diff --git a/.gitignore b/.gitignore index fe632798e0..ba51fea2b4 100644 --- a/.gitignore +++ b/.gitignore @@ -24,3 +24,10 @@ compiled/ .DS_Store *.bak TAGS + +# generated by patch +*.orig +*.rej + +# coredumps +*.core diff --git a/.travis.yml b/.travis.yml index 69b233f44b..515e07b3d6 100644 --- a/.travis.yml +++ b/.travis.yml @@ -42,7 +42,7 @@ script: - raco test -l tests/net/encoders - raco test -l tests/openssl/basic - raco test -l tests/openssl/https -- raco test -l tests/match/plt-match-tests +- raco test -l tests/match/main - raco test -l tests/zo-path - raco test -l tests/xml/test - raco test -l tests/db/all-tests diff --git a/INSTALL.txt b/INSTALL.txt index 3654772566..e7da5d0243 100644 --- a/INSTALL.txt +++ b/INSTALL.txt @@ -514,12 +514,20 @@ In more detail: `make'. The `README' value is used as a file name to download from the server. - For a Mac OS X installer, set `SIGN_IDENTITY' to sign the - installer, where the value of `SIGN_IDENTITY' is the name to + To create a ".tgz" archive instead of an installer (or any + platform), set `TGZ_MODE' to "--tgz". + + For a Mac OS X installer, set `SIGN_IDENTITY' as the name to which the signing certificate is associated. Set `MAC_PKG_MODE' to "--mac-pkg" to create a ".pkg" installer instead of a ".dmg" image. + For a Windows installer, set `OSSLSIGNCODE_ARGS_BASE64` as a + Base64 encoding of an S-expression for a list of argument strings + for `osslsigncode`. The `-n', `-t', `-in', and `-out' arguments + are provided to `osslsigncode` automatically, so supply the + others. + The `SERVER_CATALOG_PATH' and `SERVER_COLLECTS_PATH' makefile variables specify paths at `SERVER' plus `SERVER_PORT' to access the package catalog and pre-built "collects" tree needed for a diff --git a/Makefile b/Makefile index 50e6312fd5..fde73a4428 100644 --- a/Makefile +++ b/Makefile @@ -36,7 +36,11 @@ WIN32_RUN_RACKET = $(WIN32_PLAIN_RACKET) -G racket/etc -X racket/collects RUN_RACO = $(RUN_RACKET) -N raco -l- raco WIN32_RUN_RACO = $(WIN32_RUN_RACKET) -N raco -l- raco -DEFAULT_SRC_CATALOG = http://pkgs.racket-lang.org +DEFAULT_SRC_CATALOG = https://pkgs.racket-lang.org + +# Belongs in the "Configuration options" section, but here +# to accomodate nmake: +SRC_CATALOG = $(DEFAULT_SRC_CATALOG) CPUS = @@ -69,7 +73,7 @@ plain-in-place: win32-in-place: $(MAKE) win32-base - $(MAKE) win32-pkgs-catalog + $(MAKE) win32-pkgs-catalog SRC_CATALOG="$(SRC_CATALOG)" $(WIN32_RUN_RACO) pkg update $(UPDATE_PKGS_ARGS) $(WIN32_RUN_RACO) pkg install $(INSTALL_PKGS_ARGS) $(WIN32_RUN_RACO) setup --only-foreign-libs $(ALL_PLT_SETUP_OPTIONS) @@ -194,8 +198,8 @@ racket/src/build/cross/Makefile: racket/src/configure racket/src/Makefile.in # end in "_q" or "_qq", don't use any quote marks on the right-hand # side of its definition. -# Catalog for package sources: -SRC_CATALOG = $(DEFAULT_SRC_CATALOG) +# Catalog for package sources (defined above): +# SRC_CATALOG = $(DEFAULT_SRC_CATALOG) # A URL embedded in documentation for remote searches, where a Racket # version and search key are added as query fields to the URL, and "" @@ -234,6 +238,9 @@ VERSIONLESS_MODE = # instead of a ".dmg" for drag-and-drop installation: MAC_PKG_MODE = +# Set to "--tgz" to create a ".tgz" archive instead of an installer: +TGZ_MODE = + # Set to "--source --no-setup" to include packages in an installer # (or archive) only in source form: PKG_SOURCE_MODE = @@ -264,10 +271,14 @@ BUILD_STAMP = # the default as the version number: INSTALL_NAME = -# A signing identity (spaces allowed) for Mac OS X binaries in an +# For Mac OS X, a signing identity (spaces allowed) for binaries in an # installer: SIGN_IDENTITY = +# For Windows, `osslsigncode' arguments other than `-n', `-t', `-in', +# and `-out' as a Base64-encoded, S-expression, list of strings: +OSSLSIGNCODE_ARGS_BASE64 = + # URL for a README file to include in an installer (empty for none, # spaces allowed): README = http://$(SVR_PRT)/README.txt @@ -339,8 +350,10 @@ pkgs-catalog: $(RUN_RACKET) $(PKGS_CONFIG) "$(DEFAULT_SRC_CATALOG)" "$(SRC_CATALOG)" $(RUN_RACKET) racket/src/pkgs-check.rkt racket/share/pkgs-catalog +COPY_PKGS_ARGS = PLAIN_RACKET="$(WIN32_PLAIN_RACKET)" SRC_CATALOG="$(SRC_CATALOG)" + win32-pkgs-catalog: - $(MAKE) pkgs-catalog PLAIN_RACKET="$(WIN32_PLAIN_RACKET)" + $(MAKE) pkgs-catalog $(COPY_PKGS_ARGS) # ------------------------------------------------------------ # On a server platform (for an installer build): @@ -443,11 +456,12 @@ PROP_ARGS = SERVER=$(SERVER) SERVER_PORT=$(SERVER_PORT) SERVER_HOSTS="$(SERVER_H PKGS="$(PKGS)" PLAIN_RACKET="$(PLAIN_RACKET)" BUILD_STAMP="$(BUILD_STAMP)" \ RELEASE_MODE=$(RELEASE_MODE) SOURCE_MODE=$(SOURCE_MODE) \ VERSIONLESS_MODE=$(VERSIONLESS_MODE) MAC_PKG_MODE=$(MAC_PKG_MODE) \ - PKG_SOURCE_MODE="$(PKG_SOURCE_MODE)" INSTALL_NAME="$(INSTALL_NAME)"\ + PKG_SOURCE_MODE="$(PKG_SOURCE_MODE)" INSTALL_NAME="$(INSTALL_NAME)" \ DIST_NAME="$(DIST_NAME)" DIST_BASE=$(DIST_BASE) \ DIST_DIR=$(DIST_DIR) DIST_SUFFIX=$(DIST_SUFFIX) UPLOAD="$(UPLOAD)" \ - DIST_DESC="$(DIST_DESC)" README="$(README)" SIGN_IDENTITY="$(SIGN_IDENTITY)"\ - JOB_OPTIONS="$(JOB_OPTIONS)" + DIST_DESC="$(DIST_DESC)" README="$(README)" SIGN_IDENTITY="$(SIGN_IDENTITY)" \ + OSSLSIGNCODE_ARGS_BASE64="$(OSSLSIGNCODE_ARGS_BASE64)" JOB_OPTIONS="$(JOB_OPTIONS)" \ + TGZ_MODE=$(TGZ_MODE) COPY_ARGS = $(PROP_ARGS) \ SERVER_CATALOG_PATH=$(SERVER_CATALOG_PATH) SERVER_COLLECTS_PATH=$(SERVER_COLLECTS_PATH) @@ -496,9 +510,10 @@ bundle-from-server: $(RACKET) -l setup/unixstyle-install post-adjust "$(SOURCE_MODE)" "$(PKG_SOURCE_MODE)" racket bundle/racket UPLOAD_q = --readme "$(README)" --upload "$(UPLOAD)" --desc "$(DIST_DESC)" -DIST_ARGS_q = $(UPLOAD_q) $(RELEASE_MODE) $(SOURCE_MODE) $(VERSIONLESS_MODE) $(MAC_PKG_MODE) \ +DIST_ARGS_q = $(UPLOAD_q) $(RELEASE_MODE) $(SOURCE_MODE) $(VERSIONLESS_MODE) \ + $(MAC_PKG_MODE) $(TGZ_MODE) \ "$(DIST_NAME)" $(DIST_BASE) $(DIST_DIR) "$(DIST_SUFFIX)" \ - "$(SIGN_IDENTITY)" + "$(SIGN_IDENTITY)" "$(OSSLSIGNCODE_ARGS_BASE64)" # Create an installer from the build (with installed packages) that's # in "bundle/racket": diff --git a/README.txt b/README.txt index e6c1d2d36e..d1e2c2b132 100644 --- a/README.txt +++ b/README.txt @@ -5,7 +5,7 @@ License ------- Racket -Copyright (c) 2010-2015 PLT Design Inc. +Copyright (c) 2010-2016 PLT Design Inc. Racket is distributed under the GNU Lesser General Public License (LGPL). This implies that you may link Racket into proprietary diff --git a/appveyor.yml b/appveyor.yml index 06073a1ea8..d60c45daf4 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -24,7 +24,7 @@ test_script: - racket\raco.exe test -l tests/net/encoders - racket\raco.exe test -l tests/openssl/basic - racket\raco.exe test -l tests/openssl/https -- racket\raco.exe test -l tests/match/plt-match-tests +- racket\raco.exe test -l tests/match/main - racket\raco.exe test -l tests/zo-path - racket\raco.exe test -l tests/xml/test diff --git a/pkgs/at-exp-lib/LICENSE.txt b/pkgs/at-exp-lib/LICENSE.txt index 1f2645dc9c..056171aee8 100644 --- a/pkgs/at-exp-lib/LICENSE.txt +++ b/pkgs/at-exp-lib/LICENSE.txt @@ -1,5 +1,5 @@ at-exp-lib -Copyright (c) 2010-2015 PLT Design Inc. +Copyright (c) 2010-2016 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link this package into proprietary diff --git a/pkgs/base/LICENSE.txt b/pkgs/base/LICENSE.txt index 7396cb7383..9a979f3f73 100644 --- a/pkgs/base/LICENSE.txt +++ b/pkgs/base/LICENSE.txt @@ -1,5 +1,5 @@ base -Copyright (c) 2010-2015 PLT Design Inc. +Copyright (c) 2010-2016 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link this package into proprietary diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 8918b1c225..6c64727430 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.3.0.2") +(define version "6.4.0.1") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/LICENSE.txt b/pkgs/racket-doc/LICENSE.txt index 51edf17571..a13beb37cf 100644 --- a/pkgs/racket-doc/LICENSE.txt +++ b/pkgs/racket-doc/LICENSE.txt @@ -1,5 +1,5 @@ racket-doc -Copyright (c) 2010-2015 PLT Design Inc. +Copyright (c) 2010-2016 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link this package into proprietary diff --git a/pkgs/racket-doc/compatibility/scribblings/package.scrbl b/pkgs/racket-doc/compatibility/scribblings/package.scrbl index 16f5939195..278b64082d 100644 --- a/pkgs/racket-doc/compatibility/scribblings/package.scrbl +++ b/pkgs/racket-doc/compatibility/scribblings/package.scrbl @@ -2,7 +2,7 @@ @(require scribblings/reference/mz (for-label compatibility/package)) @(define pack-eval (make-base-eval)) -@interaction-eval[#:eval pack-eval (require compatibility/package)] +@examples[#:hidden #:eval pack-eval (require compatibility/package)] @title[#:tag "compatibility-package"]{Limiting Scope: @racket[define-package], @racket[open-package], ...} @@ -61,11 +61,11 @@ is the exported one. (define-package presents (doll) (define doll "Molly Coddle") (define robot "Destructo")) -doll -robot +(eval:error doll) +(eval:error robot) (open-package presents) doll -robot +(eval:error robot) (define-package big-russian-doll (middle-russian-doll) (define-package middle-russian-doll (little-russian-doll) (define little-russian-doll "Anastasia"))) @@ -95,7 +95,7 @@ the defined bindings remain hidden outside the (package-begin (define secret "mimi") (list secret)) -secret +(eval:error secret) ]} @deftogether[( diff --git a/pkgs/racket-doc/file/scribblings/tar.scrbl b/pkgs/racket-doc/file/scribblings/tar.scrbl index 3f2232f65a..618a1d4d3b 100644 --- a/pkgs/racket-doc/file/scribblings/tar.scrbl +++ b/pkgs/racket-doc/file/scribblings/tar.scrbl @@ -11,14 +11,16 @@ directories, files, and symbolic links, and owner information is not preserved; the owner that is stored in the archive is always ``root.'' -Symbolic links (on Unix and Mac OS X) are not followed, and the path +Symbolic links (on Unix and Mac OS X) are not followed by default, and the path in a link must be less than 100 bytes.} @defproc[(tar [tar-file path-string?] [path path-string?] ... + [#:follow-links? follow-links? any/c #f] [#:exists-ok? exists-ok? any/c #f] [#:path-prefix path-prefix (or/c #f path-string?) #f] + [#:path-filter path-filter (or/c #f (path? . -> . any/c)) #f] [#:get-timestamp get-timestamp (path? . -> . exact-integer?) (if timestamp @@ -32,7 +34,8 @@ relative paths for existing directories and files (i.e., relative to the current directory). If a nested path is provided as a @racket[path], its ancestor directories are also added to the resulting tar file, up to the current directory (using -@racket[pathlist-closure]). +@racket[pathlist-closure]). If @racket[follow-links?] is false, then +symbolic links are included in the resulting tar file as links. If @racket[exists-ok?] is @racket[#f], then an exception is raised if @racket[tar-file] exists already. If @racket[exists-ok?] is true, then @@ -45,12 +48,16 @@ The @racket[get-timestamp] function is used to obtain the modification date to record in the archive for each file or directory. @history[#:changed "6.0.0.3" @elem{Added the @racket[#:get-timestamp] argument.} - #:changed "6.1.1.1" @elem{Added the @racket[#:exists-ok?] argument.}]} + #:changed "6.1.1.1" @elem{Added the @racket[#:exists-ok?] argument.} + #:changed "6.3.0.3" @elem{Added the @racket[#:follow-links?] argument.} + #:changed "6.3.0.11" @elem{Added the @racket[#:path-filter] argument.}]} @defproc[(tar->output [paths (listof path?)] [out output-port? (current-output-port)] + [#:follow-links? follow-links? any/c #f] [#:path-prefix path-prefix (or/c #f path-string?) #f] + [#:path-filter path-filter (or/c #f (path? . -> . any/c)) #f] [#:get-timestamp get-timestamp (path? . -> . exact-integer?) (if timestamp @@ -64,11 +71,14 @@ archive that is written directly to the @racket[out]. The specified content is not automatically added, and nested directories are added without parent directories. -@history[#:changed "6.0.0.3" @elem{Added the @racket[#:get-timestamp] argument.}]} +@history[#:changed "6.0.0.3" @elem{Added the @racket[#:get-timestamp] argument.} + #:changed "6.3.0.3" @elem{Added the @racket[#:follow-links?] argument.} + #:changed "6.3.0.11" @elem{Added the @racket[#:path-filter] argument.}]} @defproc[(tar-gzip [tar-file path-string?] [paths path-string?] ... + [#:follow-links? follow-links? any/c #f] [#:exists-ok? exists-ok? any/c #f] [#:path-prefix path-prefix (or/c #f path-string?) #f] [#:get-timestamp get-timestamp @@ -81,4 +91,5 @@ without parent directories. Like @racket[tar], but compresses the resulting file with @racket[gzip]. @history[#:changed "6.0.0.3" @elem{Added the @racket[#:get-timestamp] argument.} - #:changed "6.1.1.1" @elem{Added the @racket[#:exists-ok?] argument.}]} + #:changed "6.1.1.1" @elem{Added the @racket[#:exists-ok?] argument.} + #:changed "6.3.0.3" @elem{Added the @racket[#:follow-links?] argument.}]} diff --git a/pkgs/racket-doc/info.rkt b/pkgs/racket-doc/info.rkt index 48eca51fa1..e80f691186 100644 --- a/pkgs/racket-doc/info.rkt +++ b/pkgs/racket-doc/info.rkt @@ -6,7 +6,7 @@ "base" "net-lib" "sandbox-lib" - "scribble-lib" + ["scribble-lib" #:version "1.14"] "racket-index")) (define build-deps '("rackunit-doc" "compatibility" diff --git a/pkgs/racket-doc/openssl/openssl.scrbl b/pkgs/racket-doc/openssl/openssl.scrbl index 2562743e47..3911dd893a 100644 --- a/pkgs/racket-doc/openssl/openssl.scrbl +++ b/pkgs/racket-doc/openssl/openssl.scrbl @@ -29,8 +29,10 @@ or with the Racket distribution. In particular: included in the Racket distribution for Windows.} @item{For Mac OS X, @racketmodname[openssl] depends on -@filepath{libssl.dylib} and @filepath{libcrypto.dylib}, which are -provided by Mac OS X 10.2 and later.} +@filepath{libssl.dylib} and @filepath{libcrypto.dylib}. Although those +libraries are provided by Mac OS X 10.2 and later, their use is +deprecated, so the Racket distribution for Mac OS X includes newer +versions.} @item{For Unix, @racketmodname[openssl] depends on @filepath{libssl.so} and @filepath{libcrypto.so}, which must be @@ -66,7 +68,9 @@ using the functions described in @secref["cert-procs"]. [port-no (integer-in 1 65535)] [client-protocol (or/c ssl-client-context? - 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) + 'secure + 'auto + 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) 'auto]) (values input-port? output-port?)]{ @@ -75,6 +79,10 @@ Connect to the host given by @racket[hostname], on the port given by return values are as for @racket[tcp-connect]: an input port and an output port. +The default @racket['auto] protocol is @bold{insecure}. Use +@racket['secure] for a secure connection. See +@racket[ssl-secure-client-context] for details. + The optional @racket[client-protocol] argument determines which encryption protocol is used, whether the server's certificate is checked, etc. The argument can be either a client context created by @@ -104,14 +112,16 @@ well-defined communication pattern, where theres no question of whether the other end is supposed to be sending or reading data. } -} +@history[#:changed "6.3.0.12" @elem{Added @racket['secure] for + @racket[client-protocol].}]} @defproc[(ssl-connect/enable-break [hostname string?] [port-no (integer-in 1 65535)] [client-protocol (or/c ssl-client-context? - 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) + 'secure 'auto + 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) 'auto]) (values input-port? output-port?)]{ @@ -149,11 +159,13 @@ The context is cached, so different calls to @defproc[(ssl-make-client-context - [protocol (or/c 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) 'auto]) + [protocol (or/c 'secure 'auto + 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) + 'auto]) ssl-client-context?]{ Creates a context to be supplied to @racket[ssl-connect]. The context -is @bold{insecure} unless additional steps are taken; see +is @bold{insecure} unless @racket['secure] is supplied or additional steps are taken; see @racket[ssl-secure-client-context] for details. The client context identifies a communication protocol (as selected by @@ -164,6 +176,7 @@ certificates. The @racket[protocol] should be one of the following: @itemize[ +@item{@racket['secure] : Equivalent to @racket[(ssl-secure-client-context)].} @item{@racket['auto] : Automatically negotiates the protocol version from those that this library considers sufficiently secure---currently TLS versions 1.0 and higher, but subject to change.} @@ -182,27 +195,29 @@ Note that SSL 2.0 support has been removed from many platforms.} ] Not all protocol versions are supported by all servers. The -@racket['auto] option offers broad compatibility at a reasonable level +@racket['secure] and @racket['auto] options offer broad compatibility at a reasonable level of security. Note that the security of connections depends on more than the protocol version; see @racket[ssl-secure-client-context] for -details. - -Not all protocol versions are available on all platforms. See also +details. See also @racket[supported-client-protocols] and @racket[supported-server-protocols]. @history[ #:changed "6.1" @elem{Added @racket['tls11] and @racket['tls12].} #:changed "6.1.1.3" @elem{Default to new @racket['auto] and disabled SSL -2.0 and 3.0 by default.} + 2.0 and 3.0 by default.} +#:changed "6.3.0.12" @elem{Added @racket['secure].} ]} @defproc[(supported-client-protocols) - (listof (or/c 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12))]{ + (listof (or/c 'secure 'auto + 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12))]{ Returns a list of symbols representing protocols that are supported -for clients on the current platform.} +for clients on the current platform. + +@history[#:changed "6.3.0.12" @elem{Added @racket['secure].}]} @defproc[(ssl-client-context? [v any/c]) boolean?]{ @@ -212,7 +227,7 @@ Returns @racket[#t] if @racket[v] is a value produced by @history[#:added "6.0.1.3"]} -@defproc[(ssl-max-client-protocol) (or/c 'sslv2 sslv3 'tls 'tls11 'tls12 #f)]{ +@defproc[(ssl-max-client-protocol) (or/c 'sslv2 'sslv3 'tls 'tls11 'tls12 #f)]{ Returns the most recent SSL/TLS protocol version supported by the current platform for client connections. @@ -231,13 +246,15 @@ current platform for client connections. [hostname-or-#f (or/c string? #f) #f] [server-protocol (or/c ssl-server-context? - 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) + 'secure 'auto + 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) 'auto]) ssl-listener?]{ Like @racket[tcp-listen], but the result is an SSL listener. The extra optional @racket[server-protocol] is as for @racket[ssl-connect], except that a -context must be a server context instead of a client context. +context must be a server context instead of a client context, and +@racket['secure] is simply an alias for @racket['auto]. Call @racket[ssl-load-certificate-chain!] and @racket[ssl-load-private-key!] to avoid a @emph{no shared cipher} @@ -250,7 +267,9 @@ An SSL listener is a synchronizable value (see @racket[sync]). It is ready---with itself as its value---when the underlying TCP listener is ready. At that point, however, accepting a connection with @racket[ssl-accept] may not complete immediately, because -further communication is needed to establish the connection.} +further communication is needed to establish the connection. + +@history[#:changed "6.3.0.12" @elem{Added @racket['secure].}]} @deftogether[( @@ -298,11 +317,16 @@ Returns @racket[#t] of @racket[v] is an SSL port produced by @defproc[(ssl-make-server-context - [protocol (or/c 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) + [protocol (or/c 'secure 'auto + 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) 'auto]) ssl-server-context?]{ -Like @racket[ssl-make-client-context], but creates a server context.} +Like @racket[ssl-make-client-context], but creates a server context. +For a server context, the @racket['secure] protocol is the same as +@racket['auto]. + +@history[#:changed "6.3.0.12" @elem{Added @racket['secure].}]} @defproc[(ssl-server-context? [v any/c]) boolean?]{ @@ -311,14 +335,16 @@ Returns @racket[#t] if @racket[v] is a value produced by @racket[ssl-make-server-context], @racket[#f] otherwise.} @defproc[(supported-server-protocols) - (listof (or/c 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12))]{ + (listof (or/c 'secure 'auto + 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12))]{ Returns a list of symbols representing protocols that are supported for servers on the current platform. -@history[#:added "6.0.1.3"]} +@history[#:added "6.0.1.3" + #:changed "6.3.0.12" @elem{Added @racket['secure].}]} -@defproc[(ssl-max-server-protocol) (or/c 'sslv2 sslv3 'tls 'tls11 'tls12 #f)]{ +@defproc[(ssl-max-server-protocol) (or/c 'sslv2 'sslv3 'tls 'tls11 'tls12 #f)]{ Returns the most recent SSL/TLS protocol version supported by the current platform for server connections. @@ -340,7 +366,8 @@ current platform for server connections. ssl-make-server-context ssl-make-client-context) protocol)] - [#:encrypt protocol (or/c 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) + [#:encrypt protocol (or/c 'secure 'auto + 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12) 'auto] [#:close-original? close-original? boolean? #f] [#:shutdown-on-close? shutdown-on-close? boolean? #f] diff --git a/pkgs/racket-doc/pkg/scribblings/apis.scrbl b/pkgs/racket-doc/pkg/scribblings/apis.scrbl index 437eef5d85..5a816382c9 100644 --- a/pkgs/racket-doc/pkg/scribblings/apis.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/apis.scrbl @@ -53,3 +53,4 @@ to the @exec{raco pkg} sub-subcommands. @include-section["name.scrbl"] @include-section["db.scrbl"] @include-section["dirs-catalog.scrbl"] +@include-section["envvars.scrbl"] diff --git a/pkgs/racket-doc/pkg/scribblings/envvars.scrbl b/pkgs/racket-doc/pkg/scribblings/envvars.scrbl new file mode 100644 index 0000000000..aba0a744ee --- /dev/null +++ b/pkgs/racket-doc/pkg/scribblings/envvars.scrbl @@ -0,0 +1,14 @@ +#lang scribble/manual +@(require "common.rkt") + +@title[#:tag "envvars"]{Package Management Environment Variables} + +If the @indexed-envvar{PLT_PKG_SSL_NO_VERIFY} environment variable is +set, server certificates are not validated for HTTPS connections. When +accessing Git servers over HTTPS, @envvar{GIT_SSL_NO_VERIFY} must be +set, too, to disable certificate validation. + +As noted in the specification of GitHub-repository package sources, if +the @envvar{PLT_USE_GITHUB_API} environment variable is set, GitHub +packages are obtained using the GitHub API protocol instead of using +the Git protocol. diff --git a/pkgs/racket-doc/pkg/scribblings/getting-started.scrbl b/pkgs/racket-doc/pkg/scribblings/getting-started.scrbl index 477148d7ea..65cde89410 100644 --- a/pkgs/racket-doc/pkg/scribblings/getting-started.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/getting-started.scrbl @@ -131,7 +131,7 @@ treated as a explicitly installed package. The PLT @tech{package catalog} at -@centerline{@url{http://pkgs.racket-lang.org}} +@centerline{@url{https://pkgs.racket-lang.org}} provides a centralized listing of available Racket packages. The PLT @tech{package catalog} normally will be the first place you check when @@ -445,7 +445,7 @@ by a simple name until it is listed on a @tech{package catalog}. If you'd like to use the PLT @tech{package catalog}, browse to -@link["http://pkgs.racket-lang.org/"]{http://pkgs.racket-lang.org/} +@link["https://pkgs.racket-lang.org/"]{https://pkgs.racket-lang.org/} and upload a new package. You will need to create an account and log in first. @@ -558,7 +558,7 @@ In your @racket[info.rkt], you should: ] Finally, when listing your package on -@url{http://pkgs.racket-lang-org}, you should supply a GitHub source +@url{https://pkgs.racket-lang-org}, you should supply a GitHub source using the URL format @tt{github://github.com/@nonterm{user}/@nonterm{repo}/@nonterm{rev}@optional{/@nonterm{path}}} (not the @tt{git://} or @exec{http://} format). diff --git a/pkgs/racket-doc/pkg/scribblings/git-workflow.scrbl b/pkgs/racket-doc/pkg/scribblings/git-workflow.scrbl index 1c334de087..f7601c987d 100644 --- a/pkgs/racket-doc/pkg/scribblings/git-workflow.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/git-workflow.scrbl @@ -102,7 +102,7 @@ develops only a few of them. The intended workflow is as follows: @commandline{@command{update} --lookup --catalog @nonterm{catalog} --clone @nonterm{path-to}/@nonterm{pkg-name}} - A suitable @nonterm{catalog} might be @url{http://pkgs.racket-lang.org}.} + A suitable @nonterm{catalog} might be @url{https://pkgs.racket-lang.org}.} @item{A newly cloned package will have the specified (or existing installation's) repository as its Git @exec{origin}. If you want to diff --git a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl index d21a87beef..cc4b025c5e 100644 --- a/pkgs/racket-doc/pkg/scribblings/pkg.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/pkg.scrbl @@ -337,7 +337,7 @@ URL indicates a remote server, and a @litchar{file://} URL indicates a local catalog in the form of an SQLite database or a directory tree. PLT supports two @tech{package catalog} servers that are enabled by -default: @url{http://pkgs.racket-lang.org} for new packages and +default: @url{https://pkgs.racket-lang.org} for new packages and @url{http://planet-compats.racket-lang.org} for automatically generated packages for old @|PLaneT| packages. Anyone may host a @tech{package catalog}, and any file-serving HTTP host can act @@ -1426,10 +1426,10 @@ tests, and documentation from a package before installing it. site (where a Racket distribution downloaded from the site is configured to consult the site for packages), at least for packages associated with the distribution. Beware that -@url{http://pkgs.racket-lang.org/} generally refers to @tech{source +@url{https://pkgs.racket-lang.org/} generally refers to @tech{source packages}, not @tech{built packages}. In the near future, built -variants of the @url{http://pkgs.racket-lang.org/} packages will be -provided at @url{http://pkg-build.racket-lang.org/catalog/}. +variants of the @url{https://pkgs.racket-lang.org/} packages will be +provided at @url{https://pkg-build.racket-lang.org/catalog/}. Some packages have been split at the source level into separate library, test, and documentation packages. For example, diff --git a/pkgs/racket-doc/scribblings/foreign/com-auto.scrbl b/pkgs/racket-doc/scribblings/foreign/com-auto.scrbl index c10cbaeb34..e295970af7 100644 --- a/pkgs/racket-doc/scribblings/foreign/com-auto.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/com-auto.scrbl @@ -209,6 +209,14 @@ A constant for use with @racket[com-invoke] in place of an optional argument.} +@defproc[(com-omit? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is @racket[com-omit], @racket[#f] +otherwise. + +@history[#:added "6.3.0.3"]} + + @; ---------------------------------------- @section{COM Properties} diff --git a/pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-doc/scribblings/foreign/types.scrbl index 32b4d78a61..3225084e58 100644 --- a/pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/types.scrbl @@ -1081,7 +1081,8 @@ below for a more efficient approach. (property (code:line #:alignment alignment-expr) (code:line #:malloc-mode malloc-mode-expr) (code:line #:property prop-expr val-expr) - #:no-equal)] + #:no-equal + #:define-unsafe)] #:contracts ([offset-expr exact-integer?] [alignment-expr (or/c #f 1 2 4 8 16)] [malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic @@ -1130,7 +1131,16 @@ The resulting bindings are as follows: @item{@racketidfont{set-}@racketvarfont{id}@racketidfont{-}@racket[field-id]@racketidfont{!} : a mutator function for each @racket[field-id].} - @item{@racketvarfont{id}: structure-type information compatible with + @item{@racketvarfont{id}@racketidfont{-}@racket[field-id]@racketidfont{-offset} + : the absolute offset, in bytes, of each @racket[field-id], if @racket[#:define-unsafe] is present.} + + @item{@racketidfont{unsafe-}@racketvarfont{id}@racketidfont{-}@racket[field-id] + : an unsafe accessor function for each @racket[field-id], if @racket[#:define-unsafe] is present.} + + @item{@racketidfont{unsafe-set-}@racketvarfont{id}@racketidfont{-}@racket[field-id]@racketidfont{!} + : an unsafe mutator function for each @racket[field-id], if @racket[#:define-unsafe] is present.} + +@item{@racketvarfont{id}: structure-type information compatible with @racket[struct-out] or @racket[match] (but not @racket[struct] or @racket[define-struct]); currently, this information is correct only when no @racket[super-id] @@ -1328,7 +1338,8 @@ expects arguments for both the super fields and the new ones: ] @history[#:changed "6.0.0.6" @elem{Added @racket[#:malloc-mode].} - #:changed "6.1.1.8" @elem{Added @racket[#:offset] for fields.}]} +#:changed "6.1.1.8" @elem{Added @racket[#:offset] for fields.} +#:changed "6.3.0.13" @elem{Added @racket[#:define-unsafe].}]} @; ------------------------------------------------------------ diff --git a/pkgs/racket-doc/scribblings/guide/define-struct.scrbl b/pkgs/racket-doc/scribblings/guide/define-struct.scrbl index b5481a95fc..c458eee8c3 100644 --- a/pkgs/racket-doc/scribblings/guide/define-struct.scrbl +++ b/pkgs/racket-doc/scribblings/guide/define-struct.scrbl @@ -453,7 +453,7 @@ A @racket[_struct-option] always starts with a keyword: @racket[#:auto] field option. The constructor procedure does not accept arguments for automatic fields. Automatic fields are implicitly mutable (via reflective operations), but mutator - functions are bound only if @racket[#:mutator] is also specified. + functions are bound only if @racket[#:mutable] is also specified. @defexamples[ (struct posn (x y [z #:auto]) diff --git a/pkgs/racket-doc/scribblings/guide/guide.scrbl b/pkgs/racket-doc/scribblings/guide/guide.scrbl index 9a868c8db5..2f4a09b52a 100644 --- a/pkgs/racket-doc/scribblings/guide/guide.scrbl +++ b/pkgs/racket-doc/scribblings/guide/guide.scrbl @@ -16,7 +16,7 @@ into details---covering much of the Racket toolbox, but leaving precise details to @|Racket| and other reference manuals. @margin-note{The source of this manual is available on -@hyperlink["https://github.com/plt/racket/tree/master/pkgs/racket-doc/scribblings/guide"]{GitHub}.} +@hyperlink["https://github.com/racket/racket/tree/master/pkgs/racket-doc/scribblings/guide"]{GitHub}.} @table-of-contents[] diff --git a/pkgs/racket-doc/scribblings/guide/io.scrbl b/pkgs/racket-doc/scribblings/guide/io.scrbl index 75c2066666..e578521353 100644 --- a/pkgs/racket-doc/scribblings/guide/io.scrbl +++ b/pkgs/racket-doc/scribblings/guide/io.scrbl @@ -69,10 +69,11 @@ file: (close-output-port out) ] -Instead of having to match @racket[open-input-file] and -@racket[open-output-file] calls, most Racket programmers will instead -use @racket[call-with-output-file], which takes a function to call -with the output port; when the function returns, the port is closed. +Instead of having to match the open calls with close calls, most Racket +programmers will use the @racket[call-with-input-file] and +@racket[call-with-output-file] functions which take a function to call to carry +out the desired operation. This function gets as its only argument the port, +which is automatically opened and closed for the operation. @examples[ #:eval io-eval @@ -318,7 +319,7 @@ Other structure types created by @racket[struct], which offer more abstraction than @tech{prefab} structure types, normally @racket[write] either using @racketresultfont{#<....>} notation (for opaque structure types) or using @racketresultfont{#(....)} vector -notation (for transparent structure types). In neither can the +notation (for transparent structure types). In neither case can the result be read back in as an instance of the structure type: @interaction[ diff --git a/pkgs/racket-doc/scribblings/guide/let.scrbl b/pkgs/racket-doc/scribblings/guide/let.scrbl index 6611e653f9..b09855a43d 100644 --- a/pkgs/racket-doc/scribblings/guide/let.scrbl +++ b/pkgs/racket-doc/scribblings/guide/let.scrbl @@ -79,11 +79,11 @@ The difference is that each @racket[_id] is available for use in later visible one. @examples[ -(let* ([x (list "Borroughs")] +(let* ([x (list "Burroughs")] [y (cons "Rice" x)] [z (cons "Edgar" y)]) (list x y z)) -(let* ([name (list "Borroughs")] +(let* ([name (list "Burroughs")] [name (cons "Rice" name)] [name (cons "Edgar" name)]) name) @@ -93,7 +93,7 @@ In other words, a @racket[let*] form is equivalent to nested @racket[let] forms, each with a single binding: @interaction[ -(let ([name (list "Borroughs")]) +(let ([name (list "Burroughs")]) (let ([name (cons "Rice" name)]) (let ([name (cons "Edgar" name)]) name))) diff --git a/pkgs/racket-doc/scribblings/guide/lists.scrbl b/pkgs/racket-doc/scribblings/guide/lists.scrbl index c7bb8f1bac..663031eadc 100644 --- a/pkgs/racket-doc/scribblings/guide/lists.scrbl +++ b/pkgs/racket-doc/scribblings/guide/lists.scrbl @@ -74,15 +74,7 @@ by @racket[and]ing or @racket[or]ing: (ormap number? (list "a" "b" 6)) ] -The @racket[filter] function keeps elements for which the body result -is true, and discards elements for which it is @racket[#f]: - -@interaction[ -(filter string? (list "a" "b" 6)) -(filter positive? (list 1 -2 6 7 0)) -] - -The @racket[map], @racket[andmap], @racket[ormap], and @racket[filter] +The @racket[map], @racket[andmap], and @racket[ormap] functions can all handle multiple lists, instead of just a single list. The lists must all have the same length, and the given function must accept one argument for each list: @@ -93,6 +85,14 @@ must accept one argument for each list: (list 6 3 7)) ] +The @racket[filter] function keeps elements for which the body result +is true, and discards elements for which it is @racket[#f]: + +@interaction[ +(filter string? (list "a" "b" 6)) +(filter positive? (list 1 -2 6 7 0)) +] + The @racket[foldl] function generalizes some iteration functions. It uses the per-element function to both process an element and combine it with the ``current'' value, so the per-element function takes an diff --git a/pkgs/racket-doc/scribblings/guide/macros.scrbl b/pkgs/racket-doc/scribblings/guide/macros.scrbl index 8da7bd9ab3..963f4c5077 100644 --- a/pkgs/racket-doc/scribblings/guide/macros.scrbl +++ b/pkgs/racket-doc/scribblings/guide/macros.scrbl @@ -15,6 +15,8 @@ make simple transformations easy to implement and reliable to use. Racket also supports arbitrary macro transformers that are implemented in Racket---or in a macro-extended variant of Racket. +(For a bottom-up introduction of Racket macro, you may refer to: @(hyperlink "http://www.greghendershott.com/fear-of-macros/" "Fear of Macros")) + @local-table-of-contents[] @;------------------------------------------------------------------------ diff --git a/pkgs/racket-doc/scribblings/guide/other.scrbl b/pkgs/racket-doc/scribblings/guide/other.scrbl index 1a9b8ea633..7134bfa9dc 100644 --- a/pkgs/racket-doc/scribblings/guide/other.scrbl +++ b/pkgs/racket-doc/scribblings/guide/other.scrbl @@ -28,7 +28,7 @@ many other installed libraries. Run @exec{raco docs} to find documentation for libraries that are installed on your system and specific to your user account. -@link["http://pkgs.racket-lang.org/"]{The Racket package repository} +@link["https://pkgs.racket-lang.org/"]{The Racket package repository} offer even more downloadable packages that are contributed by Racketeers. diff --git a/pkgs/racket-doc/scribblings/guide/pattern-macros.scrbl b/pkgs/racket-doc/scribblings/guide/pattern-macros.scrbl index a9e790d4a1..48440d9c2b 100644 --- a/pkgs/racket-doc/scribblings/guide/pattern-macros.scrbl +++ b/pkgs/racket-doc/scribblings/guide/pattern-macros.scrbl @@ -453,11 +453,11 @@ Step-by-step, expansion proceeds as follows: @racketblock[ (define-for-cbr do-f (a b) () (swap a b)) -=> (define-for-cbr do-f (b) +(unsyntax @tt{=>}) (define-for-cbr do-f (b) ([a get_1 put_1]) (swap a b)) -=> (define-for-cbr do-f () +(unsyntax @tt{=>}) (define-for-cbr do-f () ([a get_1 put_1] [b get_2 put_2]) (swap a b)) -=> (define (do-f get_1 get_2 put_1 put_2) +(unsyntax @tt{=>}) (define (do-f get_1 get_2 put_1 put_2) (define-get/put-id a get_1 put_1) (define-get/put-id b get_2 put_2) (swap a b)) diff --git a/pkgs/racket-doc/scribblings/guide/performance.scrbl b/pkgs/racket-doc/scribblings/guide/performance.scrbl index a827026c7f..e647146b2c 100644 --- a/pkgs/racket-doc/scribblings/guide/performance.scrbl +++ b/pkgs/racket-doc/scribblings/guide/performance.scrbl @@ -471,7 +471,7 @@ then the expansion of the @racket[let] form to implement automatically converts the closure to pass itself @racket[n] as an argument instead. -@section{Reachability and Garbage Collection} +@section[#:tag "Reachability and Garbage Collection"]{Reachability and Garbage Collection} In general, Racket re-uses the storage for a value when the garbage collector can prove that the object is unreachable from @@ -534,7 +534,7 @@ There are a number of exceptions, however: @item{Interned symbols are allocated only once (per place). A table inside Racket tracks this allocation so a symbol may not become garbage because that table holds onto it.} - @item{Reachability is only approximate with the CGC collector (i.e., + @item{Reachability is only approximate with the @tech{CGC} collector (i.e., a value may appear reachable to that collector when there is, in fact, no way to reach it anymore.}] @@ -577,3 +577,53 @@ occurrence of the variable @racket[_fishes]. That constitutes a reference to the list, ensuring that the list is not itself garbage collected, and thus the red fish is not either. + +@section{Reducing Garbage Collection Pauses} + +By default, Racket's @tech{generational garbage collector} creates +brief pauses for frequent @deftech{minor collections}, which inspect +only the most recently allocated objects, and long pauses for infrequent +@deftech{major collections}, which re-inspect all memory. + +For some applications, such as animations and games, +long pauses due to a major collection can interfere +unacceptably with a program's operation. To reduce major-collection +pauses, the Racket garbage collector supports @deftech{incremental +garbage-collection} mode. In incremental mode, minor collections +create longer (but still relatively short) pauses by performing extra +work toward the next major collection. If all goes well, most of a +major collection's work has been performed by minor collections the +time that a major collection is needed, so the major collection's +pause is as short as a minor collection's pause. Incremental mode +tends to run more slowly overall, but it can +provide much more consistent real-time behavior. + +If the @envvar{PLT_INCREMENTAL_GC} environment variable is set +to a value that starts with @litchar{1}, @litchar{y}, or @litchar{Y} +when Racket starts, incremental mode is permanently enabled. Since +incremental mode is only useful for certain parts of some programs, +however, and since the need for incremental mode is a property of a +program rather than its environment, the preferred way to enable +incremental mode is with @racket[(collect-garbage 'incremental)]. + +Calling @racket[(collect-garbage 'incremental)] does not perform an +immediate garbage collection, but instead requests that each minor +collection perform incremental work up to the next major collection. +The request expires with the next major collection. Make a call to +@racket[(collect-garbage 'incremental)] in any repeating task within +an application that needs to be responsive in real time. Force a +full collection with @racket[(collect-garbage)] just before an initial +@racket[(collect-garbage 'incremental)] to initiate incremental mode +from an optimal state. + +To check whether incremental mode is use and how it affects pause +times, enable @tt{debug}-level logging output for the +@racketidfont{GC} topic. For example, + +@commandline{racket -W "debuG@"@"GC error" main.rkt} + +runs @filepath{main.rkt} with garbage-collection logging to stderr +(while preserving @tt{error}-level logging for all topics). Minor +collections are reported by @litchar{min} lines, increment-mode minor +collection are reported with @litchar{mIn} lines, and major +collections are reported with @litchar{MAJ} lines. diff --git a/pkgs/racket-doc/scribblings/inside/embedding.scrbl b/pkgs/racket-doc/scribblings/inside/embedding.scrbl index 96c0c58433..f9ace6984e 100644 --- a/pkgs/racket-doc/scribblings/inside/embedding.scrbl +++ b/pkgs/racket-doc/scribblings/inside/embedding.scrbl @@ -1,5 +1,6 @@ #lang scribble/doc -@(require "utils.rkt") +@(require "utils.rkt" + scribble/bnf) @(define cgc-v-3m "CGC versus 3m") @@ -114,16 +115,28 @@ To embed Racket CGC in a program, follow these steps: into the top-level environment. To embed a module like @racketmodname[racket/base] (along with all - its dependencies), use @exec{raco ctool --c-mods}, which generates a C file + its dependencies), use + @seclink["c-mods" #:doc raco-doc]{@exec{raco ctool --c-mods @nonterm{dest}}}, + which generates a C file @nonterm{dest} that contains modules in bytecode form as encapsulated in a static array. The generated C file defines a @cppi{declare_modules} function that takes a @cpp{Scheme_Env*}, installs the modules into the environment, and adjusts the module name resolver to access the - embedded declarations. + embedded declarations. If embedded modules refer to runtime files + that need to be carried along, supply @DFlag{runtime} to + @exec{raco ctool --c-mods} to collect the runtime files into a + directory; see @secref[#:doc raco-doc "c-mods"] for more information. - Alternately, use @cpp{scheme_set_collects_path} and + Alternatively, use @cpp{scheme_set_collects_path} and @cpp{scheme_init_collection_paths} to configure and install a path - for finding modules at run time.} + for finding modules at run time. + + On Windows, @exec{raco ctool --c-mods @nonterm{dest} --runtime + @nonterm{dest-dir}} includes in @nonterm{dest-dir} optional DLLs + that are referenced by the Racket library to support @tech[#:doc + reference-doc]{extflonums} and @racket[bytes-open-converter]. Call + @cpp{scheme_set_dll_path} to register @nonterm{dest-dir} so that + those DLLs can be found at run time.} @item{Access Racket through @cppi{scheme_dynamic_require}, @cppi{scheme_load}, @cppi{scheme_eval}, and/or other functions diff --git a/pkgs/racket-doc/scribblings/inside/hooks.scrbl b/pkgs/racket-doc/scribblings/inside/hooks.scrbl index eb6a5ec9c3..774312abbd 100644 --- a/pkgs/racket-doc/scribblings/inside/hooks.scrbl +++ b/pkgs/racket-doc/scribblings/inside/hooks.scrbl @@ -91,6 +91,15 @@ Like @cpp{scheme_init_collection_paths_post}, but with @racket[null] as the last argument.} +@function[(void scheme_set_dll_path + [wchar_t* path])]{ + +On Windows only, sets the path used to find optional DLLs that are used +by the runtime system: @filepath{longdouble.dll} and one of @filepath{iconv.dll}, +@filepath{libiconv.dll}, or @filepath{libiconv-2.dll}. The given @var{path} +should be an absolute path.} + + @function[(void scheme_seal_parameters)]{ Takes a snapshot of the current values of built-in parameters. These diff --git a/pkgs/racket-doc/scribblings/inside/overview.scrbl b/pkgs/racket-doc/scribblings/inside/overview.scrbl index be196db743..658422b4af 100644 --- a/pkgs/racket-doc/scribblings/inside/overview.scrbl +++ b/pkgs/racket-doc/scribblings/inside/overview.scrbl @@ -41,7 +41,7 @@ source distribution from @url{http://download.racket-lang.org}; detailed build instructions are in the @filepath{README} file in the top-level @filepath{src} directory. You can also get the latest sources from the @tt{git} repository at -@url{https://github.com/plt/racket}, but beware that the repository is +@url{https://github.com/racket/racket}, but beware that the repository is one step away from a normal source distribution, and it provides build modes that are more suitable for developing Racket itself; see @filepath{INSTALL.txt} in the @tt{git} repository for more diff --git a/pkgs/racket-doc/scribblings/inside/params.scrbl b/pkgs/racket-doc/scribblings/inside/params.scrbl index c0659feede..9602b8edb0 100644 --- a/pkgs/racket-doc/scribblings/inside/params.scrbl +++ b/pkgs/racket-doc/scribblings/inside/params.scrbl @@ -45,6 +45,13 @@ through the following indices: @item{@cppdef{MZCONFIG_CAN_READ_COMPILED} --- @racket[read-accept-compiled]} @item{@cppdef{MZCONFIG_CAN_READ_BOX} --- @racket[read-accept-box]} @item{@cppdef{MZCONFIG_CAN_READ_PIPE_QUOTE} --- @racket[read-accept-bar-quote]} +@item{@cppdef{MZCONFIG_CAN_READ_DOT} --- @racket[read-accept-dot]} +@item{@cppdef{MZCONFIG_CAN_READ_INFIX_DOT} --- @racket[read-accept-infix-dot]} +@item{@cppdef{MZCONFIG_CAN_READ_QUASI} --- @racket[read-accept-quasiquote]} +@item{@cppdef{MZCONFIG_CAN_READ_READER} --- @racket[read-accept-reader]} +@item{@cppdef{MZCONFIG_CAN_READ_LANG} --- @racket[read-accept-lang]} +@item{@cppdef{MZCONFIG_READ_DECIMAL_INEXACT} --- @racket[read-decimal-as-inexact]} +@item{@cppdef{MZCONFIG_READ_CDOT} --- @racket[read-cdot]} @item{@cppdef{MZCONFIG_PRINT_GRAPH} --- @racket[print-graph]} @item{@cppdef{MZCONFIG_PRINT_STRUCT} --- @racket[print-struct]} @@ -53,6 +60,8 @@ through the following indices: @item{@cppdef{MZCONFIG_CASE_SENS} --- @racket[read-case-sensitive]} @item{@cppdef{MZCONFIG_SQUARE_BRACKETS_ARE_PARENS} --- @racket[read-square-brackets-as-parens]} @item{@cppdef{MZCONFIG_CURLY_BRACES_ARE_PARENS} --- @racket[read-curly-braces-as-parens]} +@item{@cppdef{MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED} --- @racket[read-square-brackets-with-tag]} +@item{@cppdef{MZCONFIG_CURLY_BRACES_ARE_TAGGED} --- @racket[read-curly-braces-with-tag]} @item{@cppdef{MZCONFIG_ERROR_PRINT_WIDTH} --- @racket[error-print-width]} diff --git a/pkgs/racket-doc/scribblings/inside/utils.rkt b/pkgs/racket-doc/scribblings/inside/utils.rkt index 47f9341272..50e99dfbe4 100644 --- a/pkgs/racket-doc/scribblings/inside/utils.rkt +++ b/pkgs/racket-doc/scribblings/inside/utils.rkt @@ -12,6 +12,7 @@ function subfunction FormatD tech-place + reference-doc raco-doc (except-out (all-from-out scribble/manual) var) (for-label (all-from-out scheme/base))) @@ -157,8 +158,11 @@ (define mzc (exec "raco ctool")) +(define reference-doc '(lib "scribblings/reference/reference.scrbl")) +(define raco-doc '(lib "scribblings/raco/raco.scrbl")) + (define (refsecref s) - (secref #:doc '(lib "scribblings/reference/reference.scrbl") s)) + (secref #:doc reference-doc s)) (define Racket (other-manual '(lib "scribblings/reference/reference.scrbl"))) diff --git a/pkgs/racket-doc/scribblings/more/more.scrbl b/pkgs/racket-doc/scribblings/more/more.scrbl index 0266f46a55..35d1bfc7bc 100644 --- a/pkgs/racket-doc/scribblings/more/more.scrbl +++ b/pkgs/racket-doc/scribblings/more/more.scrbl @@ -747,7 +747,7 @@ import a library of control operators: Specifically, we need @racket[prompt] and @racket[abort] from @racketmodname[racket/control]. We use @racket[prompt] to mark the place where a servlet is started, so that we can abort a computation -to that point. Change @racket[handle] by wrapping an @racket[prompt] +to that point. Change @racket[handle] by wrapping a @racket[prompt] around the call to @racket[dispatch]: @racketblock[ diff --git a/pkgs/racket-doc/scribblings/raco/exe.scrbl b/pkgs/racket-doc/scribblings/raco/exe.scrbl index 3e957c98b4..2a276cd540 100644 --- a/pkgs/racket-doc/scribblings/raco/exe.scrbl +++ b/pkgs/racket-doc/scribblings/raco/exe.scrbl @@ -49,7 +49,10 @@ created executable. Such modules can be explicitly included using the @racket[define-runtime-path] to embed references to the run-time files in the executable; the files are then copied and packaged together with the executable when creating a distribution (as described in -@secref["exe-dist"]). +@secref["exe-dist"]). Finally, a submodule is included if its +enclosing module is included and the submodule contains a +sub-submodule named @racketidfont{declare-preserve-for-embedding} +(where the implementation of the sub-submodule is ignored). Modules that are implemented directly by extensions---i.e., extensions that are automatically loaded from @racket[(build-path "compiled" @@ -172,6 +175,9 @@ The @exec{raco exe} command accepts the following command-line flags: ] +@history[#:changed "6.3.0.11" @elem{Added support for + @racketidfont{declare-preserve-for-embedding}.}] + @; ---------------------------------------------------------------------- @include-section["exe-api.scrbl"] diff --git a/pkgs/racket-doc/scribblings/raco/setup.scrbl b/pkgs/racket-doc/scribblings/raco/setup.scrbl index 7a4340a9b0..b351eeb35a 100644 --- a/pkgs/racket-doc/scribblings/raco/setup.scrbl +++ b/pkgs/racket-doc/scribblings/raco/setup.scrbl @@ -452,9 +452,13 @@ Optional @filepath{info.rkt} fields trigger additional actions by ] The @racket[_category] list specifies how to show the document in - the root table of contents. The list must start with a symbol, - usually one of the following categories, which are ordered as - below in the root documentation page: + the root table of contents. The list must start with a category, + which determines where the manual appears in the root + documentation page. A category is either a string or a symbol. If + it is a string, then the string is the category label on the root + page. If it is a symbol, then a default category label is + used. The available symbols and the order of categories on the + root documentation page is as below: @itemize[ @@ -483,6 +487,8 @@ Optional @filepath{info.rkt} fields trigger additional actions by @item{@racket['interop] : Documentation for interoperability tools and libraries.} + @item{All string categories as ordered by @racket[string<=?].} + @item{@racket['library] : Documentation for libraries; this category is the default and used for unrecognized category symbols.} diff --git a/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl b/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl index 5de07392c4..c3a69d40f3 100644 --- a/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl +++ b/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl @@ -274,12 +274,17 @@ binding, constructor, etc.} The @racket[lang-info] value specifies an optional module path that provides information about the module's implementation language. - The @racket[internal-module-context] value describes the lexical - context of the body of the module. This value is used by - @racket[module->namespace]. A @racket[#f] value means that the - context is unavailable or empty. A @racket[#t] value means that the - context is computed by re-importing all required modules. A - syntax-object value embeds an arbitrary lexical context. + The @racket[internal-context] value describes the lexical context of + the body of the module. This value is used by + @racket[module->namespace]. A @racket[#f] value means that the + context is unavailable or empty. A @racket[#t] value means that the + context is computed by re-importing all required modules. A + syntax-object value embeds lexical information; the syntax object + should contain a vector of two elements, where the first element of + the vector is a syntax object for the module's body, which includes + the outside-edge and inside-edge scopes, and the second element of + the vector is a syntax object that has just the module's inside-edge + scope. The @racket[binding-names] value provides additional information to @racket[module->namespace] to correlate symbol names for variables diff --git a/pkgs/racket-doc/scribblings/reference/async-channels.scrbl b/pkgs/racket-doc/scribblings/reference/async-channels.scrbl index 9da432a95e..9c4d6bcc85 100644 --- a/pkgs/racket-doc/scribblings/reference/async-channels.scrbl +++ b/pkgs/racket-doc/scribblings/reference/async-channels.scrbl @@ -70,27 +70,27 @@ synchronization} when @racket[(async-channel-put ach v)] would return a value (i.e., when the channel holds fewer values already than its limit); @resultItself{asychronous channel-put event}.} -@defexamples[#:eval (async-eval) -(define (server input-channel output-channel) - (thread (lambda () - (define (get) - (async-channel-get input-channel)) - (define (put x) - (async-channel-put output-channel x)) - (define (do-large-computation) - (sqrt 9)) - (let loop ([data (get)]) - (case data - [(quit) (void)] - [(add) (begin - (put (+ 1 (get))) - (loop (get)))] - [(long) (begin - (put (do-large-computation)) - (loop (get)))]))))) - -(define to-server (make-async-channel)) -(define from-server (make-async-channel)) +@examples[#:eval (async-eval) #:once +(eval:no-prompt + (define (server input-channel output-channel) + (thread (lambda () + (define (get) + (async-channel-get input-channel)) + (define (put x) + (async-channel-put output-channel x)) + (define (do-large-computation) + (sqrt 9)) + (let loop ([data (get)]) + (case data + [(quit) (void)] + [(add) (begin + (put (+ 1 (get))) + (loop (get)))] + [(long) (begin + (put (do-large-computation)) + (loop (get)))]))))) + (define to-server (make-async-channel)) + (define from-server (make-async-channel))) (server to-server from-server) diff --git a/pkgs/racket-doc/scribblings/reference/block.scrbl b/pkgs/racket-doc/scribblings/reference/block.scrbl index 61a3aad2ad..2d757c3c92 100644 --- a/pkgs/racket-doc/scribblings/reference/block.scrbl +++ b/pkgs/racket-doc/scribblings/reference/block.scrbl @@ -1,5 +1,5 @@ #lang scribble/doc -@(require "mz.rkt" scribble/eval (for-label racket/block)) +@(require "mz.rkt" (for-label racket/block)) @(define ev (make-base-eval)) @(ev '(require racket/block)) diff --git a/pkgs/racket-doc/scribblings/reference/bytes.scrbl b/pkgs/racket-doc/scribblings/reference/bytes.scrbl index 4b2f62222f..97de7fdd4b 100644 --- a/pkgs/racket-doc/scribblings/reference/bytes.scrbl +++ b/pkgs/racket-doc/scribblings/reference/bytes.scrbl @@ -643,7 +643,7 @@ normally identified by @racket[""]). See also @section{Additional Byte String Functions} @note-lib[racket/bytes] @(define string-eval (make-base-eval)) -@(interaction-eval #:eval string-eval (require racket/bytes racket/list)) +@@examples[#:hidden #:eval string-eval (require racket/bytes racket/list)] @defproc[(bytes-append* [str bytes?] ... [strs (listof bytes?)]) bytes?]{ @; Note: this is exactly the same description as the one for append* diff --git a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl index 747835735c..432ecf9e4c 100644 --- a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -191,18 +191,31 @@ required keyword arguments of @racket[wrapper-proc] must be a subset of the required keywords of @racket[proc]. For applications without keywords, the result of @racket[wrapper-proc] -must be either the same number of values as supplied to it or one more -than the number of supplied values, where an extra result is supplied -before the others. The additional result, if any, must be a procedure +must be at least the same number of values as supplied to it. +Additional results can be supplied---before the values that correspond +to the supplied values---in the following pattern: + +@itemlist[ + + @item{An optional procedure, @racket[_result-wrapper-proc], which + will be applied to the results of @racket[proc]; followed by} + + @item{any number of repetitions of @racket['mark _key _val] (i.e., + three values), where the call @racket[_proc] is wrapped to + install a @tech{continuation mark} @racket[_key] and @racket[_val].} + +] + +If @racket[_result-wrapper-proc] is produced, it must be a procedure that accepts as many results as produced by @racket[proc]; it must -return the same number of results. If @racket[wrapper-proc] returns -the same number of values as it is given (i.e., it does not return a -procedure to impersonator @racket[proc]'s result), then @racket[proc] is -called in @tech{tail position} with respect to the call to the impersonator. +return the same number of results. If @racket[_result-wrapper-proc] is +not supplied, then @racket[proc] is called in @tech{tail position} +with respect to the call to the impersonator. For applications that include keyword arguments, @racket[wrapper-proc] -must return an additional value before any other values but after the -result-impersonating procedure (if any). The additional value must be a +must return an additional value before any other values but after +@racket[_result-wrapper-proc] and @racket['mark _key _val] +sequences (if any). The additional value must be a list of replacements for the keyword arguments that were supplied to the impersonator (i.e., not counting optional arguments that were not supplied). The arguments must be ordered according to the sorted @@ -229,7 +242,51 @@ for @racket[(car prop-val)] in the call's continuation---then the value is also installed as an immediate value for @racket[(car prop-val)] as a mark during the call to @racket[wrapper-proc] (which allows tail-calls of impersonators with respect to wrapping impersonators to be detected within -@racket[wrapper-proc]).} +@racket[wrapper-proc]). + +@history[#:changed "6.3.0.5" @elem{Added support for @racket['mark + _key _val] results from + @racket[wrapper-proc].}] + + @examples[ + + (define (add15 x) (+ x 15)) + (define add15+print + (impersonate-procedure add15 + (λ (x) + (printf "called with ~s\n" x) + (values (λ (res) + (printf "returned ~s\n" res) + res) + x)))) + (add15 27) + (add15+print 27) + + (define-values (imp-prop:p1 imp-prop:p1? imp-prop:p1-get) + (make-impersonator-property 'imp-prop:p1)) + (define-values (imp-prop:p2 imp-prop:p2? imp-prop:p2-get) + (make-impersonator-property 'imp-prop:p2)) + + (define add15.2 (impersonate-procedure add15 #f imp-prop:p1 11)) + (add15.2 2) + (imp-prop:p1? add15.2) + (imp-prop:p1-get add15.2) + (imp-prop:p2? add15.2) + + (define add15.3 (impersonate-procedure add15.2 #f imp-prop:p2 13)) + (add15.3 3) + (imp-prop:p1? add15.3) + (imp-prop:p1-get add15.3) + (imp-prop:p2? add15.3) + (imp-prop:p2-get add15.3) + + (define add15.4 (impersonate-procedure add15.3 #f imp-prop:p1 101)) + (add15.4 4) + (imp-prop:p1? add15.4) + (imp-prop:p1-get add15.4) + (imp-prop:p2? add15.4) + (imp-prop:p2-get add15.4)] +} @defproc[(impersonate-procedure* [proc procedure?] [wrapper-proc (or/c procedure? #f)] @@ -389,6 +446,7 @@ or override impersonator-property values of @racket[box].} [remove-proc (hash? any/c . -> . any/c)] [key-proc (hash? any/c . -> . any/c)] [clear-proc (or/c #f (hash? . -> . any)) #f] + [equal-key-proc (or/c #f (hash? any/c . -> . any/c)) #f] [prop impersonator-property?] [prop-val any] ... ...) (and/c hash? impersonator?)]{ @@ -404,7 +462,7 @@ In addition, operations like @racket[hash-iterate-key] or @racket[hash-map], which extract keys from the table, use @racket[key-proc] to filter keys extracted from the table. Operations like @racket[hash-iterate-value] or -@racket[hash-iterate-map] implicitly use @racket[hash-ref] and +@racket[hash-values] implicitly use @racket[hash-ref] and therefore redirect through @racket[ref-proc]. The @racket[ref-proc] must accept @racket[hash] and a key passed @@ -442,6 +500,19 @@ If @racket[clear-proc] is @racket[#f], then @racket[hash-clear] or @racket[hash-clear!] on the impersonator is implemented using @racket[hash-iterate-key] and @racket[hash-remove] or @racket[hash-remove!]. +If @racket[equal-key-proc] is not @racket[#f], it effectively +interposes on calls to @racket[equal?], @racket[equal-hash-code], and +@racket[equal-secondary-hash-code] for the keys of @racket[hash]. The +@racket[equal-key-proc] must accept as its arguments @racket[hash] and +a key that is either mapped by @racket[hash] or passed to +@racket[hash-ref], etc., where the latter has potentially been +adjusted by the corresponding @racket[ref-proc], etc@|.__| The result +is a value that is passed to @racket[equal?], +@racket[equal-hash-code], and @racket[equal-secondary-hash-code] as +needed to hash and compare keys. In the case of @racket[hash-set!] or +@racket[hash-set], the key that is passed to @racket[equal-key-proc] +is the one stored in the hash table for future lookup. + The @racket[hash-iterate-value], @racket[hash-map], or @racket[hash-for-each] functions use a combination of @racket[hash-iterate-key] and @racket[hash-ref]. If a key @@ -450,7 +521,10 @@ produced by @racket[key-proc] does not yield a value through Pairs of @racket[prop] and @racket[prop-val] (the number of arguments to @racket[impersonate-hash] must be odd) add impersonator properties -or override impersonator-property values of @racket[hash].} +or override impersonator-property values of @racket[hash]. + +@history[#:changed "6.3.0.11" @elem{Added the @racket[equal-key-proc] + argument.}]} @defproc[(impersonate-channel [channel channel?] @@ -745,6 +819,7 @@ the same value or a chaperone of the value that it is given. The [remove-proc (hash? any/c . -> . any/c)] [key-proc (hash? any/c . -> . any/c)] [clear-proc (or/c #f (hash? . -> . any)) #f] + [equal-key-proc (or/c #f (hash? any/c . -> . any/c)) #f] [prop impersonator-property?] [prop-val any] ... ...) (and/c hash? chaperone?)]{ @@ -754,8 +829,12 @@ and support for immutable hashes. The @racket[ref-proc] procedure must return a found value or a chaperone of the value. The @racket[set-proc] procedure must produce two values: the key that it is given or a chaperone of the key and the value that it is given or a -chaperone of the value. The @racket[remove-proc] and @racket[key-proc] -procedures must produce the given key or a chaperone of the key.} +chaperone of the value. The @racket[remove-proc], @racket[key-proc], +and @racket[equal-key-proc] +procedures must produce the given key or a chaperone of the key. + +@history[#:changed "6.3.0.11" @elem{Added the @racket[equal-key-proc] + argument.}]} @defproc[(chaperone-struct-type [struct-type struct-type?] [struct-info-proc procedure?] @@ -867,11 +946,12 @@ procedure. (lambda (n) (* n 2)) (lambda (n) (+ n 1)))) - (call-with-continuation-prompt - (lambda () - (abort-current-continuation bad-chaperone 5)) - bad-chaperone - (lambda (n) n)) + (eval:error + (call-with-continuation-prompt + (lambda () + (abort-current-continuation bad-chaperone 5)) + bad-chaperone + (lambda (n) n))) (define good-chaperone (chaperone-prompt-tag @@ -909,10 +989,11 @@ given. (lambda (l) (map char-upcase l)) string->list)) - (with-continuation-mark bad-chaperone "timballo" - (continuation-mark-set-first - (current-continuation-marks) - bad-chaperone)) + (eval:error + (with-continuation-mark bad-chaperone "timballo" + (continuation-mark-set-first + (current-continuation-marks) + bad-chaperone))) (define (checker s) (if (> (string-length s) 5) diff --git a/pkgs/racket-doc/scribblings/reference/class.scrbl b/pkgs/racket-doc/scribblings/reference/class.scrbl index 9eb15c1fb7..e95455db04 100644 --- a/pkgs/racket-doc/scribblings/reference/class.scrbl +++ b/pkgs/racket-doc/scribblings/reference/class.scrbl @@ -71,11 +71,10 @@ ) -@(interaction-eval #:eval class-eval (require racket/class racket/contract)) -@(interaction-eval - #:eval class-ctc-eval - (require racket/class racket/contract)) - +@examples[#:hidden #:eval class-eval + (require racket/class racket/contract)] +@examples[#:hidden #:eval class-ctc-eval + (require racket/class racket/contract)] @title[#:tag "mzlib:class" #:style 'toc]{Classes and Objects} @@ -196,8 +195,9 @@ is the most specific requirement from its superinterfaces. If the superinterfaces specify inconsistent derivation requirements, the @exnraise[exn:fail:object]. -@defexamples[ +@examples[ #:eval class-ctc-eval +#:no-prompt (define file-interface<%> (interface () open close read-byte write-byte)) (define directory-interface<%> @@ -226,8 +226,9 @@ extended to produce the internal structure type for instances of the class (so that no information about fields is accessible to the structure type property's guard, if any). -@defexamples[ +@examples[ #:eval class-eval +#:no-prompt (define i<%> (interface* () ([prop:custom-write (lambda (obj port mode) (void))]) method1 method2 method3)) @@ -387,8 +388,9 @@ calling subclass augmentations of methods (see Like @racket[class*], but omits the @racket[_interface-expr]s, for the case that none are needed. -@defexamples[ +@examples[ #:eval class-eval +#:no-prompt (define book-class% (class object% (field (pages 5)) @@ -404,15 +406,16 @@ to the current object (i.e., the object being initialized or whose method was called). Use outside the body of a @racket[class*] form is a syntax error. -@defexamples[ +@examples[ #:eval class-eval -(define (describe obj) - (printf "Hello ~a\n" obj)) -(define table% - (class object% - (define/public (describe-self) - (describe this)) - (super-new))) +(eval:no-prompt + (define (describe obj) + (printf "Hello ~a\n" obj)) + (define table% + (class object% + (define/public (describe-self) + (describe this)) + (super-new)))) (send (new table%) describe-self) ]} @@ -423,21 +426,22 @@ of the current object (i.e., the object being initialized or whose method was called). Use outside the body of a @racket[class*] form is a syntax error. -@defexamples[ +@examples[ #:eval class-eval -(define account% - (class object% - (super-new) - (init-field balance) - (define/public (add n) - (new this% [balance (+ n balance)])))) -(define savings% - (class account% - (super-new) - (inherit-field balance) - (define interest 0.04) - (define/public (add-interest) - (send this add (* interest balance))))) +(eval:no-prompt + (define account% + (class object% + (super-new) + (init-field balance) + (define/public (add n) + (new this% [balance (+ n balance)])))) + (define savings% + (class account% + (super-new) + (inherit-field balance) + (define interest 0.04) + (define/public (add-interest) + (send this add (* interest balance)))))) (let* ([acct (new savings% [balance 500])] [acct (send acct add 500)] [acct (send acct add-interest)]) @@ -447,7 +451,7 @@ a syntax error. @defclassforms[ [(inspect inspector-expr) ()] [(init init-decl ...) ("clinitvars") - @defexamples[#:eval class-eval + @examples[#:eval class-eval (class object% (super-new) (init turnip @@ -455,7 +459,7 @@ a syntax error. [carrot 'good] [(internal-rutabaga rutabaga) 'okay]))]] [(init-field init-decl ...) ("clinitvars" "clfields") - @defexamples[#:eval class-eval + @examples[#:eval class-eval (class object% (super-new) (init-field turkey @@ -463,181 +467,202 @@ a syntax error. [chicken 7] [(internal-emu emu) 13]))]] [(field field-decl ...) ("clfields") - @defexamples[#:eval class-eval + @examples[#:eval class-eval (class object% (super-new) (field [minestrone 'ready] [(internal-coq-au-vin coq-au-vin) 'stewing]))]] [(inherit-field maybe-renamed ...) ("clfields") - @defexamples[#:eval class-eval - (define cookbook% - (class object% - (super-new) - (field [recipes '(caldo-verde oyakodon eggs-benedict)] - [pages 389]))) + @examples[#:eval class-eval + (eval:no-prompt + (define cookbook% + (class object% + (super-new) + (field [recipes '(caldo-verde oyakodon eggs-benedict)] + [pages 389])))) (class cookbook% (super-new) (inherit-field recipes [internal-pages pages]))]] [* ((init-rest id) (init-rest)) ("clinitvars") - @defexamples[#:eval class-eval - (define fruit-basket% - (class object% - (super-new) - (init-rest fruits) - (displayln fruits))) - (make-object fruit-basket% 'kiwi 'lychee 'melon)]] - [(public maybe-renamed ...) ("clmethoddefs") - @defexamples[#:eval class-eval - (define jumper% + @examples[#:eval class-eval + (eval:no-prompt + (define fruit-basket% (class object% (super-new) - (define (skip) 'skip) - (define (hop) 'hop) - (public skip [hop jump]))) + (init-rest fruits) + (displayln fruits)))) + (make-object fruit-basket% 'kiwi 'lychee 'melon)]] + [(public maybe-renamed ...) ("clmethoddefs") + @examples[#:eval class-eval + (eval:no-prompt + (define jumper% + (class object% + (super-new) + (define (skip) 'skip) + (define (hop) 'hop) + (public skip [hop jump])))) (send (new jumper%) skip) (send (new jumper%) jump)]] [(pubment maybe-renamed ...) ("clmethoddefs") - @defexamples[#:eval class-eval - (define runner% - (class object% - (super-new) - (define (run) 'run) - (define (trot) 'trot) - (pubment run [trot jog]))) + @examples[#:eval class-eval + (eval:no-prompt + (define runner% + (class object% + (super-new) + (define (run) 'run) + (define (trot) 'trot) + (pubment run [trot jog])))) (send (new runner%) run) (send (new runner%) jog)]] [(public-final maybe-renamed ...) ("clmethoddefs") - @defexamples[#:eval class-eval - (define point% - (class object% - (super-new) - (init-field [x 0] [y 0]) - (define (get-x) x) - (define (do-get-y) y) - (public-final get-x [do-get-y get-y]))) + @examples[#:eval class-eval + (eval:no-prompt + (define point% + (class object% + (super-new) + (init-field [x 0] [y 0]) + (define (get-x) x) + (define (do-get-y) y) + (public-final get-x [do-get-y get-y])))) (send (new point% [x 1] [y 3]) get-y) - (class point% - (super-new) - (define (get-x) 3.14) - (override get-x))]] + (eval:error + (class point% + (super-new) + (define (get-x) 3.14) + (override get-x)))]] [(override maybe-renamed ...) ("clmethoddefs") - @defexamples[#:eval class-eval - (define sheep% - (class object% - (super-new) - (define/public (bleat) - (displayln "baaaaaaaaah")))) - (define confused-sheep% - (class sheep% - (super-new) - (define (bleat) - (super bleat) - (displayln "???")) - (override bleat))) + @examples[#:eval class-eval + (eval:no-prompt + (define sheep% + (class object% + (super-new) + (define/public (bleat) + (displayln "baaaaaaaaah"))))) + (eval:no-prompt + (define confused-sheep% + (class sheep% + (super-new) + (define (bleat) + (super bleat) + (displayln "???")) + (override bleat)))) (send (new sheep%) bleat) (send (new confused-sheep%) bleat)]] [(overment maybe-renamed ...) ("clmethoddefs") - @defexamples[#:eval class-eval - (define turkey% - (class object% - (super-new) - (define/public (gobble) - (displayln "gobble gobble")))) - (define extra-turkey% - (class turkey% - (super-new) - (define (gobble) - (super gobble) - (displayln "gobble gobble gobble") - (inner (void) gobble)) - (overment gobble))) - (define cyborg-turkey% - (class extra-turkey% - (super-new) - (define/augment (gobble) - (displayln "110011111011111100010110001011011001100101")))) + @examples[#:eval class-eval + (eval:no-prompt + (define turkey% + (class object% + (super-new) + (define/public (gobble) + (displayln "gobble gobble"))))) + (eval:no-prompt + (define extra-turkey% + (class turkey% + (super-new) + (define (gobble) + (super gobble) + (displayln "gobble gobble gobble") + (inner (void) gobble)) + (overment gobble)))) + (eval:no-prompt + (define cyborg-turkey% + (class extra-turkey% + (super-new) + (define/augment (gobble) + (displayln "110011111011111100010110001011011001100101"))))) (send (new extra-turkey%) gobble) (send (new cyborg-turkey%) gobble)]] [(override-final maybe-renamed ...) ("clmethoddefs") - @defexamples[#:eval class-eval - (define meeper% - (class object% - (super-new) - (define/public (meep) - (displayln "meep")))) - (define final-meeper% - (class meeper% - (super-new) - (define (meep) - (super meep) - (displayln "This meeping ends with me")) - (override-final meep))) + @examples[#:eval class-eval + (eval:no-prompt + (define meeper% + (class object% + (super-new) + (define/public (meep) + (displayln "meep"))))) + (eval:no-prompt + (define final-meeper% + (class meeper% + (super-new) + (define (meep) + (super meep) + (displayln "This meeping ends with me")) + (override-final meep)))) (send (new meeper%) meep) (send (new final-meeper%) meep)]] [(augment maybe-renamed ...) ("clmethoddefs") - @defexamples[#:eval class-eval - (define buzzer% - (class object% - (super-new) - (define/pubment (buzz) - (displayln "bzzzt") - (inner (void) buzz)))) - (define loud-buzzer% - (class buzzer% - (super-new) - (define (buzz) - (displayln "BZZZZZZZZZT")) - (augment buzz))) + @examples[#:eval class-eval + (eval:no-prompt + (define buzzer% + (class object% + (super-new) + (define/pubment (buzz) + (displayln "bzzzt") + (inner (void) buzz))))) + (eval:no-prompt + (define loud-buzzer% + (class buzzer% + (super-new) + (define (buzz) + (displayln "BZZZZZZZZZT")) + (augment buzz)))) (send (new buzzer%) buzz) (send (new loud-buzzer%) buzz)]] [(augride maybe-renamed ...) ("clmethoddefs")] [(augment-final maybe-renamed ...) ("clmethoddefs")] [(private id ...) ("clmethoddefs") - @defexamples[#:eval class-eval - (define light% - (class object% - (super-new) - (define on? #t) - (define (toggle) (set! on? (not on?))) - (private toggle) - (define (flick) (toggle)) - (public flick))) - (send (new light%) toggle) + @examples[#:eval class-eval + (eval:no-prompt + (define light% + (class object% + (super-new) + (define on? #t) + (define (toggle) (set! on? (not on?))) + (private toggle) + (define (flick) (toggle)) + (public flick)))) + (eval:error (send (new light%) toggle)) (send (new light%) flick)]] [(abstract id ...) ("clmethoddefs") - @defexamples[#:eval class-eval - (define train% - (class object% - (super-new) - (abstract get-speed) - (init-field [position 0]) - (define/public (move) - (new this% [position (+ position (get-speed))])))) - (define acela% - (class train% - (super-new) - (define/override (get-speed) 241))) - (define talgo-350% - (class train% - (super-new) - (define/override (get-speed) 330))) - (new train%) + @examples[#:eval class-eval + (eval:no-prompt + (define train% + (class object% + (super-new) + (abstract get-speed) + (init-field [position 0]) + (define/public (move) + (new this% [position (+ position (get-speed))]))))) + (eval:no-prompt + (define acela% + (class train% + (super-new) + (define/override (get-speed) 241)))) + (eval:no-prompt + (define talgo-350% + (class train% + (super-new) + (define/override (get-speed) 330)))) + (eval:error (new train%)) (send (new acela%) move)]] [(inherit maybe-renamed ...) ("classinherit") - @defexamples[#:eval class-eval - (define alarm% - (class object% - (super-new) - (define/public (alarm) - (displayln "beeeeeeeep")))) - (define car-alarm% - (class alarm% - (super-new) - (init-field proximity) - (inherit alarm) - (when (< proximity 10) - (alarm)))) + @examples[#:eval class-eval + (eval:no-prompt + (define alarm% + (class object% + (super-new) + (define/public (alarm) + (displayln "beeeeeeeep"))))) + (eval:no-prompt + (define car-alarm% + (class alarm% + (super-new) + (init-field proximity) + (inherit alarm) + (when (< proximity 10) + (alarm))))) (new car-alarm% [proximity 5])]] [(inherit/super maybe-renamed ...) ("classinherit")] [(inherit/inner maybe-renamed ...) ("classinherit")] @@ -1067,21 +1092,22 @@ hidden name (except as a top-level definition). The @racket[interface->method-names] procedure does not expose hidden names. -@defexamples[ +@examples[ #:eval class-eval -(define-values (r o) - (let () - (define-local-member-name m) - (define c% (class object% - (define/public (m) 10) - (super-new))) - (define o (new c%)) +(eval:no-prompt + (define-values (r o) + (let () + (define-local-member-name m) + (define c% (class object% + (define/public (m) 10) + (super-new))) + (define o (new c%)) - (values (send o m) - o))) + (values (send o m) + o)))) r -(send o m) +(eval:error (send o m)) ]} @@ -1121,28 +1147,27 @@ Produces an integer hash code consistent with @racket[member-name-key=?] comparisons, analogous to @racket[equal-hash-code].} -@defexamples[ +@examples[ #:eval class-eval -(define (make-c% key) - (define-member-name m key) - (class object% - (define/public (m) 10) - (super-new))) +(eval:no-prompt + (define (make-c% key) + (define-member-name m key) + (class object% + (define/public (m) 10) + (super-new)))) (send (new (make-c% (member-name-key m))) m) -(send (new (make-c% (member-name-key p))) m) +(eval:error (send (new (make-c% (member-name-key p))) m)) (send (new (make-c% (member-name-key p))) p) -] -@defs+int[ -#:eval class-eval -[(define (fresh-c%) +(eval:no-prompt + (define (fresh-c%) (let ([key (generate-member-key)]) (values (make-c% key) key))) - (define-values (fc% key) (fresh-c%))] + (define-values (fc% key) (fresh-c%))) -(send (new fc%) m) +(eval:error (send (new fc%) m)) (let () (define-member-name p key) (send (new fc%) p)) @@ -1352,15 +1377,16 @@ the last method call, which is expected to be an object. Each This is the functional analogue of @racket[send*]. -@defexamples[#:eval class-eval -(define point% - (class object% - (super-new) - (init-field [x 0] [y 0]) - (define/public (move-x dx) - (new this% [x (+ x dx)])) - (define/public (move-y dy) - (new this% [y (+ y dy)])))) +@examples[#:eval class-eval +(eval:no-prompt + (define point% + (class object% + (super-new) + (init-field [x 0] [y 0]) + (define/public (move-x dx) + (new this% [x (+ x dx)])) + (define/public (move-y dy) + (new this% [y (+ y dy)]))))) (send+ (new point%) (move-x 5) @@ -1802,21 +1828,21 @@ The external contracts are as follows: If only the field name is present, this is equivalent to insisting only that the method is present in the class. - @defexamples[#:eval - class-eval - (define woody% - (class object% - (define/public (draw who) - (format "reach for the sky, ~a" who)) - (super-new))) + @examples[#:eval class-eval + (eval:no-prompt + (define woody% + (class object% + (define/public (draw who) + (format "reach for the sky, ~a" who)) + (super-new))) - (define/contract woody+c% - (class/c [draw (->m symbol? string?)]) - woody%) + (define/contract woody+c% + (class/c [draw (->m symbol? string?)]) + woody%)) (send (new woody%) draw #f) (send (new woody+c%) draw 'zurg) - (send (new woody+c%) draw #f)] + (eval:error (send (new woody+c%) draw #f))] } @item{An external field contract, tagged with @racket[field], describes the behavior of the value contained in that field when accessed from outside @@ -1827,28 +1853,29 @@ The external contracts are as follows: If only the field name is present, this is equivalent to using the contract @racket[any/c] (but it is checked more efficiently). - @defexamples[#:eval - class-eval - (define woody/hat% - (class woody% - (field [hat-location 'uninitialized]) - (define/public (lose-hat) (set! hat-location 'lost)) - (define/public (find-hat) (set! hat-location 'on-head)) - (super-new))) - (define/contract woody/hat+c% - (class/c [draw (->m symbol? string?)] - [lose-hat (->m void?)] - [find-hat (->m void?)] - (field [hat-location (or/c 'on-head 'lost)])) - woody/hat%) + @examples[#:eval class-eval + (eval:no-prompt + (define woody/hat% + (class woody% + (field [hat-location 'uninitialized]) + (define/public (lose-hat) (set! hat-location 'lost)) + (define/public (find-hat) (set! hat-location 'on-head)) + (super-new))) + (define/contract woody/hat+c% + (class/c [draw (->m symbol? string?)] + [lose-hat (->m void?)] + [find-hat (->m void?)] + (field [hat-location (or/c 'on-head 'lost)])) + woody/hat%)) (get-field hat-location (new woody/hat%)) (let ([woody (new woody/hat+c%)]) (send woody lose-hat) (get-field hat-location woody)) - (get-field hat-location (new woody/hat+c%)) - (let ([woody (new woody/hat+c%)]) - (set-field! hat-location woody 'under-the-dresser))] + (eval:error (get-field hat-location (new woody/hat+c%))) + (eval:error + (let ([woody (new woody/hat+c%)]) + (set-field! hat-location woody 'under-the-dresser)))] } @item{An initialization argument contract, tagged with @racket[init], @@ -1861,28 +1888,29 @@ The external contracts are as follows: If only the initialization argument name is present, this is equivalent to using the contract @racket[any/c] (but it is checked more efficiently). - @defexamples[#:eval - class-eval - (define woody/init-hat% - (class woody% - (init init-hat-location) - (field [hat-location init-hat-location]) - (define/public (lose-hat) (set! hat-location 'lost)) - (define/public (find-hat) (set! hat-location 'on-head)) - (super-new))) - (define/contract woody/init-hat+c% - (class/c [draw (->m symbol? string?)] - [lose-hat (->m void?)] - [find-hat (->m void?)] - (init [init-hat-location (or/c 'on-head 'lost)]) - (field [hat-location (or/c 'on-head 'lost)])) - woody/init-hat%) + @examples[#:eval class-eval + (eval:no-prompt + (define woody/init-hat% + (class woody% + (init init-hat-location) + (field [hat-location init-hat-location]) + (define/public (lose-hat) (set! hat-location 'lost)) + (define/public (find-hat) (set! hat-location 'on-head)) + (super-new))) + (define/contract woody/init-hat+c% + (class/c [draw (->m symbol? string?)] + [lose-hat (->m void?)] + [find-hat (->m void?)] + (init [init-hat-location (or/c 'on-head 'lost)]) + (field [hat-location (or/c 'on-head 'lost)])) + woody/init-hat%)) (get-field hat-location (new woody/init-hat+c% [init-hat-location 'lost])) - (get-field hat-location - (new woody/init-hat+c% - [init-hat-location 'slinkys-mouth]))] + (eval:error + (get-field hat-location + (new woody/init-hat+c% + [init-hat-location 'slinkys-mouth])))] } @item{The contracts listed in an @racket[init-field] section are @@ -1906,18 +1934,19 @@ As with the external contracts, when a method or field name is specified contracted class's method implementation is no longer the entry point for dynamic dispatch. - @defexamples[#:eval - class-eval + @examples[#:eval class-eval (new (class woody+c% (inherit draw) (super-new) (printf "woody sez: “~a”\n" (draw "evil dr porkchop")))) - (define/contract woody+c-inherit% - (class/c (inherit [draw (->m symbol? string?)])) - woody+c%) - (new (class woody+c-inherit% - (inherit draw) - (printf "woody sez: ~a\n" (draw "evil dr porkchop"))))] + (eval:no-prompt + (define/contract woody+c-inherit% + (class/c (inherit [draw (->m symbol? string?)])) + woody+c%)) + (eval:error + (new (class woody+c-inherit% + (inherit draw) + (printf "woody sez: ~a\n" (draw "evil dr porkchop")))))] } @item{A method contract tagged with @racket[super] describes the behavior of @@ -1932,18 +1961,18 @@ As with the external contracts, when a method or field name is specified contract the controls how the @racket[super] methods must be invoked. - @defexamples[#:eval - class-eval - (define/contract woody2+c% - (class/c (super [draw (->m symbol? string?)])) - (class woody% - (define/override draw - (case-lambda - [(a) (super draw a)] - [(a b) (string-append (super draw a) - " and " - (super draw b))])) - (super-new))) + @examples[#:eval class-eval + (eval:no-prompt + (define/contract woody2+c% + (class/c (super [draw (->m symbol? string?)])) + (class woody% + (define/override draw + (case-lambda + [(a) (super draw a)] + [(a b) (string-append (super draw a) + " and " + (super draw b))])) + (super-new)))) (send (new woody2+c%) draw 'evil-dr-porkchop 'zurg) (send (new woody2+c%) draw "evil dr porkchop" "zurg")] @@ -1971,27 +2000,28 @@ As with the external contracts, when a method or field name is specified add a contract to make sure that overriding @racket[draw] doesn't break @racket[draw2]. - @defexamples[#:eval - class-eval - (define/contract woody2+override/c% - (class/c (override [draw (->m symbol? string?)])) - (class woody+c% - (inherit draw) - (define/public (draw2 a b) - (string-append (draw a) - " and " - (draw b))) - (super-new))) + @examples[#:eval class-eval + (eval:no-prompt + (define/contract woody2+override/c% + (class/c (override [draw (->m symbol? string?)])) + (class woody+c% + (inherit draw) + (define/public (draw2 a b) + (string-append (draw a) + " and " + (draw b))) + (super-new))) - (define woody2+broken-draw - (class woody2+override/c% - (define/override (draw x) - 'not-a-string) - (super-new))) - - (send (new woody2+broken-draw) draw2 - 'evil-dr-porkchop - 'zurg)] + (define woody2+broken-draw + (class woody2+override/c% + (define/override (draw x) + 'not-a-string) + (super-new)))) + + (eval:error + (send (new woody2+broken-draw) draw2 + 'evil-dr-porkchop + 'zurg))] } @@ -2390,7 +2420,7 @@ A @racket[print] request is directed to @racket[custom-write].} Returns @racket[#t] if @racket[v] is an object, @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (object? (new object%)) (object? object%) (object? "clam chowder") @@ -2401,7 +2431,7 @@ Returns @racket[#t] if @racket[v] is an object, @racket[#f] otherwise. Returns @racket[#t] if @racket[v] is a class, @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (class? object%) (class? (class object% (super-new))) (class? (new object%)) @@ -2413,7 +2443,7 @@ Returns @racket[#t] if @racket[v] is a class, @racket[#f] otherwise. Returns @racket[#t] if @racket[v] is an interface, @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (interface? (interface () empty cons first rest)) (interface? object%) (interface? "gazpacho") @@ -2424,7 +2454,7 @@ Returns @racket[#t] if @racket[v] is an interface, @racket[#f] otherwise. Returns @racket[#t] if @racket[v] is a @tech{generic}, @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (define c% (class object% (super-new) @@ -2448,7 +2478,7 @@ This procedure is similar in spirit to @racket[eq?] but also works properly with contracts (and has a stronger guarantee). -@defexamples[#:eval class-ctc-eval +@examples[#:eval class-ctc-eval (define obj-1 (new object%)) (define obj-2 (new object%)) (define/contract obj-3 (object/c) obj-1) @@ -2468,7 +2498,7 @@ This procedure is similar in spirit to Like @racket[object=?], but accepts @racket[#f] for either argument and returns @racket[#t] if both arguments are @racket[#f]. -@defexamples[#:eval class-ctc-eval +@examples[#:eval class-ctc-eval (object-or-false=? #f (new object%)) (object-or-false=? (new object%) #f) (object-or-false=? #f #f) @@ -2482,7 +2512,7 @@ returns @racket[#t] if both arguments are @racket[#f]. Returns a vector representing @racket[object] that shows its inspectable fields, analogous to @racket[struct->vector]. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (object->vector (new object%)) (object->vector (new (class object% (super-new) @@ -2494,7 +2524,7 @@ inspectable fields, analogous to @racket[struct->vector]. Returns the interface implicitly defined by @racket[class]. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (class->interface object%) ]} @@ -2504,7 +2534,7 @@ Returns the interface implicitly defined by @racket[class]. Returns the interface implicitly defined by the class of @racket[object]. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (object-interface (new object%)) ]} @@ -2515,7 +2545,7 @@ Returns @racket[#t] if @racket[v] is an instance of a class @racket[type] or a class that implements an interface @racket[type], @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (define point<%> (interface () get-x get-y)) (define 2d-point% (class* object% (point<%>) @@ -2536,7 +2566,7 @@ Returns @racket[#t] if @racket[v] is an instance of a class Returns @racket[#t] if @racket[v] is a class derived from (or equal to) @racket[cls], @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (subclass? (class object% (super-new)) object%) (subclass? object% (class object% (super-new))) (subclass? object% object%) @@ -2548,7 +2578,7 @@ to) @racket[cls], @racket[#f] otherwise. Returns @racket[#t] if @racket[v] is a class that implements @racket[intf], @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (define i<%> (interface () go)) (define c% (class* object% (i<%>) @@ -2565,7 +2595,7 @@ Returns @racket[#t] if @racket[v] is a class that implements Returns @racket[#t] if @racket[v] is an interface that extends @racket[intf], @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (define point<%> (interface () get-x get-y)) (define colored-point<%> (interface (point<%>) color)) @@ -2581,7 +2611,7 @@ Returns @racket[#t] if @racket[intf] (or any of its ancestor interfaces) includes a member with the name @racket[sym], @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (define i<%> (interface () get-x get-y)) (method-in-interface? 'get-x i<%>) (method-in-interface? 'get-z i<%>) @@ -2595,7 +2625,7 @@ including methods inherited from superinterfaces, but not including methods whose names are local (i.e., declared with @racket[define-local-member-name]). -@defexamples[#:eval class-eval +@examples[#:eval class-eval (define i<%> (interface () get-x get-y)) (interface->method-names i<%>) ]} @@ -2607,7 +2637,7 @@ methods whose names are local (i.e., declared with Returns @racket[#t] if @racket[object] has a method named @racket[sym] that accepts @racket[cnt] arguments, @racket[#f] otherwise. -@defexamples[#:eval class-eval +@examples[#:eval class-eval (define c% (class object% (super-new) @@ -2628,7 +2658,7 @@ Returns a list of all of the names of the fields bound in not including fields whose names are local (i.e., declared with @racket[define-local-member-name]). -@defexamples[#:eval class-eval +@examples[#:eval class-eval (field-names (new object%)) (field-names (new (class object% (super-new) (field [x 0] [y 0])))) ]} diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index d22ffc44cc..e8a4eb1d10 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -182,25 +182,63 @@ If there are multiple higher-order contracts, @racket[or/c] uses them. More precisely, when an @racket[or/c] is checked, it first checks all of the @tech{flat contracts}. If none of them pass, it calls @racket[contract-first-order-passes?] with each of the -higher-order contracts, taking the first one that returns -true as the contract for the value. - +higher-order contracts. If only one returns true, @racket[or/c] uses +that contract. If none of them return true, it signals a contract +violation. If more than one returns true, it also signals a contract +violation. For example, this contract @racketblock[ (or/c (-> number? number?) (-> string? string? string?)) ] -accepts a function like this one: @racket[(lambda args ...)], -using the @racket[(-> number? number?)] contract on it, ignoring -the @racket[(-> string? string? string?)] contract since it came -second. +does not accept a function like this one: @racket[(lambda args ...)] +since it cannot tell which of the two arrow contracts should be used +with the function. If all of its arguments are @racket[list-contract?]s, then @racket[or/c] returns a @racket[list-contract?]. +} -@history[#:changed "6.3" @list{Adjusted @racket[or/c] so that it - takes the first higher-order contract instead of insisting that - there be exactly one higher-order contract for a given value.}] +@defproc[(first-or/c [contract contract?] ...) + contract?]{ + + Takes any number of contracts and returns a contract that + accepts any value that any one of the contracts accepts + individually. + + The @racket[first-or/c] result tests any value by applying the + contracts in order from left to right. Thus, a contract + such as @racket[(first-or/c (not/c real?) positive?)] + is guaranteed to only invoke the + @racket[positive?] predicate on real numbers. + + If all of the arguments are procedures or @tech{flat + contracts}, the result is a @tech{flat contract} and + similarly if all of the arguments are @tech{chaperone + contracts} the result is too. Otherwise, the result is an + @tech{impersonator contract}. + + If there are multiple higher-order contracts, + @racket[first-or/c] uses @racket[contract-first-order-passes?] + to distinguish between them. More precisely, when an + @racket[first-or/c] is checked, it checks the first order passes + of the first contract against the value. If it succeeds, + then it uses only that contract. If it fails, then it moves + to the second contract, continuing until it finds one of + the contracts where the first order check succeeds. If none + of them do, a contract violation is signaled. + + For example, this contract + @racketblock[ + (first-or/c (-> number? number?) + (-> string? string? string?))] + accepts the function @racket[(λ args 0)], + applying the @racket[(->number? number?)] contract to the function + because it comes first, even though + @racket[(-> string? string? string?)] also applies. + + If all of its arguments are @racket[list-contract?]s, then @racket[first-or/c] + returns a @racket[list-contract?]. } @defproc[(and/c [contract contract?] ...) contract?]{ @@ -217,7 +255,7 @@ the contracts in order, from left to right.} @defproc[(not/c [flat-contract flat-contract?]) flat-contract?]{ -Accepts a flat contracts or a predicate and returns a flat contract +Accepts a flat contract or a predicate and returns a flat contract that checks the inverse of the argument.} @@ -328,7 +366,12 @@ is a chaperone contract, then the result will be a chaperone contract. When a higher-order @racket[vectorof] contract is applied to a vector, the result is not @racket[eq?] to the input. The result will be a copy for immutable vectors -and a @tech{chaperone} or @tech{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 flat contract and the vector is immutable, +in which case the result is the original vector. + +@history[#:changed "6.3.0.5" @list{Changed flat vector contracts to not copy + immutable vectors.}]} @defproc[(vector-immutableof [c contract?]) contract?]{ @@ -397,13 +440,14 @@ Returns a contract that recognizes a list whose every element matches the contract @racket[c]. Beware that when this contract is applied to a value, the result is not necessarily @racket[eq?] to the input. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract some-numbers (listof number?) (list 1 2 3)) - (define/contract just-one-number - (listof number?) - 11)] + (eval:error + (define/contract just-one-number + (listof number?) + 11))] } @@ -414,14 +458,15 @@ Returns a contract that recognizes non-empty lists whose elements match the contract @racket[c]. Beware that when this contract is applied to a value, the result is not necessarily @racket[eq?] to the input. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract some-numbers (non-empty-listof number?) (list 1 2 3)) - (define/contract not-enough-numbers - (non-empty-listof number?) - (list))] + (eval:error + (define/contract not-enough-numbers + (non-empty-listof number?) + (list)))] } @defproc[(list*of [c contract?]) contract?]{ @@ -433,14 +478,15 @@ its @racket[cdr] position is expected to be @racket[(list*of c)]. Otherwise, it is expected to match @racket[c]. Beware that when this contract is applied to a value, the result is not necessarily @racket[eq?] to the input. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract improper-numbers (list*of number?) (cons 1 (cons 2 3))) - (define/contract not-improper-numbers - (list*of number?) - (list 1 2 3))] + (eval:error + (define/contract not-improper-numbers + (list*of number?) + (list 1 2 3)))] @history[#:added "6.1.1.1"] } @@ -456,14 +502,15 @@ necessarily @racket[eq?] to the input. If the @racket[cdr-c] contract is a @racket[list-contract?], then @racket[cons/c] returns a @racket[list-contract?]. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract a-pair-of-numbers (cons/c number? number?) (cons 1 2)) - (define/contract not-a-pair-of-numbers - (cons/c number? number?) - (cons #f #t))] + (eval:error + (define/contract not-a-pair-of-numbers + (cons/c number? number?) + (cons #f #t)))] @history[#:changed "6.0.1.13" @list{Added the @racket[list-contract?] propagating behavior.}] } @@ -482,14 +529,15 @@ In the first case, the contract on the @racket[cdr-id] portion of the contract may depend on the value in the @racket[car-id] portion of the pair and in the second case, the reverse is true. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract an-ordered-pair-of-reals (cons/dc [hd real?] [tl (hd) (>=/c hd)]) (cons 1 2)) - (define/contract not-an-ordered-pair-of-reals - (cons/dc [hd real?] [tl (hd) (>=/c hd)]) - (cons 2 1))] + (eval:error + (define/contract not-an-ordered-pair-of-reals + (cons/dc [hd real?] [tl (hd) (>=/c hd)]) + (cons 2 1)))] @history[#:added "6.1.1.6"] } @@ -610,7 +658,7 @@ Produces a contract on parameters whose values must match @racket[_out]. When the value in the contracted parameter is set, it must match @racket[_in]. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract current-snack (parameter/c string?) (make-parameter "potato-chip")) @@ -620,9 +668,10 @@ is set, it must match @racket[_in]. (parameter/c string? baked/c) (make-parameter "turkey" (λ (s) (string-append "roasted " s)))) -(current-snack 'not-a-snack) -(parameterize ([current-dinner "tofurkey"]) - (current-dinner)) +(eval:error (current-snack 'not-a-snack)) +(eval:error + (parameterize ([current-dinner "tofurkey"]) + (current-dinner))) ]} @@ -640,18 +689,18 @@ Produces a contract for procedures that accept @racket[n] argument Produces a contract that recognizes @racket[hash] tables with keys and values as specified by the @racket[key] and @racket[val] arguments. -@examples[#:eval - (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract good-hash (hash/c integer? boolean?) (hash 1 #t 2 #f 3 #t)) - (define/contract bad-hash - (hash/c integer? boolean?) - (hash 1 "elephant" - 2 "monkey" - 3 "manatee"))] + (eval:error + (define/contract bad-hash + (hash/c integer? boolean?) + (hash 1 "elephant" + 2 "monkey" + 3 "manatee")))] There are a number of technicalities that control how @racket[hash/c] contracts behave. @@ -660,17 +709,15 @@ behave. a flat contract, and the @racket[key] and @racket[val] arguments must also be flat contracts. -@examples[#:eval - (contract-eval) +@examples[#:eval (contract-eval) #:once (flat-contract? (hash/c integer? boolean?)) (flat-contract? (hash/c integer? boolean? #:flat? #t)) - (hash/c integer? (-> integer? integer?) #:flat? #t)] + (eval:error (hash/c integer? (-> integer? integer?) #:flat? #t))] Such flat contracts will be unsound if applied to mutable hash tables, as they will not check future mutations to the hash table. -@examples[#:eval - (contract-eval) +@examples[#:eval (contract-eval) #:once (define original-h (make-hasheq)) (define/contract ctc-h (hash/c integer? boolean? #:flat? #t) @@ -682,15 +729,13 @@ If the @racket[immutable] argument is @racket[#t] and the @racket[key] and @racket[val] arguments are @racket[flat-contract?]s, the result will be a @racket[flat-contract?]. -@examples[#:eval - (contract-eval) +@examples[#:eval (contract-eval) #:once (flat-contract? (hash/c integer? boolean? #:immutable #t))] If either the domain or the range is a @racket[chaperone-contract?], then the result will be a @racket[chaperone-contract?]. -@examples[#:eval - (contract-eval) +@examples[#:eval (contract-eval) #:once (flat-contract? (hash/c (-> integer? integer?) boolean? #:immutable #t)) (chaperone-contract? (hash/c (-> integer? integer?) boolean? @@ -701,11 +746,11 @@ be a @racket[chaperone-contract?]. If the @racket[key] argument is a @racket[chaperone-contract?] but not a @racket[flat-contract?], then the resulting contract can be applied only to @racket[equal?]-based hash tables. -@examples[#:eval - (contract-eval) - (define/contract h - (hash/c (-> integer? integer?) any/c) - (make-hasheq))] +@examples[#:eval (contract-eval) #:once + (eval:error + (define/contract h + (hash/c (-> integer? integer?) any/c) + (make-hasheq)))] Also, when such a @racket[hash/c] contract is applied to a hash table, the result is not @racket[eq?] to the input. The result of applying the contract will be a copy for immutable hash tables, @@ -734,16 +779,16 @@ for mutable hash tables. and it may also be @racket['impersonator], in which case they may be any @racket[contract?]s. The default is @racket['chaperone]. - @examples[#:eval - (contract-eval) + @examples[#:eval (contract-eval) #:once (define/contract h (hash/dc [k real?] [v (k) (>=/c k)]) (hash 1 3 2 4)) - (define/contract h - (hash/dc [k real?] [v (k) (>=/c k)]) - (hash 3 1 - 4 2))] + (eval:error + (define/contract h + (hash/dc [k real?] [v (k) (>=/c k)]) + (hash 3 1 + 4 2)))] } @@ -758,12 +803,12 @@ is a chaperone contract. Otherwise, the resulting contract is an impersonator contract. When a channel contract is applied to a channel, the resulting channel is not @racket[eq?] to the input. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract chan (channel/c string?) (make-channel)) (thread (λ () (channel-get chan))) - (channel-put chan 'not-a-string) + (eval:error (channel-put chan 'not-a-string)) ]} @@ -789,19 +834,20 @@ If @racket[maybe-call/cc] is provided, then the provided contracts are used to check the return values from a continuation captured with @racket[call-with-current-continuation]. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract tag (prompt-tag/c (-> number? string?)) (make-continuation-prompt-tag)) - (call-with-continuation-prompt - (lambda () - (number->string - (call-with-composable-continuation - (lambda (k) - (abort-current-continuation tag k))))) - tag - (lambda (k) (k "not a number"))) + (eval:error + (call-with-continuation-prompt + (lambda () + (number->string + (call-with-composable-continuation + (lambda (k) + (abort-current-continuation tag k))))) + tag + (lambda (k) (k "not a number")))) ] } @@ -815,17 +861,18 @@ If the argument @racket[contract] is a chaperone contract, the resulting contract will also be a @tech{chaperone} contract. Otherwise, the contract is an @tech{impersonator} contract. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract mark-key (continuation-mark-key/c (-> symbol? (listof symbol?))) (make-continuation-mark-key)) - (with-continuation-mark - mark-key - (lambda (s) (append s '(truffle fudge ganache))) - (let ([mark-value (continuation-mark-set-first - (current-continuation-marks) mark-key)]) - (mark-value "chocolate-bar"))) + (eval:error + (with-continuation-mark + mark-key + (lambda (s) (append s '(truffle fudge ganache))) + (let ([mark-value (continuation-mark-set-first + (current-continuation-marks) mark-key)]) + (mark-value "chocolate-bar")))) ] } @@ -837,7 +884,7 @@ Returns a contract that recognizes @tech{synchronizable event}s whose The resulting contract is always a @tech{chaperone} contract and its arguments must all be chaperone contracts. -@defexamples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract my-evt (evt/c evt?) always-evt) @@ -845,7 +892,7 @@ arguments must all be chaperone contracts. (evt/c number? number?) (alarm-evt (+ (current-inexact-milliseconds) 50))) (sync my-evt) - (sync failing-evt) + (eval:error (sync failing-evt)) ] } @@ -1047,18 +1094,21 @@ symbols, and that return a symbol. } @defform*/subs[#:literals (any values) -[(->i (mandatory-dependent-dom ...) +[(->i maybe-chaperone + (mandatory-dependent-dom ...) dependent-rest pre-condition dependent-range post-condition) - (->i (mandatory-dependent-dom ...) + (->i maybe-chaperone + (mandatory-dependent-dom ...) (optional-dependent-dom ...) dependent-rest pre-condition dependent-range post-condition)] -([mandatory-dependent-dom id+ctc +([maybe-chaperone #:chaperone (code:line)] + [mandatory-dependent-dom id+ctc (code:line keyword id+ctc)] [optional-dependent-dom id+ctc (code:line keyword id+ctc)] @@ -1093,6 +1143,12 @@ combinator in that each argument and result is named and these names can be used in the subcontracts and in the pre-/post-condition clauses. In other words, @racket[->i] expresses dependencies among arguments and results. +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 +and results must be chaperone contracts and the result of @racket[->i] will be +a chaperone contract. If it is not present, then the result +contract will not be a chaperone contract. + 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 rest-args contract, and an optional pre-condition. The pre-condition is @@ -1329,14 +1385,14 @@ by some @racket[x] in positive position with respect to @racket[parametric->/c]) are checked for the appropriate wrapper. If they have it, they are unwrapped; if they do not, a contract violation is signaled. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define/contract (check x y) (parametric->/c [X] (boolean? X . -> . X)) (if (or (not x) (equal? y 'surprise)) 'invalid y)) (check #t 'ok) -(check #f 'ignored) +(eval:error (check #f 'ignored)) (check #t 'surprise) ] } @@ -1546,8 +1602,7 @@ the export. should be reported in terms of the public module instead of the private one. - @examples[#:eval - (contract-eval) + @examples[#:eval (contract-eval) #:once (module private-implementation racket/base (require racket/contract) (define (recip x) (/ 1 x)) @@ -1560,7 +1615,7 @@ the export. (provide (recontract-out recip))) (require 'public) - (recip +nan.0)] + (eval:error (recip +nan.0))] Replacing the use of @racket[recontract-out] with just @racket[recip] would result in a contract violation blaming @@ -1628,7 +1683,7 @@ For the definition of @racket[free-var-list], see @racket[with-contract]. (-> real? real?) (* 660 fr)) (code:comment "a contract violation expected here:") - (furlongs->feet "not a furlong") + (eval:error (furlongs->feet "not a furlong")) ] The @racket[define/contract] form treats the individual definition as @@ -1639,7 +1694,7 @@ positions of the contract. Since the contract boundary is between the definition and the surrounding context, references to @racket[id] inside the @racket[define/contract] form are not checked. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (code:comment "an unsual predicate that prints when called") (define (printing-int? x) (displayln "I was called") @@ -1649,7 +1704,7 @@ between the definition and the surrounding context, references to (if (zero? n) 1 (* n (fact (sub1 n))))) - (fact 5) (code:comment "only prints twice, not for each recursive call") + (code:line (fact 5) (code:comment "only prints twice, not for each recursive call")) ] If a free-var-list is given, then any uses of the free variables @@ -1657,7 +1712,7 @@ inside the @racket[body] will be protected with contracts that blame the context of the @racket[define/contract] form for the positive positions and the @racket[define/contract] form for the negative ones. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define (integer->binary-string n) (number->string n 2)) (define/contract (numbers->strings lst) @@ -1665,7 +1720,7 @@ positions and the @racket[define/contract] form for the negative ones. #:freevar integer->binary-string (-> exact-integer? string?) (code:comment "mistake, lst might contain inexact numbers") (map integer->binary-string lst)) - (numbers->strings '(4.0 3.3 5.8)) + (eval:error (numbers->strings '(4.0 3.3 5.8))) ]} @defform*[[(define-struct/contract struct-id ([field contract-expr] ...) @@ -1682,15 +1737,15 @@ The @racket[define-struct/contract] form only allows a subset of the @racket[#:auto-value], @racket[#:omit-define-syntaxes], @racket[#:property] and @racket[#:omit-define-values]. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define-struct/contract fish ([color number?])) (make-fish 5) -(make-fish #f) +(eval:error (make-fish #f)) (define-struct/contract (salmon fish) ([ocean symbol?])) (make-salmon 5 'atlantic) -(make-salmon 5 #f) -(make-salmon #f 'pacific) +(eval:error (make-salmon 5 #f)) +(eval:error (make-salmon #f 'pacific)) ]} @defform[(invariant-assertion invariant-expr expr)]{ @@ -1707,7 +1762,7 @@ The @racket[define-struct/contract] form only allows a subset of the recursive calls, when an invariant is used on the right-hand side of a definition: - @examples[#:eval + @examples[#:eval furlongs->feet-eval (define furlongss->feets (invariant-assertion @@ -1723,7 +1778,7 @@ The @racket[define-struct/contract] form only allows a subset of the (furlongss->feets (list 1 2 3)) - (furlongss->feets (list 1 327 3))] + (eval:error (furlongss->feets (list 1 327 3)))] @history[#:added "6.0.1.11"] @@ -1767,8 +1822,7 @@ The @racket[define-struct/contract] form only allows a subset of the it can be any of the things that the third argument to @racket[datum->syntax] can be. - @examples[#:eval - (contract-eval) + @examples[#:eval (contract-eval) #:once (module server racket/base (require racket/contract/base) (define (f x) #f) @@ -1780,8 +1834,8 @@ The @racket[define-struct/contract] form only allows a subset of the (define (servers-fault) (g 1)) (provide servers-fault clients-fault)) (require 'client) - (clients-fault) - (servers-fault)] + (eval:error (clients-fault)) + (eval:error (servers-fault))] } @@ -1813,10 +1867,9 @@ produces @racket[#f], no name is printed. Otherwise, it is also formatted as by @racket[display]. More precisely, the @racket[value-name-expr] ends up in the @racket[blame-name] field of the blame record, which is used as the first portion of the error message. -@examples[#:eval - (contract-eval) - (contract integer? #f 'pos 'neg 'timothy #f) - (contract integer? #f 'pos 'neg #f #f)] +@examples[#:eval (contract-eval) #:once + (eval:error (contract integer? #f 'pos 'neg 'timothy #f)) + (eval:error (contract integer? #f 'pos 'neg #f #f))] If specified, @racket[source-location-expr] indicates the source location reported by contract violations. The expression must produce a @racket[srcloc] @@ -1922,11 +1975,14 @@ contracts is @racketresult[anonymous-chaperone-contract], and for flat contracts is @racketresult[anonymous-flat-contract]. The first-order predicate @racket[test] can be used to determine which values -the contract applies to; usually, this is the set of values for which the +the contract applies to; this must be the set of values for which the contract fails immediately without any higher-order wrapping. This test is used -by @racket[contract-first-order-passes?], and indirectly by @racket[or/c] to -determine which of multiple higher-order contracts to wrap a value with. The -default test accepts any value. +by @racket[contract-first-order-passes?], and indirectly by @racket[or/c] +and @racket[from-or/c] to determine which higher-order contract to wrap a +value with when there are multiple higher-order contracts to choose from. +The default test accepts any value. The predicate should be influenced by +the value of @racket[(contract-first-order-okay-to-give-up?)] (see it's documentation +for more explanation). The @racket[late-neg-proj] defines the behavior of applying the contract. If it is supplied, it accepts a blame object that does not have a value for @@ -1948,6 +2004,14 @@ first-order test fails, and produces the value unchanged otherwise. The @racket[val-first-proj] is like @racket[late-neg-proj], except with an extra layer of currying. +At least one of the @racket[late-neg-proj], @racket[proj], + @racket[val-first-proj], or @racket[first-order] must be non-@racket[#f]. + +The projection arguments (@racket[late-neg-proj], @racket[proj], and + @racket[val-first-proj]) must be in sync with the @racket[test] argument. + In particular, if the test argument returns @racket[#f] for some value, + then the projections must raise a blame error for that value. + Projections for chaperone contracts must produce a value that passes @racket[chaperone-of?] when compared with the original, uncontracted value. Projections for flat contracts must fail precisely when the first-order test @@ -1959,16 +2023,18 @@ flat contracts do not need to supply an explicit projection. 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 -was passed as the second argument to @racket[contract-stronger?]. +was passed as the second argument to @racket[contract-stronger?]. If no +@racket[stronger] argument is supplied, then a default that compares its arguments +with @racket[equal?] is used. The @racket[is-list-contract?] argument is used by the @racket[list-contract?] predicate to determine if this is a contract that accepts only @racket[list?] values. -@defexamples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define int/c (make-flat-contract #:name 'int/c #:first-order integer?)) (contract int/c 1 'positive 'negative) -(contract int/c "not one" 'positive 'negative) +(eval:error (contract int/c "not one" 'positive 'negative)) (int/c 1) (int/c "not one") (define int->int/c @@ -1987,12 +2053,12 @@ to determine if this is a contract that accepts only @racket[list?] values. b f '(expected "a function of one argument" given: "~e") f))))))) -(contract int->int/c "not fun" 'positive 'negative) +(eval:error (contract int->int/c "not fun" 'positive 'negative)) (define halve (contract int->int/c (λ (x) (/ x 2)) 'positive 'negative)) (halve 2) -(halve 1/2) -(halve 1) +(eval:error (halve 1/2)) +(eval:error (halve 1)) ] @history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}] @@ -2057,12 +2123,69 @@ contracts. The error messages assume that the function named by @history[#:added "6.1.1.5"] } +@defproc[(get/build-late-neg-projection [c contract?]) + (-> contract? blame? (-> any/c any/c any/c))]{ + Returns the @racket[_late-neg] projection for @racket[c]. + + If @racket[c] does not have a @racket[_late-neg] contract, + then this function uses the original projection for it + and logs a warning to the @racket['racket/contract] logger. + + See @racket[make-contract] for more details. + + @history[#:added "6.2.900.11"] +} + +@defparam[skip-projection-wrapper? wrap? boolean? #:value #f]{ + The functions @racket[make-chaperone-contract] and + @racket[build-chaperone-contract-property] wrap their + arguments to ensure that the result of the projections + are chaperones of the input. This layer of wrapping can, + in some cases, introduce unwanted overhead into contract + checking. If this parameter's value is @racket[#t] + during the dynamic extent of the call to either of those + functions, the wrapping (and thus the checks) are skipped. +} + @subsection{Blame Objects} @defproc[(blame? [x any/c]) boolean?]{ This predicate recognizes @|blame-objects|. } +@defproc[(raise-blame-error [b blame?] + [x any/c] + [fmt (or/c string? + (listof (or/c string? + 'given 'given: + 'expected 'expected:)))] + [v any/c] ...) + none/c]{ + +Signals a contract violation. The first argument, @racket[b], records the +current blame information, including positive and negative parties, the name of +the contract, the name of the value, and the source location of the contract +application. The second argument, @racket[x], is the value that failed to +satisfy the contract. + +The remaining arguments are a format string, +@racket[fmt], and its arguments, @racket[v ...], specifying an error message +specific to the precise violation. + +If @racket[fmt] is a list, then the elements are concatenated together +(with spaces added, unless there are already spaces at the ends of the strings), +after first replacing symbols with either their string counterparts, or +replacing @racket['given] with @racket["produced"] and +@racket['expected] with @racket["promised"], depending on whether or not +the @racket[b] argument has been swapped or not (see @racket[blame-swap]). + +If @racket[fmt] contains the symbols @racket['given:] or @racket['expected:], +they are replaced like @racket['given:] and @racket['expected:] are, but +the replacements are prefixed with the string @racket["\n "] to conform +to the error message guidelines in @secref["err-msg-conventions"]. + +} + @defproc[(blame-add-context [blame blame?] [context (or/c string? #f)] [#:important important (or/c string? #f) #f] @@ -2078,12 +2201,12 @@ contracts. The error messages assume that the function named by or @racket["a conjunct of"] (in the case of an @racket[and/c] contract). For example, consider this contract violation: - @interaction[#:eval (contract-eval) + @examples[#:label #f #:eval (contract-eval) #:once (define/contract f (list/c (-> integer? integer?)) (list (λ (x) x))) -((car f) #f) +(eval:error ((car f) #f)) ] It shows that the portion of the contract being violated is the first occurrence of @racket[integer?], because the @racket[->] and @@ -2163,39 +2286,18 @@ the other; both are provided for convenience and clarity. and negative parties of @racket[b] respectively. } -@defproc[(raise-blame-error [b blame?] - [x any/c] - [fmt (or/c string? - (listof (or/c string? - 'given 'given: - 'expected 'expected:)))] - [v any/c] ...) - none/c]{ - -Signals a contract violation. The first argument, @racket[b], records the -current blame information, including positive and negative parties, the name of -the contract, the name of the value, and the source location of the contract -application. The second argument, @racket[x], is the value that failed to -satisfy the contract. - -The remaining arguments are a format string, -@racket[fmt], and its arguments, @racket[v ...], specifying an error message -specific to the precise violation. - -If @racket[fmt] is a list, then the elements are concatenated together -(with spaces added, unless there are already spaces at the ends of the strings), -after first replacing symbols with either their string counterparts, or -replacing @racket['given] with @racket["produced"] and -@racket['expected] with @racket["promised"], depending on whether or not -the @racket[b] argument has been swapped or not (see @racket[blame-swap]). - -If @racket[fmt] contains the symbols @racket['given:] or @racket['expected:], -they are replaced like @racket['given:] and @racket['expected:] are, but -the replacements are prefixed with the string @racket["\n "] to conform -to the error message guidelines in @secref["err-msg-conventions"]. - +@defproc[(blame-missing-party? [b blame?]) boolean?]{ + Returns @racket[#t] when @racket[b] does not have both parties. } +@defproc[(blame-add-missing-party [b (and/c blame? blame-missing-party?)] + [missing-party any/c]) + (and/c blame? (not/c blame-missing-party?))]{ + Produces a new blame object like @racket[b], except that the missing + party is replaced with @racket[missing-party]. +} + + @defstruct[(exn:fail:contract:blame exn:fail:contract) ([object blame?])]{ This exception is raised to signal a contract error. The @racket[object] field contains a @|blame-object| associated with a contract violation. @@ -2217,7 +2319,7 @@ returns a string that is put into the contract error message. Note that the value is often already included in the message that indicates the violation. -@defexamples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (define (show-blame-error blame value message) (string-append "Contract Violation!\n" @@ -2233,8 +2335,8 @@ the message that indicates the violation. (-> integer? integer?) (/ x 2)) (f 2) -(f 1) -(f 1/2) +(eval:error (f 1)) +(eval:error (f 1/2)) ] } @@ -2282,10 +2384,17 @@ is expected to be the contract on the value). @defthing[impersonator-prop:blame impersonator-property?] )]{ These properties attach a blame information to the protected structure, -chaperone, or impersonator value. The function @racket[blame-contract?] +chaperone, or impersonator value. The function @racket[has-blame?] returns @racket[#t] for values that have one of these properties, and -@racket[blame-contract] extracts the value from the property (which -is expected to be the blame record for the contract on the value). +@racket[value-blame] extracts the value from the property. + +The value is expected to be the blame record for the contract on the value or +a @racket[cons]-pair of a blame record with a missing party and the missing +party. The @racket[value-blame] function reassembles the arguments of the pair +into a complete blame record using @racket[blame-add-missing-party]. If +the value has one of the properties, but the value is not a blame object +or a pair whose @racket[car] position is a blame object, then @racket[has-blame?] +returns @racket[#f] but @racket[value-blame] returns @racket[#f]. } @deftogether[( @@ -2448,34 +2557,39 @@ is expected to be the blame record for the contract on the value). (λ (c) (λ (fuel) (values void '())))] [#:list-contract? is-list-contract? (-> contract? boolean?) (λ (c) #f)]) contract-property?])]{ - - @italic{The precise details of the - @racket[val-first-projection] argument - are subject to change. (Probably - also the default values of the @racket[project] - arguments will change.)} - These functions build the arguments for @racket[prop:contract], @racket[prop:chaperone-contract], and @racket[prop:flat-contract], respectively. A @deftech{contract property} specifies the behavior of a structure when used as -a contract. It is specified in terms of five accessors: @racket[get-name], -which produces a description to @racket[write] as part of a contract violation; -@racket[get-first-order], which produces a first-order predicate to be used by -@racket[contract-first-order-passes?]; @racket[get-projection], which -produces a blame-tracking projection defining the behavior of the contract; -@racket[stronger], which is a predicate that determines whether this contract -(passed in the first argument) is stronger than some other contract (passed -in the second argument); @racket[generate], which returns a thunk -that generates random values matching the contract (using @racket[contract-random-generate-fail]) -to indicate failure) or @racket[#f] to indicate -that random generation for this contract isn't supported; @racket[exercise], -which returns a function that exercises values matching the contract (e.g., -if it is a function contract, it may call the function) and a list of contracts -whose values will be generated by this process; and @racket[is-flat-contract?], -which is used by @racket[flat-contract?] to determine if this contract -accepts only @racket[list?]s. +a contract. It is specified in terms of seven properties: +@itemlist[ + @item{@racket[get-name] which produces a description to @racket[write] as part + of a contract violation;} + @item{@racket[get-first-order], which produces a first-order predicate to be + used by @racket[contract-first-order-passes?];} + @item{@racket[get-late-neg-projection], which produces a blame-tracking projection + defining the behavior of the contract (The @racket[get-projection] + and @racket[get-val-first-projection] arguments also specify the projection, + but using a different signature. They are here for backwards compatibility.);} + @item{@racket[stronger], a predicate that determines whether this + contract (passed in the first argument) is stronger than some other + contract (passed in the second argument) and whose default always + returns @racket[#f];} + @item{@racket[generate], which returns a thunk that generates random values + matching the contract (using @racket[contract-random-generate-fail]) + to indicate failure) or @racket[#f] to indicate that random + generation for this contract isn't supported;} + @item{@racket[exercise], which returns a function that exercises values + matching the contract (e.g., if it is a function contract, it may call + the function) and a list of contracts whose values will be generated + by this process;} + @item{and @racket[is-list-contract?], which is used by @racket[flat-contract?] + to determine if this contract accepts only @racket[list?]s.} +] + +At least one of the @racket[late-neg-proj], @racket[proj], +@racket[val-first-proj], or @racket[first-order] must be non-@racket[#f]. These accessors are passed as (optional) keyword arguments to @racket[build-contract-property], and are applied to instances of the @@ -2615,17 +2729,20 @@ are below): Returns @racket[#t] if the contract @racket[x] accepts either fewer or the same number of values as @racket[y] does. + Contracts that are the same (i.e., where @racket[x] is @racket[equal?] + to @racket[y]) are considered to always be stronger than each other. + This function is conservative, so it may return @racket[#f] when @racket[x] does, in fact, accept fewer values. -@examples[#:eval (contract-eval) +@examples[#:eval (contract-eval) #:once (contract-stronger? integer? integer?) (contract-stronger? (between/c 25 75) (between/c 0 100)) (contract-stronger? (between/c 0 100) (between/c 25 75)) (contract-stronger? (between/c -10 0) (between/c 0 10)) - (contract-stronger? (λ (x) (and (real? x) (<= x (random 10)))) - (λ (x) (and (real? x) (<= x (+ 100 (random 10))))))] + (contract-stronger? (λ (x) (and (real? x) (<= x 0))) + (λ (x) (and (real? x) (<= x 100))))] } @@ -2641,7 +2758,11 @@ If it returns @racket[#f], the contract is guaranteed not to hold for that value; if it returns @racket[#t], the contract may or may not hold. If the contract is a first-order contract, a result of @racket[#t] guarantees that the -contract holds.} +contract holds. + +See also @racket[contract-first-order-okay-to-give-up?] and +@racket[contract-first-order-try-less-hard]. +} @defproc[(contract-first-order [c contract?]) (-> any/c boolean?)]{ Produces the first-order test used by @racket[or/c] to match values to @@ -2727,8 +2848,28 @@ Produces the name used to describe the contract in error messages. @history[#:added "6.0.1.12"] } +@defproc[(contract-late-neg-projection [c contract?]) (-> blame? (-> any/c (or/c #f any/c) any/c))]{ + Produces the projection defining a contract's behavior. + + The first argument, @racket[blame?] object encapsulates information about + the contract checking, mostly used to create a meaningful error message if + a contract violation is detected. The resulting function's first argument + is the value that should have the contract and its second argument is + a ``missing party'' from the blame object, to be passed to @racket[raise-contract-error]. + + If possible, use this function instead of @racket[contract-val-first-projection] or + @racket[contract-projection]. +} + + @defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{ - Produces the projection defining a contract's behavior on protected values. + Produces the projection defining a contract's behavior. See also + @racket[contract-late-neg-projection]. +} + +@defproc[(contract-val-first-projection [c contract?]) (-> blame? (-> any/c (-> any/c any/c)))]{ + Produces the projection defining a contract's behavior. + See also @racket[contract-late-neg-projection]. } @defproc[(make-none/c [sexp-name any/c]) contract?]{ @@ -2772,13 +2913,15 @@ expression, then @racket[opt/c] raises an error using @racket[id] as the name of the primitive, instead of using the name @racket[opt/c]. -@examples[#:eval (contract-eval) - (define/contract (f x) - (opt/c '(not-a-contract)) - x) - (define/contract (f x) - (opt/c '(not-a-contract) #:error-name define/contract) - x)] +@examples[#:eval (contract-eval) #:once + (eval:error + (define/contract (f x) + (opt/c '(not-a-contract)) + x)) + (eval:error + (define/contract (f x) + (opt/c '(not-a-contract) #:error-name define/contract) + x))] } @@ -2837,6 +2980,35 @@ currently being checked. @history[#:added "6.3"] } +@defform[(contract-first-order-okay-to-give-up?)]{ + This form returns a boolean that controls the result + of first-order contact checks. More specifically, if + it returns @racket[#t], then a first-order check may + return @racket[#t] even when the entire first-order + checks have not happened. If it returns @racket[#f] + then the first order checks must continue until a + definitive answer is returned. + + This will only return @racket[#t] in the dynamic + extent of @racket[or/c] or @racket[first-or/c]'s + checking to determine which branch to use. + + @history[#:added "6.3.0.9"] +} +@defform[(contract-first-order-try-less-hard e)]{ + Encourages first-order checks that happen in the + dynamic-extent of @racket[e] to be more likely to + give up. That is, makes it more likely that + @racket[contract-first-order-okay-to-give-up?] might + return @racket[#t]. + + If not in the dynamic-extent of @racket[or/c]'s or + @racket[first-or/c]'s checking to determine the branch, + then this form has no effect. + + @history[#:added "6.3.0.9"] +} + @defproc[(if/c [predicate (-> any/c any/c)] [then-contract contract?] [else-contract contract?]) diff --git a/pkgs/racket-doc/scribblings/reference/custom-ports.scrbl b/pkgs/racket-doc/scribblings/reference/custom-ports.scrbl index 4cc96f8846..ac690a17ba 100644 --- a/pkgs/racket-doc/scribblings/reference/custom-ports.scrbl +++ b/pkgs/racket-doc/scribblings/reference/custom-ports.scrbl @@ -455,7 +455,7 @@ The arguments implement the port as follows: ;; The port doesn't supply procedures to implement progress events: (port-provides-progress-evts? infinite-ones) -(port-progress-evt infinite-ones) +(eval:error (port-progress-evt infinite-ones)) ;; Non-byte port results: (define infinite-voids @@ -464,7 +464,7 @@ The arguments implement the port as follows: (lambda (s) (lambda args 'void)) (lambda (skip s evt) (lambda args 'void)) void)) -(read-char infinite-voids) +(eval:error (read-char infinite-voids)) (read-char-or-special infinite-voids) ;; This port produces 0, 1, 2, 0, 1, 2, etc., but it is not diff --git a/pkgs/racket-doc/scribblings/reference/custom-write.scrbl b/pkgs/racket-doc/scribblings/reference/custom-write.scrbl index 30bba2b84c..ed0d66af3d 100644 --- a/pkgs/racket-doc/scribblings/reference/custom-write.scrbl +++ b/pkgs/racket-doc/scribblings/reference/custom-write.scrbl @@ -47,25 +47,27 @@ angle brackets in @racket[write] and @racket[print] mode and no brackets in @racket[display] mode. Elements of the tuple are printed recursively, so that graph and cycle structure can be represented. -@defexamples[ -(define (tuple-print tuple port mode) - (when mode (write-string "<" port)) - (let ([l (tuple-ref tuple)] - [recur (case mode - [(#t) write] - [(#f) display] - [else (lambda (p port) (print p port mode))])]) - (unless (zero? (vector-length l)) - (recur (vector-ref l 0) port) - (for-each (lambda (e) - (write-string ", " port) - (recur e port)) - (cdr (vector->list l))))) - (when mode (write-string ">" port))) +@examples[ +(eval:no-prompt + (define (tuple-print tuple port mode) + (when mode (write-string "<" port)) + (let ([l (tuple-ref tuple)] + [recur (case mode + [(#t) write] + [(#f) display] + [else (lambda (p port) (print p port mode))])]) + (unless (zero? (vector-length l)) + (recur (vector-ref l 0) port) + (for-each (lambda (e) + (write-string ", " port) + (recur e port)) + (cdr (vector->list l))))) + (when mode (write-string ">" port)))) -(struct tuple (ref) - #:methods gen:custom-write - [(define write-proc tuple-print)]) +(eval:no-prompt + (struct tuple (ref) + #:methods gen:custom-write + [(define write-proc tuple-print)])) (display (tuple #(1 2 "a"))) diff --git a/pkgs/racket-doc/scribblings/reference/define-struct.scrbl b/pkgs/racket-doc/scribblings/reference/define-struct.scrbl index 967813a6f4..3ce4bc3892 100644 --- a/pkgs/racket-doc/scribblings/reference/define-struct.scrbl +++ b/pkgs/racket-doc/scribblings/reference/define-struct.scrbl @@ -3,8 +3,8 @@ racket/generic)) @(define posn-eval (make-base-eval)) -@(interaction-eval #:eval posn-eval - (require racket/match racket/stream (for-syntax racket/base))) +@examples[#:hidden #:eval posn-eval + (require racket/match racket/stream (for-syntax racket/base))] @title[#:tag "define-struct"]{Defining Structure Types: @racket[struct]} @@ -141,7 +141,7 @@ multiple times, attaches a property value to the structure type; see (unless (and (real? temp) (>= temp -273.15)) (error "not a valid temperature")) temp)) - (celsius -275) + (eval:error (celsius -275)) ] @margin-note{Use the @racket[prop:procedure] property to implement an @@ -195,7 +195,7 @@ name, as do the various procedures that are bound by @racket[struct]. @examples[#:eval posn-eval (struct circle (radius) #:reflection-name ') (circle 15) - (circle-radius "bad") + (eval:error (circle-radius "bad")) ] If @racket[#:methods gen:name method-defs] is provided, then @@ -225,11 +225,12 @@ supplied, then the @racket[struct] form is equivalent to @examples[#:eval posn-eval (struct square (side) #:omit-define-syntaxes) - (match (square 5) - (code:comment "fails to match because syntax is omitted") - [(struct square x) x]) + (eval:error + (match (square 5) + (code:comment "fails to match because syntax is omitted") + [(struct square x) x])) (struct ellipse (width height) #:omit-define-values) - ellipse-width + (eval:error ellipse-width) ] If @racket[#:auto] is supplied as a @racket[field-option], then the @@ -247,20 +248,20 @@ error is reported. If any @racket[field-option] or @racket[struct-option] keyword is repeated, other than @racket[#:property], a syntax error is reported. -@defexamples[ +@examples[ #:eval posn-eval -(struct posn (x y [z #:auto]) - #:auto-value 0 - #:transparent) +(eval:no-prompt + (struct posn (x y [z #:auto #:mutable]) + #:auto-value 0 + #:transparent)) (posn 1 2) (posn? (posn 1 2)) (posn-y (posn 1 2)) -] +(posn-z (posn 1 2)) -@defs+int[ -#:eval posn-eval -[(struct color-posn posn (hue) #:mutable) - (define cp (color-posn 1 2 "blue"))] +(eval:no-prompt + (struct color-posn posn (hue) #:mutable) + (define cp (color-posn 1 2 "blue"))) (color-posn-hue cp) cp (set-posn-z! cp 3) @@ -280,11 +281,12 @@ expression is an exact, non-negative integer that corresponds to the position within the structure declaration of the field named by @racket[field-id]. -@defexamples[ +@examples[ #:eval posn-eval -(struct mood-procedure (base rating) - #:property prop:procedure (struct-field-index base)) -(define happy+ (mood-procedure add1 10)) +(eval:no-prompt + (struct mood-procedure (base rating) + #:property prop:procedure (struct-field-index base)) + (define happy+ (mood-procedure add1 10))) (happy+ 2) (mood-procedure-rating happy+) ]} @@ -305,11 +307,12 @@ provided. This form is provided for backwards compatibility; @racket[struct] is preferred. -@defexamples[ +@examples[ #:eval posn-eval -(define-struct posn (x y [z #:auto]) - #:auto-value 0 - #:transparent) +(eval:no-prompt + (define-struct posn (x y [z #:auto]) + #:auto-value 0 + #:transparent)) (make-posn 1 2) (posn? (make-posn 1 2)) (posn-y (make-posn 1 2)) @@ -326,20 +329,21 @@ the sub-form for error reporting is that it starts with @racket[id]. The @racket[define-struct/derived] form is intended for use by macros that expand to @racket[define-struct]. -@defexamples[ +@examples[ #:eval posn-eval -(define-syntax (define-xy-struct stx) - (syntax-case stx () - [(ds name . rest) - (with-syntax ([orig stx]) - #'(define-struct/derived orig name (x y) . rest))])) +(eval:no-prompt + (define-syntax (define-xy-struct stx) + (syntax-case stx () + [(ds name . rest) + (with-syntax ([orig stx]) + #'(define-struct/derived orig name (x y) . rest))]))) (define-xy-struct posn) (posn-x (make-posn 1 2)) (define-xy-struct posn #:mutable) (set-posn-x! (make-posn 1 2) 0) (code:comment "this next line will cause an error due to a bad keyword") -(define-xy-struct posn #:bad-option) +(eval:error (define-xy-struct posn #:bad-option)) ]} @; ---------------------------------------- diff --git a/pkgs/racket-doc/scribblings/reference/dicts.scrbl b/pkgs/racket-doc/scribblings/reference/dicts.scrbl index 97a7fb4103..28345f2bc2 100644 --- a/pkgs/racket-doc/scribblings/reference/dicts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/dicts.scrbl @@ -1,8 +1,8 @@ #lang scribble/doc -@(require "mz.rkt" scribble/eval (for-label racket/generic)) +@(require "mz.rkt" (for-label racket/generic)) @(define dict-eval (make-base-eval)) -@(interaction-eval #:eval dict-eval (require racket/dict racket/generic)) +@examples[#:hidden #:eval dict-eval (require racket/dict racket/generic)] @title[#:tag "dicts"]{Dictionaries} @@ -200,12 +200,12 @@ result: @examples[ #:eval dict-eval (dict-ref #hash((a . "apple") (b . "beer")) 'a) -(dict-ref #hash((a . "apple") (b . "beer")) 'c) +(eval:error (dict-ref #hash((a . "apple") (b . "beer")) 'c)) (dict-ref #hash((a . "apple") (b . "beer")) 'c #f) (dict-ref '((a . "apple") (b . "banana")) 'b) (dict-ref #("apple" "banana") 1) (dict-ref #("apple" "banana") 3 #f) -(dict-ref #("apple" "banana") -3 #f) +(eval:error (dict-ref #("apple" "banana") -3 #f)) ]} @defproc[(dict-set! [dict (and/c dict? (not/c immutable?))] @@ -461,10 +461,10 @@ Supported for any @racket[dict] that implements @racket[dict-ref] and @examples[ #:eval dict-eval -(dict-ref! (make-hasheq '((a . "apple") (b . "beer"))) 'a) +(dict-ref! (make-hasheq '((a . "apple") (b . "beer"))) 'a #f) (dict-ref! (make-hasheq '((a . "apple") (b . "beer"))) 'c 'cabbage) (define h (make-hasheq '((a . "apple") (b . "beer")))) -(dict-ref h 'c) +(eval:error (dict-ref h 'c)) (dict-ref! h 'c (λ () 'cabbage)) (dict-ref h 'c) ]} @@ -486,7 +486,7 @@ Supported for any @racket[dict] that implements @racket[dict-ref] and @examples[ #:eval dict-eval (define h (make-hash)) -(dict-update! h 'a add1) +(eval:error (dict-update! h 'a add1)) (dict-update! h 'a add1 0) h (define v (vector #f #f #f)) @@ -512,7 +512,7 @@ Supported for any @racket[dict] that implements @racket[dict-ref] and @examples[ #:eval dict-eval -(dict-update #hash() 'a add1) +(eval:error (dict-update #hash() 'a add1)) (dict-update #hash() 'a add1 0) (dict-update #hash((a . "apple") (b . "beer")) 'b string-length) ]} diff --git a/pkgs/racket-doc/scribblings/reference/evts.scrbl b/pkgs/racket-doc/scribblings/reference/evts.scrbl index 0e810e41ef..02808a0265 100644 --- a/pkgs/racket-doc/scribblings/reference/evts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/evts.scrbl @@ -1,6 +1,5 @@ #lang scribble/doc @(require scribble/struct - scribble/eval "mz.rkt" (for-label racket/async-channel)) diff --git a/pkgs/racket-doc/scribblings/reference/exns.scrbl b/pkgs/racket-doc/scribblings/reference/exns.scrbl index 9b43d8b07e..316d506bc0 100644 --- a/pkgs/racket-doc/scribblings/reference/exns.scrbl +++ b/pkgs/racket-doc/scribblings/reference/exns.scrbl @@ -103,7 +103,7 @@ exception handler obtains control, and the handler itself is (+ 5 (raise (make-my-exception "failed" (current-continuation-marks))))) -(raise 'failed #t) +(eval:error (raise 'failed #t)) ]} @defproc*[([(error [sym symbol?]) any] @@ -145,9 +145,9 @@ In all cases, the constructed message string is passed to @racket[make-exn:fail], and the resulting exception is raised. @examples[ -(error 'failed) -(error "failed" 23 'pizza (list 1 2 3)) -(error 'method-a "failed because ~a" "no argument supplied") +(eval:error (error 'failed)) +(eval:error (error "failed" 23 'pizza (list 1 2 3))) +(eval:error (error 'method-a "failed because ~a" "no argument supplied")) ]} @@ -187,17 +187,17 @@ message names the bad argument and also lists the other arguments. If (if (not (integer? bits)) (raise-argument-error 'feed-machine "integer?" bits) "fed the machine")) -(feed-machine 'turkey) +(eval:error (feed-machine 'turkey)) (define (feed-cow animal) (if (not (eq? animal 'cow)) (raise-argument-error 'feed-cow "'cow" animal) "fed the cow")) -(feed-cow 'turkey) +(eval:error (feed-cow 'turkey)) (define (feed-animals cow sheep goose cat) (if (not (eq? goose 'goose)) (raise-argument-error 'feed-animals "'goose" 2 cow sheep goose cat) "fed the animals")) -(feed-animals 'cow 'sheep 'dog 'cat) +(eval:error (feed-animals 'cow 'sheep 'dog 'cat)) ]} @@ -224,10 +224,11 @@ using the error value conversion handler (see @racket[error-value->string-handler]). @examples[ + (eval:error (raise-arguments-error 'eat "fish is smaller than its given meal" "fish" 12 - "meal" 13) + "meal" 13)) ]} @@ -254,10 +255,10 @@ less than} the size of a collection---for example, @racket[(sub1 (vector-length _vec))], @racket[(sub1 (length _lst))], and so on. @examples[ -(raise-range-error 'vector-ref "vector" "starting " 5 #(1 2 3 4) 0 3) -(raise-range-error 'vector-ref "vector" "ending " 5 #(1 2 3 4) 0 3) -(raise-range-error 'vector-ref "vector" "" 3 #() 0 -1) -(raise-range-error 'vector-ref "vector" "ending " 1 #(1 2 3 4) 2 3 0) +(eval:error (raise-range-error 'vector-ref "vector" "starting " 5 #(1 2 3 4) 0 3)) +(eval:error (raise-range-error 'vector-ref "vector" "ending " 5 #(1 2 3 4) 0 3)) +(eval:error (raise-range-error 'vector-ref "vector" "" 3 #() 0 -1)) +(eval:error (raise-range-error 'vector-ref "vector" "ending " 1 #(1 2 3 4) 2 3 0)) ]} diff --git a/pkgs/racket-doc/scribblings/reference/extflonums.scrbl b/pkgs/racket-doc/scribblings/reference/extflonums.scrbl index f1b5004a03..4419129db3 100644 --- a/pkgs/racket-doc/scribblings/reference/extflonums.scrbl +++ b/pkgs/racket-doc/scribblings/reference/extflonums.scrbl @@ -109,14 +109,14 @@ Like @racket[flsin], @racket[flcos], @racket[fltan], @racket[flasin], @defproc[(->extfl [a exact-integer?]) extflonum?] @defproc[(extfl->exact-integer [a extflonum?]) exact-integer?] @defproc[(real->extfl [a real?]) extflonum?] -@defproc[(extfl->exact [a real?]) (and/c real? exact?)] -@defproc[(extfl->inexact [a real?]) flonum?] +@defproc[(extfl->exact [a extflonum?]) (and/c real? exact?)] +@defproc[(extfl->inexact [a extflonum?]) flonum?] )]{ The first four are like @racket[->fl], @racket[fl->exact], @racket[fl->real], @racket[inexact->exact], but for @tech{extflonums}. The @racket[extfl->inexact] function converts a @tech{extflonum} to -its closest @racket{flonum} approximation.} +its closest @tech{flonum} approximation.} @; ------------------------------------------------------------------------ diff --git a/pkgs/racket-doc/scribblings/reference/fasl.scrbl b/pkgs/racket-doc/scribblings/reference/fasl.scrbl index a440bd731b..84bd774431 100644 --- a/pkgs/racket-doc/scribblings/reference/fasl.scrbl +++ b/pkgs/racket-doc/scribblings/reference/fasl.scrbl @@ -2,7 +2,7 @@ @(require "mz.rkt" (for-label racket/fasl)) @(define fasl-eval (make-base-eval)) -@(interaction-eval #:eval fasl-eval (require racket/fasl)) +@examples[#:hidden #:eval fasl-eval (require racket/fasl)] @title[#:tag "fasl"]{Fast-Load Serialization} diff --git a/pkgs/racket-doc/scribblings/reference/file-ports.scrbl b/pkgs/racket-doc/scribblings/reference/file-ports.scrbl index 19c1df8ba4..969fea7a46 100644 --- a/pkgs/racket-doc/scribblings/reference/file-ports.scrbl +++ b/pkgs/racket-doc/scribblings/reference/file-ports.scrbl @@ -27,8 +27,8 @@ (delete-file i))))) (clean) (begin0 - (defexamples #:eval my-eval - expr ...) + (examples #:eval my-eval + expr ...) (clean)))])) "") diff --git a/pkgs/racket-doc/scribblings/reference/filesystem.scrbl b/pkgs/racket-doc/scribblings/reference/filesystem.scrbl index 06b107fa24..d5f0f5213a 100644 --- a/pkgs/racket-doc/scribblings/reference/filesystem.scrbl +++ b/pkgs/racket-doc/scribblings/reference/filesystem.scrbl @@ -7,7 +7,9 @@ setup/cross-system)) @(define file-eval (make-base-eval)) -@(interaction-eval #:eval file-eval (begin (require racket/file) (define filename (make-temporary-file)))) +@examples[#:hidden #:eval file-eval + (require racket/file) + (define filename (make-temporary-file))] @title{Filesystem} @@ -296,7 +298,7 @@ exists---to the path @racket[new]. If the file or directory is not renamed successfully, the @exnraise[exn:fail:filesystem]. This procedure can be used to move a file/directory to a different -directory (on the same disk) 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, @racket[new] cannot refer to an existing file or directory. Even if @racket[exists-ok?] is true, @racket[new] cannot refer to an existing @@ -639,13 +641,18 @@ In addition to the bindings described below, @tech{phase level} 1, since string constants are often used as compile-time expressions with @racket[define-runtime-path]. -@defform[(define-runtime-path id expr)]{ +@defform[(define-runtime-path id maybe-runtime?-id expr) + #:grammar ([maybe-runtime? code:blank + (code:line #:runtime?-id runtime?-id)])]{ Uses @racket[expr] as both a compile-time (i.e., @tech{phase} 1) expression and a run-time (i.e., @tech{phase} 0) expression. In either context, @racket[expr] should produce a path, a string that represents a path, a list of the form @racket[(list 'lib _str ...+)], or a list of the form @racket[(list 'so _str)] or @racket[(list 'so _str _vers)]. +If @racket[runtime?-id] is provided, then it is bound in the context +of @racket[expr] to @racket[#f] for the compile-time instance of +@racket[expr] and @racket[#t] for the run-time instance of @racket[expr]. For run time, @racket[id] is bound to a path that is based on the result of @racket[expr]. The path is normally computed by taking a @@ -779,23 +786,25 @@ Examples: [(windows) '(so "ssleay32")] [else '(so "libssl")])) (define libssl (ffi-lib libssl-so)) -]} +] + +@history[#:changed "6.4" @elem{Added @racket[#:runtime?-id].}]} -@defform[(define-runtime-paths (id ...) expr)]{ +@defform[(define-runtime-paths (id ...) maybe-runtime?-id expr)]{ Like @racket[define-runtime-path], but declares and binds multiple paths at once. The @racket[expr] should produce as many values as @racket[id]s.} -@defform[(define-runtime-path-list id expr)]{ +@defform[(define-runtime-path-list id maybe-runtime?-id expr)]{ Like @racket[define-runtime-path], but @racket[expr] should produce a list of paths.} -@defform[(define-runtime-module-path-index id module-path-expr)]{ +@defform[(define-runtime-module-path-index id maybe-runtime?-id module-path-expr)]{ Similar to @racket[define-runtime-path], but @racket[id] is bound to a @tech{module path index} that encapsulates the result of @@ -977,6 +986,7 @@ exists and is removed by another thread or process before @defproc[(find-files [predicate (path? . -> . any/c)] [start-path (or/c path-string? #f) #f] + [#:skip-filtered-directory? skip-filtered-directory? #f] [#:follow-links? follow-links? #f]) (listof path?)]{ @@ -997,6 +1007,10 @@ paths in the former case and relative paths in the latter. Another difference is that @racket[predicate] is not called for the current directory when @racket[start-path] is @racket[#f]. +If @racket[skip-filtered-directory?] is true, then when +@racket[predicate] returns @racket[#f] for a directory, the +directory's content is not traversed. + If @racket[follow-links?] is true, the @racket[find-files] traversal follows links, and links are not included in the result. If @racket[follow-links?] is @racket[#f], then links are not followed, @@ -1007,10 +1021,15 @@ directory, then @racket[predicate] will be called exactly once with @racket[start-path] as the argument. The @racket[find-files] procedure raises an exception if it encounters -a directory for which @racket[directory-list] fails.} +a directory for which @racket[directory-list] fails. + +@history[#:changed "6.3.0.11" @elem{Added the + @racket[#:skip-filtered-directory?] + argument.}]} @defproc[(pathlist-closure [path-list (listof path-string?)] - [#:follow-links? follow-links? #f]) + [#:path-filter path-filter (or/c #f (path? . -> . any/c)) #f] + [#:follow-links? follow-links? any/c #f]) (listof path?)]{ Given a list of paths, either absolute or relative to the current @@ -1023,17 +1042,25 @@ directory, returns a list such that twice);} @item{if a path refers to directory, all of its descendants are also - included in the result;} + included in the result, except as omitted by @racket[path-filter];} @item{ancestor directories appear before their descendants in the - result list.} + result list, as long as they are not misordered in the given + @racket[path-list].} ] +If @racket[path-filter] is a procedure, then it is applied to each +descendant of a directory. If @racket[path-filter] returns +@racket[#f], then the descendant (and any of its descendants, in the +case of a subdirectory) are omitted from the result. + If @racket[follow-links?] is true, then the traversal of directories and files follows links, and the link paths are not included in the -result. If @racket[follow-links?] is @racket[#f], then he result list -includes paths to link and the links are not followed.} +result. If @racket[follow-links?] is @racket[#f], then the result list +includes paths to link and the links are not followed. + +@history[#:changed "6.3.0.11" @elem{Added the @racket[#:path-filter] argument.}]} @defproc[(fold-files [proc (or/c (path? (or/c 'file 'dir 'link) any/c @@ -1428,7 +1455,7 @@ and bitwise operations such as @racket[bitwise-ior], and @racket[bitwise-and].} -@(interaction-eval #:eval file-eval (begin - (delete-file filename) - (delete-file (make-lock-file-name filename)))) +@examples[#:hidden #:eval file-eval + (delete-file filename) + (delete-file (make-lock-file-name filename))] @(close-eval file-eval) diff --git a/pkgs/racket-doc/scribblings/reference/fixnums.scrbl b/pkgs/racket-doc/scribblings/reference/fixnums.scrbl index 0028ce1332..9719bd3925 100644 --- a/pkgs/racket-doc/scribblings/reference/fixnums.scrbl +++ b/pkgs/racket-doc/scribblings/reference/fixnums.scrbl @@ -7,7 +7,7 @@ racket/require)) @(define flfx-eval (make-base-eval)) -@(interaction-eval #:eval flfx-eval (require racket/fixnum)) +@examples[#:hidden #:eval flfx-eval (require racket/fixnum)] @title[#:tag "fixnums"]{Fixnums} @@ -104,6 +104,10 @@ Two @tech{fxvectors} are @racket[equal?] if they have the same length, and if the values in corresponding slots of the @tech{fxvectors} are @racket[equal?]. +A printed @tech{fxvector} starts with @litchar{#fx(}, optionally with +a number between the @litchar{#fx} and +@litchar{(}. @see-read-print["vector" #:print "vectors"]{fxvectors} + @defproc[(fxvector? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] is a @tech{fxvector}, @racket[#f] otherwise.} diff --git a/pkgs/racket-doc/scribblings/reference/flonums.scrbl b/pkgs/racket-doc/scribblings/reference/flonums.scrbl index d4fc72b233..8bb56b69a2 100644 --- a/pkgs/racket-doc/scribblings/reference/flonums.scrbl +++ b/pkgs/racket-doc/scribblings/reference/flonums.scrbl @@ -2,7 +2,7 @@ @(require "mz.rkt" (for-label racket/flonum)) @(define fl-eval (make-base-eval)) -@(interaction-eval #:eval fl-eval (require racket/flonum)) +@examples[#:hidden #:eval fl-eval (require racket/flonum)] @title[#:tag "flonums"]{Flonums} @@ -163,6 +163,10 @@ Two @tech{flvectors} are @racket[equal?] if they have the same length, and if the values in corresponding slots of the @tech{flvectors} are @racket[equal?]. +A printed @tech{flvector} starts with @litchar{#fl(}, optionally with +a number between the @litchar{#fl} and +@litchar{(}. @see-read-print["vector" #:print "vectors"]{flvectors} + @defproc[(flvector? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] is a @tech{flvector}, @racket[#f] otherwise.} diff --git a/pkgs/racket-doc/scribblings/reference/for.scrbl b/pkgs/racket-doc/scribblings/reference/for.scrbl index eaff5d42f8..7f2d862d7b 100644 --- a/pkgs/racket-doc/scribblings/reference/for.scrbl +++ b/pkgs/racket-doc/scribblings/reference/for.scrbl @@ -379,10 +379,11 @@ source for all syntax errors. @code:comment{If we misuse for/digits, we can get good error reporting} @code:comment{because the use of orig-datum allows for source correlation:} -(for/digits - [a (in-list '(1 2 3))] - [b (in-list '(4 5 6))] - (+ a b)) +(eval:error + (for/digits + [a (in-list '(1 2 3))] + [b (in-list '(4 5 6))] + (+ a b))) (for/digits ([a (in-list '(1 2 3))] @@ -426,10 +427,11 @@ Like @racket[for*/fold], but the extra @racket[orig-datum] is used as the source (values (+ n (* d k)) (* k 10)))]) n))])) -(for*/digits - [ds (in-list '((8 3) (1 1)))] - [d (in-list ds)] - d) +(eval:error + (for*/digits + [ds (in-list '((8 3) (1 1)))] + [d (in-list ds)] + d)) (for*/digits ([ds (in-list '((8 3) (1 1)))] diff --git a/pkgs/racket-doc/scribblings/reference/format.scrbl b/pkgs/racket-doc/scribblings/reference/format.scrbl index 7a240c8307..4a5bccf01d 100644 --- a/pkgs/racket-doc/scribblings/reference/format.scrbl +++ b/pkgs/racket-doc/scribblings/reference/format.scrbl @@ -1,7 +1,6 @@ #lang scribble/doc @(require scribble/manual scribble/struct - scribble/eval "mz.rkt" (for-label racket/contract racket/math @@ -40,7 +39,7 @@ with @racket[separator] between consecutive items, and then pads or truncates the string to be at least @racket[min-width] characters and at most @racket[max-width] characters. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~a "north") (~a 'south) (~a #"east") @@ -70,7 +69,7 @@ truncated and the end of the string is replaced with @racket[limit-marker]. If @racket[limit-marker] is longer than @racket[max-width], an exception is raised. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~a "abcde" #:max-width 5) (~a "abcde" #:max-width 4) (~a "abcde" #:max-width 4 #:limit-marker "*") @@ -95,7 +94,7 @@ of @racket[right-pad-string] in its entirety. Thus left padding starts with the start of @racket[left-pad-string] and right padding ends with the end of @racket[right-pad-string]. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~a "apple" #:min-width 20 #:align 'left) (~a "pear" #:min-width 20 #:align 'left #:right-pad-string " .") (~a "plum" #:min-width 20 #:align 'right #:left-pad-string ". ") @@ -107,7 +106,7 @@ Use @racket[width] to set both @racket[max-width] and @racket[min-width] simultaneously, ensuring that the resulting string is exactly @racket[width] characters long: -@interaction[#:eval the-eval +@examples[#:label #f #:eval the-eval (~a "terse" #:width 6) (~a "loquacious" #:width 6) ] @@ -131,7 +130,7 @@ Like @racket[~a], but each value is converted like @racket[(format "~v" v)], the default separator is @racket[" "], and the default limit marker is @racket["..."]. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~v "north") (~v 'south) (~v #"east") @@ -141,7 +140,7 @@ marker is @racket["..."]. Use @racket[~v] to produce text that talks about Racket values. -@interaction[#:eval the-eval +@examples[#:eval the-eval (let ([nums (for/list ([i 10]) i)]) (~a "The even numbers in " (~v nums) " are " (~v (filter even? nums)) ".")) @@ -165,7 +164,7 @@ Like @racket[~a], but each value is converted like @racket[(format "~s" v)], the default separator is @racket[" "], and the default limit marker is @racket["..."]. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~s "north") (~s 'south) (~s #"east") @@ -192,7 +191,7 @@ Like @racket[~a], but each value is converted like @racket[(format "~e" v)], the default separator is @racket[" "], and the default limit marker is @racket["..."]. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~e "north") (~e 'south) (~e #"east") @@ -241,7 +240,7 @@ The optional arguments control number formatting: in positional or exponential notation. If @racket[notation] is a function, it is applied to @racket[x] to get the notation to be used. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~r 12345) (~r 12345 #:notation 'exponential) (let ([pick-notation @@ -266,7 +265,7 @@ point are dropped the decimal point is also dropped. If @racket[precision] is @racket[(list '= _digits)], then exactly @racket[_digits] digits after the decimal point are used, and the decimal point is never dropped. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~r pi) (~r pi #:precision 4) (~r pi #:precision 0) @@ -282,7 +281,7 @@ with fewer than @racket[min-width] digits (including the decimal point but not including the sign indicator), the digits are left-padded using @racket[pad-string]. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~r 17) (~r 17 #:min-width 4) (~r -42 #:min-width 4) @@ -298,7 +297,7 @@ number to at least @racket[min-width] characters (not including the sign indicator). The padding is placed between the sign and the normal digits of @racket[x]. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~r 17 #:min-width 4 #:pad-string "0") (~r -42 #:min-width 4 #:pad-string "0") ]} @@ -311,7 +310,7 @@ indicated: generated if @racket[x] is either positive or zero, and a minus sign is prefixed if @racket[x] is negative. - @interaction[#:eval the-eval + @examples[#:eval the-eval (for/list ([x '(17 0 -42)]) (~r x)) ]} @@ -319,14 +318,14 @@ indicated: @racket[x] is zero, a plus sign is prefixed if @racket[x] is positive, and a minus sign is prefixed if @racket[x] is negative. - @interaction[#:eval the-eval + @examples[#:eval the-eval (for/list ([x '(17 0 -42)]) (~r x #:sign '+)) ]} @item{If @racket[sign] is @racket['++], a plus sign is prefixed if @racket[x] is zero or positive, and a minus sign is prefixed if @racket[x] is negative. - @interaction[#:eval the-eval + @examples[#:eval the-eval (for/list ([x '(17 0 -42)]) (~r x #:sign '++)) ]} @@ -334,7 +333,7 @@ indicated: @racket[x] is zero or positive, and the number is enclosed in parentheses if @racket[x] is negative. - @interaction[#:eval the-eval + @examples[#:eval the-eval (for/list ([x '(17 0 -42)]) (~r x #:sign 'parens)) ]} @@ -344,7 +343,7 @@ indicated: either a string to be used as a prefix or a list containing two strings: a prefix and a suffix. - @interaction[#:eval the-eval + @examples[#:eval the-eval (let ([sign-table '(("" " up") "an even " ("" " down"))]) (for/list ([x '(17 0 -42)]) (~r x #:sign sign-table))) ] @@ -359,7 +358,7 @@ indicated: used. If @racket[base] is @racket[(list 'up _base*)] and @racket[_base*] is greater than @racket[10], then upper-case letters are used. -@interaction[#:eval the-eval +@examples[#:eval the-eval (~r 100 #:base 7) (~r 4.5 #:base 2) (~r 3735928559 #:base 16) @@ -374,7 +373,7 @@ explicit sign (as with a @racket[sign] of @racket['++]) and at least two digits, separated from the significand by the ``exponent marker'' @racket[format-exponent]: -@interaction[#:eval the-eval +@examples[#:label #f #:eval the-eval (~r 1234 #:notation 'exponential #:format-exponent "E") ] @@ -382,7 +381,7 @@ If @racket[format-exponent] is @racket[#f], the ``exponent marker'' is @racket["e"] if @racket[base] is @racket[10] and a string involving @racket[base] otherwise: -@interaction[#:eval the-eval +@examples[#:label #f #:eval the-eval (~r 1234 #:notation 'exponential) (~r 1234 #:notation 'exponential #:base 8) ] @@ -390,7 +389,7 @@ If @racket[format-exponent] is @racket[#f], the ``exponent marker'' is If @racket[format-exponent] is a procedure, it is applied to the exponent and the resulting string is appended to the significand: -@interaction[#:eval the-eval +@examples[#:label #f #:eval the-eval (~r 1234 #:notation 'exponential #:format-exponent (lambda (e) (format "E~a" e))) ]} diff --git a/pkgs/racket-doc/scribblings/reference/futures.scrbl b/pkgs/racket-doc/scribblings/reference/futures.scrbl index aed4951c54..caa0113072 100644 --- a/pkgs/racket-doc/scribblings/reference/futures.scrbl +++ b/pkgs/racket-doc/scribblings/reference/futures.scrbl @@ -2,7 +2,7 @@ @(require "mz.rkt" (for-label racket/future)) @(define future-eval (make-base-eval)) -@(interaction-eval #:eval future-eval (require racket/future)) +@examples[#:hidden #:eval future-eval (require racket/future)] @(define time-id @racketidfont{time}) @@ -67,7 +67,7 @@ execute through a call to @racket[touch], however. future, the given @racket[thunk] may run speculatively in parallel to other computations, as described above. - @interaction[ + @examples[ #:eval future-eval (let ([f (future (lambda () (+ 1 2)))]) (list (+ 3 4) (touch f))) diff --git a/pkgs/racket-doc/scribblings/reference/generic.scrbl b/pkgs/racket-doc/scribblings/reference/generic.scrbl index 7f0136aa66..2195bc4b25 100644 --- a/pkgs/racket-doc/scribblings/reference/generic.scrbl +++ b/pkgs/racket-doc/scribblings/reference/generic.scrbl @@ -132,7 +132,7 @@ method} called @racket[name] that does not support the @techlink{generic instance} @racket[v]. @examples[#:eval evaluator -(raise-support-error 'some-method-name '("arbitrary" "instance" "value")) +(eval:error (raise-support-error 'some-method-name '("arbitrary" "instance" "value"))) ] } @@ -233,7 +233,7 @@ syntax error.} make-num) (define z (make-num-contracted 10)) -(gen-print* z #:width "not a number" #:height 5) +(eval:error (gen-print* z #:width "not a number" #:height 5)) ] @defform[(generic-instance/c gen-id [method-id method-ctc] ...) diff --git a/pkgs/racket-doc/scribblings/reference/hashes.scrbl b/pkgs/racket-doc/scribblings/reference/hashes.scrbl index 227199413c..3a9809f319 100644 --- a/pkgs/racket-doc/scribblings/reference/hashes.scrbl +++ b/pkgs/racket-doc/scribblings/reference/hashes.scrbl @@ -546,7 +546,7 @@ key @racket[k] and value @racket[v], if a mapping from @racket[k] to some value @racket[v0] already exists, it is replaced with a mapping from @racket[k] to @racket[(combine/key k v0 v)]. -@defexamples[ +@examples[ #:eval the-eval (hash-union (make-immutable-hash '([1 . one])) (make-immutable-hash '([2 . two])) @@ -574,7 +574,7 @@ key @racket[k] and value @racket[v], if a mapping from @racket[k] to some value @racket[v0] already exists, it is replaced with a mapping from @racket[k] to @racket[(combine/key k v0 v)]. -@defexamples[ +@examples[ #:eval the-eval (define h (make-hash)) h diff --git a/pkgs/racket-doc/scribblings/reference/logging.scrbl b/pkgs/racket-doc/scribblings/reference/logging.scrbl index 170dff5826..1353136daa 100644 --- a/pkgs/racket-doc/scribblings/reference/logging.scrbl +++ b/pkgs/racket-doc/scribblings/reference/logging.scrbl @@ -324,8 +324,8 @@ argument list takes precedence.} @note-lib[racket/logging] @(require (for-label racket/logging)) @(define log-eval (make-base-eval)) -@(interaction-eval #:eval log-eval - (require racket/logging)) +@examples[#:hidden #:eval log-eval + (require racket/logging)] @defproc[(log-level/c [v any/c]) boolean?]{ @@ -353,7 +353,7 @@ Runs @racket[proc], calling @racket[interceptor] on any log event that would be received by @racket[(make-log-receiver (current-logger) level topic ... ...)]. Returns whatever @racket[proc] returns. -@defexamples[ +@examples[ #:eval log-eval (let ([warning-counter 0]) (with-intercepted-logging @@ -381,7 +381,7 @@ Runs @racket[proc], outputting any logging that would be received by @racket[(make-log-receiver (current-logger) level topic ... ...)] to @racket[port]. Returns whatever @racket[proc] returns. -@defexamples[ +@examples[ #:eval log-eval (let ([my-log (open-output-string)]) (with-logging-to-port my-log diff --git a/pkgs/racket-doc/scribblings/reference/match.scrbl b/pkgs/racket-doc/scribblings/reference/match.scrbl index 73e64e23be..05f59838d5 100644 --- a/pkgs/racket-doc/scribblings/reference/match.scrbl +++ b/pkgs/racket-doc/scribblings/reference/match.scrbl @@ -2,8 +2,8 @@ @(require "mz.rkt" "match-grammar.rkt" racket/match) @(define match-eval (make-base-eval)) -@(interaction-eval #:eval match-eval (require racket/match racket/list)) -@(interaction-eval #:eval match-eval (require (for-syntax racket/base))) +@examples[#:hidden #:eval match-eval (require racket/match racket/list)] +@examples[#:hidden #:eval match-eval (require (for-syntax racket/base))] @title[#:tag "match"]{Pattern Matching} @@ -239,9 +239,9 @@ In more detail, patterns match as follows: @racket[struct] declaration can provide the structure type information. - @defexamples[ + @examples[ #:eval match-eval - (define-struct tree (val left right)) + (eval:no-prompt (define-struct tree (val left right))) (match (make-tree 0 (make-tree 1 #f #f) #f) [(tree a (tree b _ _) _) (list a b)]) ]} @@ -430,27 +430,30 @@ many values to expect from @racket[expr]. The arguments are ordered as they appear in the function header for matching purposes. - @defexamples[#:eval match-eval - (define/match (fact n) - [(0) 1] - [(n) (* n (fact (sub1 n)))]) + @examples[#:eval match-eval + (eval:no-prompt + (define/match (fact n) + [(0) 1] + [(n) (* n (fact (sub1 n)))])) (fact 5) ] The function header may also contain optional or keyword arguments, may have curried arguments, and may also contain a rest argument. - @defexamples[#:eval match-eval - (define/match ((f x) #:y [y '(1 2 3)]) - [((regexp #rx"p+") `(,a 2 3)) a] - [(_ _) #f]) + @examples[#:eval match-eval + (eval:no-prompt + (define/match ((f x) #:y [y '(1 2 3)]) + [((regexp #rx"p+") `(,a 2 3)) a] + [(_ _) #f])) ((f "ape") #:y '(5 2 3)) ((f "dog")) - (define/match (g x y . rst) - [(0 0 '()) #t] - [(5 5 '(5 5)) #t] - [(_ _ _) #f]) + (eval:no-prompt + (define/match (g x y . rst) + [(0 0 '()) #t] + [(5 5 '(5 5)) #t] + [(_ _ _) #f])) (g 0 0) (g 5 5 5 5) (g 1 2) @@ -586,9 +589,10 @@ are used as binding identifiers (like any other identifier) when they appear anywhere except the first position in a sequence. For example, to extend the pattern matcher and destructure syntax lists, -@defs+int[ +@examples[#:label #f #:eval match-eval - ((define (syntax-list? x) + (eval:no-prompt + (define (syntax-list? x) (and (syntax? x) (list? (syntax->list x)))) (define-match-expander syntax-list @@ -602,8 +606,7 @@ For example, to extend the pattern matcher and destructure syntax lists, (and (identifier? stx) (free-identifier=? stx keyword)))) (define or-keyword? (make-keyword-predicate #'or)) - (define and-keyword? (make-keyword-predicate #'and)) - ) + (define and-keyword? (make-keyword-predicate #'and))) (match #'(or 3 4) [(syntax-list (? or-keyword?) b c) @@ -622,9 +625,10 @@ And here is an example showing how @racket[define-match-expander]-bound identifiers are not treated specially unless they appear in the first position of pattern sequence. -@defs+int[ +@examples[#:label #f #:eval match-eval - ((define-match-expander nil + (eval:no-prompt + (define-match-expander nil (λ (stx) #''()) (λ (stx) #''())) (define (len l) @@ -728,9 +732,10 @@ not provided, it defaults to @racket[equal?]. Any field of @racket[struct-id] may be omitted, and such fields can occur in any order. - @defexamples[ + @examples[ #:eval match-eval - (define-struct tree (val left right)) + (eval:no-prompt + (define-struct tree (val left right))) (match (make-tree 0 (make-tree 1 #f #f) #f) [(struct* tree ([val a] [left (struct* tree ([right #f] [val b]))])) diff --git a/pkgs/racket-doc/scribblings/reference/memory.scrbl b/pkgs/racket-doc/scribblings/reference/memory.scrbl index 740124e485..4f5f76ef16 100644 --- a/pkgs/racket-doc/scribblings/reference/memory.scrbl +++ b/pkgs/racket-doc/scribblings/reference/memory.scrbl @@ -199,7 +199,12 @@ execution. Otherwise, @racket[#f] is returned.} @section[#:tag "garbagecollection"]{Garbage Collection} Set the @as-index{@envvar{PLTDISABLEGC}} environment variable (to any -value) before Racket starts to disable @tech{garbage collection}. +value) before Racket starts to disable @tech{garbage collection}. Set +the @as-index{@envvar{PLT_INCREMENTAL_GC}} environment variable +to a value that starts with @litchar{1}, @litchar{y}, or @litchar{Y} to +request incremental mode at all times, but calling +@racket[(collect-garbage 'incremental)] in a program with a periodic +task is generally a better mechanism for requesting incremental mode. In Racket 3m (the main variant of Racket), each garbage collection logs a message (see @secref["logging"]) at the @racket['debug] level with topic @racket['GC]. @@ -209,18 +214,28 @@ versions of Racket may use a @racket[gc-info] @tech{prefab} structure with additional fields: @racketblock[ -(struct gc-info (major? pre-amount pre-admin-amount code-amount - post-amount post-admin-amount - start-process-time end-process-time - start-time end-time) +(struct gc-info (mode pre-amount pre-admin-amount code-amount + post-amount post-admin-amount + start-process-time end-process-time + start-time end-time) #:prefab) ] @itemlist[ - @item{The @racket[major?] field indicates whether the collection was - a ``major'' collection that inspects all memory or a ``minor'' - collection that mostly inspects just recent allocations.} + @item{The @racket[mode] field is a symbol @racket['major], + @racket['minor], or @racket['incremental]; @racket['major] + indicates a collection that inspects all memory, + @racket['minor] indicates collection that mostly inspects just + recent allocations, and @racket['incremental] indicates a minor + collection that performs extra work toward the next major + collection. + + @history[#:changed "6.3.0.7" @elem{Changed first field from a + boolean (@racket[#t] for + @racket['major], @racket[#f] + for @racket['minor]) to a + mode symbol.}]} @item{The @racket[pre-amount] field reports place-local memory use (i.e., not counting the memory use of child places) in bytes at @@ -286,6 +301,8 @@ collection mode, the text has the format @elem{Processor time since startup of garbage collection's start})) ]} +@history[#:changed "6.3.0.7" @elem{Added @envvar{PLT_INCREMENTAL_GC}.}] + @defproc[(collect-garbage [request (or/c 'major 'minor 'incremental) 'major]) void?]{ @@ -314,13 +331,18 @@ garbage-collection mode, depending on @racket[request]: major collections any sooner than they would occur otherwise.} @item{@racket['incremental] --- Requests that each minor - collection performs incremental work toward a major collection. + collection performs incremental work toward a major collection + (but does not request an immediate minor collection). This incremental-mode request expires at the next major collection. The intent of incremental mode is to significantly reduce pause times due to major collections, but incremental mode typically - implies longer minor-collection times and higher memory use.} + implies longer minor-collection times and higher memory use. + + If the @envvar{PLT_INCREMENTAL_GC} environment variable's value + starts with @litchar{0}, @litchar{n}, or @litchar{N} on + start-up, then incremental-mode requests are ignored.} ] diff --git a/pkgs/racket-doc/scribblings/reference/mz.rkt b/pkgs/racket-doc/scribblings/reference/mz.rkt index 6d58dea556..28f95342b9 100644 --- a/pkgs/racket-doc/scribblings/reference/mz.rkt +++ b/pkgs/racket-doc/scribblings/reference/mz.rkt @@ -2,13 +2,13 @@ (require scribble/struct scribble/manual - scribble/eval + scribble/examples scribble/decode racket/contract "../icons.rkt") (provide (all-from-out scribble/manual) - (all-from-out scribble/eval) + (all-from-out scribble/examples) (all-from-out racket/contract)) (require (for-label racket)) diff --git a/pkgs/racket-doc/scribblings/reference/numbers.scrbl b/pkgs/racket-doc/scribblings/reference/numbers.scrbl index 30647d85da..664c1c3fdd 100644 --- a/pkgs/racket-doc/scribblings/reference/numbers.scrbl +++ b/pkgs/racket-doc/scribblings/reference/numbers.scrbl @@ -8,7 +8,7 @@ racket/random)) @(define math-eval (make-base-eval)) -@(interaction-eval #:eval math-eval (require racket/math)) +@examples[#:hidden #:eval math-eval (require racket/math)] @title[#:tag "numbers" #:style '(toc)]{Numbers} @@ -193,12 +193,12 @@ number, @racket[#f] otherwise.} @defproc[(even? [n integer?]) boolean?]{ Returns @racket[(zero? (modulo n 2))]. -@mz-examples[(even? 10.0) (even? 11) (even? +inf.0)]} +@mz-examples[(even? 10.0) (even? 11) (eval:error (even? +inf.0))]} @defproc[(odd? [n integer?]) boolean?]{ Returns @racket[(not (even? n))]. -@mz-examples[(odd? 10.0) (odd? 11) (odd? +inf.0)]} +@mz-examples[(odd? 10.0) (odd? 11) (eval:error (odd? +inf.0))]} @defproc[(exact? [z number?]) boolean?]{ Returns @racket[#t] if @racket[z] @@ -289,7 +289,7 @@ If @racket[z] is exact @racket[0] and no @racket[w] is exact Returns @racket[(truncate (/ n m))]. -@mz-examples[(quotient 10 3) (quotient -10.0 3) (quotient +inf.0 3)]} +@mz-examples[(quotient 10 3) (quotient -10.0 3) (eval:error (quotient +inf.0 3))]} @defproc[(remainder [n integer?] [m integer?]) integer?]{ @@ -307,7 +307,7 @@ Returns @racket[_q] with the same sign as @racket[n] such that If @racket[m] is exact @racket[0], the @exnraise[exn:fail:contract:divide-by-zero]. -@mz-examples[(remainder 10 3) (remainder -10.0 3) (remainder 10.0 -3) (remainder -10 -3) (remainder +inf.0 3)]} +@mz-examples[(remainder 10 3) (remainder -10.0 3) (remainder 10.0 -3) (remainder -10 -3) (eval:error (remainder +inf.0 3))]} @defproc[(quotient/remainder [n integer?] [m integer?]) (values integer? integer?)]{ @@ -336,7 +336,7 @@ Returns @racket[_q] with the same sign as @racket[m] where If @racket[m] is exact @racket[0], the @exnraise[exn:fail:contract:divide-by-zero]. -@mz-examples[(modulo 10 3) (modulo -10.0 3) (modulo 10.0 -3) (modulo -10 -3) (modulo +inf.0 3)]} +@mz-examples[(modulo 10 3) (modulo -10.0 3) (modulo 10.0 -3) (modulo -10 -3) (eval:error (modulo +inf.0 3))]} @defproc[(add1 [z number?]) number?]{ Returns @racket[(+ z 1)].} @@ -842,13 +842,22 @@ both in binary and as integers. [rand-gen pseudo-random-generator? (current-pseudo-random-generator)]) exact-nonnegative-integer?] + [(random [min (integer-in 1 4294967087)] + [max (integer-in 1 4294967087)] + [rand-gen pseudo-random-generator? + (current-pseudo-random-generator)]) + exact-nonnegative-integer?] [(random [rand-gen pseudo-random-generator? (current-pseudo-random-generator)]) (and/c real? inexact? (>/c 0) (list [r (input-port? . -> . any/c) read] [in input-port? (current-input-port)]) (listof any/c)]{ diff --git a/pkgs/racket-doc/scribblings/reference/printer.scrbl b/pkgs/racket-doc/scribblings/reference/printer.scrbl index 3c63fc7041..4d479715a4 100644 --- a/pkgs/racket-doc/scribblings/reference/printer.scrbl +++ b/pkgs/racket-doc/scribblings/reference/printer.scrbl @@ -288,7 +288,7 @@ all @tech{quotable}, then the vector @racket[print]s as and a closing @litchar{)}. A vector is @tech{quotable} when all of its elements are @tech{quotable}. -In @racket[write] or @racket[display] mode, an @tech{flvector} prints +In @racket[write] or @racket[display] mode, a @tech{flvector} prints like a @tech{vector}, but with a @litchar{#fl} prefix instead of @litchar{#}. A @tech{fxvector} similarly prints with a @litchar{#fx} prefix instead of @litchar{#}. The @racket[print-vector-length] diff --git a/pkgs/racket-doc/scribblings/reference/procedures.scrbl b/pkgs/racket-doc/scribblings/reference/procedures.scrbl index 87f5d93da1..8e784b4852 100644 --- a/pkgs/racket-doc/scribblings/reference/procedures.scrbl +++ b/pkgs/racket-doc/scribblings/reference/procedures.scrbl @@ -123,9 +123,10 @@ not require any other keywords, and it must accept as many by-position arguments as supplied via the @racket[v]s and @racket[lst]; otherwise, the @exnraise[exn:fail:contract]. -@defexamples[ -(define (f x #:y y #:z [z 10]) - (list x y z)) +@examples[ +(eval:no-prompt + (define (f x #:y y #:z [z 10]) + (list x y z))) (keyword-apply f '(#:y) '(2) '(1)) (keyword-apply f '(#:y #:z) '(2 3) '(1)) (keyword-apply f #:z 7 '(#:y) '(2) '(1)) @@ -207,7 +208,7 @@ arity-reduced procedure) or @racket[arity] must be the empty list @examples[ (define my+ (procedure-reduce-arity + 2)) (my+ 1 2) -(my+ 1 2 3) +(eval:error (my+ 1 2 3)) ]} @defproc[(procedure-keywords [proc procedure?]) @@ -256,19 +257,21 @@ The result of @racket[procedure-arity] and @racket[object-name] on the new procedure is the same as for @racket[plain-proc]. See also @racket[procedure-reduce-keyword-arity] and @racket[procedure-rename]. -@defexamples[ -(define show - (make-keyword-procedure (lambda (kws kw-args . rest) - (list kws kw-args rest)))) +@examples[ +(eval:no-prompt + (define show + (make-keyword-procedure (lambda (kws kw-args . rest) + (list kws kw-args rest))))) (show 1) (show #:init 0 1 2 3 #:extra 4) -(define show2 - (make-keyword-procedure (lambda (kws kw-args . rest) - (list kws kw-args rest)) - (lambda args - (list->vector args)))) +(eval:no-prompt + (define show2 + (make-keyword-procedure (lambda (kws kw-args . rest) + (list kws kw-args rest)) + (lambda args + (list->vector args))))) (show2 1) (show2 #:init 0 1 2 3 #:extra 4) ]} @@ -291,15 +294,16 @@ must require no more keywords than the ones listed in @racket[allowed-kws] (or it must allow all keywords if @racket[allowed-kws] is @racket[#f]). -@defexamples[ -(define orig-show - (make-keyword-procedure (lambda (kws kw-args . rest) - (list kws kw-args rest)))) -(define show (procedure-reduce-keyword-arity - orig-show 3 '(#:init) '(#:extra #:init))) +@examples[ +(eval:no-prompt + (define orig-show + (make-keyword-procedure (lambda (kws kw-args . rest) + (list kws kw-args rest)))) + (define show (procedure-reduce-keyword-arity + orig-show 3 '(#:init) '(#:extra #:init)))) (show #:init 0 1 2 3 #:extra 4) -(show 1) -(show #:init 0 1 2 3 #:extra 4 #:more 7) +(eval:error (show 1)) +(eval:error (show #:init 0 1 2 3 #:extra 4 #:more 7)) ]} @defstruct[arity-at-least ([value exact-nonnegative-integer?])]{ @@ -452,7 +456,7 @@ property is not associated with a procedure structure type. (apply pairs more))]))) (pairs 1 2 3 4) -(pairs 5)]} +(eval:error (pairs 5))]} @defthing[prop:checked-procedure struct-type-property?]{ @@ -483,6 +487,21 @@ field of @racket[v] applied to @racket[v1] and @racket[v2] produces and @racket[v2], and its result is returned by @racket[checked-procedure-check-and-extract].} + +@defproc[(procedure-specialize [proc procedure?]) + procedure?]{ + +Returns @racket[proc] or its equivalent, but provides a hint to the +run-time system that it should spend extra time and memory to +specialize the implementation of @racket[proc]. + +The hint is currently used when @racket[proc] is the value of a +@racket[lambda] or @racket[case-lambda] form that references variables +bound outside of the @racket[lambda] or @racket[case-lambda], and when +@racket[proc] has not been previously applied. + +@history[#:added "6.3.0.10"]} + @; ---------------------------------------------------------------------- @section{Reflecting on Primitives} @@ -517,7 +536,7 @@ applied.} @note-lib[racket/function] @(define fun-eval (make-base-eval)) -@(interaction-eval #:eval fun-eval (require racket/function)) +@examples[#:hidden #:eval fun-eval (require racket/function)] @defproc[(identity [v any/c]) any/c]{ Returns @racket[v]. @@ -540,13 +559,15 @@ The @racket[thunk] form creates a nullary function that evaluates the given body. The @racket[thunk*] form is similar, except that the resulting function accepts any arguments (including keyword arguments). -@defexamples[ +@examples[ #:eval fun-eval -(define th1 (thunk (define x 1) (printf "~a\n" x))) +(eval:no-prompt + (define th1 (thunk (define x 1) (printf "~a\n" x)))) (th1) -(th1 'x) -(th1 #:y 'z) -(define th2 (thunk* (define x 1) (printf "~a\n" x))) +(eval:error (th1 'x)) +(eval:error (th1 #:y 'z)) +(eval:no-prompt + (define th2 (thunk* (define x 1) (printf "~a\n" x)))) (th2) (th2 'x) (th2 #:y 'z) @@ -567,9 +588,10 @@ returns the @racket[not] of @racket[proc]'s result. Combines calls to each function with @racket[and]. Equivalent to @racket[(and (f x ...) ...)] -@defexamples[ +@examples[ #:eval fun-eval -(define f (conjoin exact? integer?)) +(eval:no-prompt + (define f (conjoin exact? integer?))) (f 1) (f 1.0) (f 1/2) @@ -583,9 +605,10 @@ Combines calls to each function with @racket[and]. Equivalent to Combines calls to each function with @racket[or]. Equivalent to @racket[(or (f x ...) ...)] -@defexamples[ +@examples[ #:eval fun-eval -(define f (disjoin exact? integer?)) +(eval:no-prompt + (define f (disjoin exact? integer?))) (f 1) (f 1.0) (f 1/2) @@ -708,7 +731,6 @@ and @racket[(equal? (normalize-arity a) (normalize-arity b))]. (arity=? 1 (list 1)) (arity=? 1 (arity-at-least 1)) (arity=? (arity-at-least 1) 1) -(arity=? 1 (arity-at-least 1)) (arity=? (arity-at-least 1) (list 1 (arity-at-least 2))) (arity=? (list 1 (arity-at-least 2)) (arity-at-least 1)) (arity=? (arity-at-least 1) (list 1 (arity-at-least 3))) @@ -732,7 +754,6 @@ arguments that procedures with arity @racket[b] accept. (arity-includes? 1 (list 1)) (arity-includes? 1 (arity-at-least 1)) (arity-includes? (arity-at-least 1) 1) -(arity-includes? 1 (arity-at-least 1)) (arity-includes? (arity-at-least 1) (list 1 (arity-at-least 2))) (arity-includes? (list 1 (arity-at-least 2)) (arity-at-least 1)) (arity-includes? (arity-at-least 1) (list 1 (arity-at-least 3))) diff --git a/pkgs/racket-doc/scribblings/reference/read.scrbl b/pkgs/racket-doc/scribblings/reference/read.scrbl index 635187e1aa..127ea8052e 100644 --- a/pkgs/racket-doc/scribblings/reference/read.scrbl +++ b/pkgs/racket-doc/scribblings/reference/read.scrbl @@ -156,8 +156,10 @@ interpretation of results is up to external tools, such as DrRacket (see If no information is available for a given key, the result should be the second argument. @mz-examples[ -((read-language (open-input-string "#lang algol60")) 'color-lexer #f) -((read-language (open-input-string "#lang algol60")) 'something-else #f) +(define scribble-manual-info + (read-language (open-input-string "#lang scribble/manual"))) +(scribble-manual-info 'color-lexer #f) +(scribble-manual-info 'something-else #f) ] The @racketidfont{get-info} function itself is applied to five @@ -217,6 +219,23 @@ A @tech{parameter} that controls whether @litchar["{"] and @litchar["}"] are treated as parentheses. See @secref["parse-pair"] for more information.} +@defboolparam[read-square-bracket-with-tag on?]{ + +A @tech{parameter} that controls whether @litchar{[} and @litchar{]} +are treated as parentheses, but the resulting list tagged with +@racket[#%brackets]. See @secref["parse-pair"] for more information. + +@history[#:added "6.3.0.5"]} + +@defboolparam[read-curly-brace-with-tag on?]{ + +A @tech{parameter} that controls whether @litchar["{"] and +@litchar["}"] are treated as parentheses, but the resulting list +tagged with @racket[#%braces]. See @secref["parse-pair"] for more +information. + +@history[#:added "6.3.0.5"]} + @defboolparam[read-accept-box on?]{ A @tech{parameter} that controls parsing @litchar{#&} input. See @@ -256,6 +275,14 @@ information.} A @tech{parameter} that controls parsing input with two dots to trigger infix conversion. See @secref["parse-pair"] for more information.} +@defboolparam[read-cdot on?]{ + +A @tech{parameter} that controls parsing input with a dot, in a C +structure accessor style. See @secref["parse-cdot"] for more +information. + +@history[#:added "6.3.0.5"]} + @defboolparam[read-accept-quasiquote on?]{ A @tech{parameter} that controls parsing input with @litchar{`} or diff --git a/pkgs/racket-doc/scribblings/reference/reader.scrbl b/pkgs/racket-doc/scribblings/reference/reader.scrbl index f01f408323..9da6e68301 100644 --- a/pkgs/racket-doc/scribblings/reference/reader.scrbl +++ b/pkgs/racket-doc/scribblings/reference/reader.scrbl @@ -388,13 +388,21 @@ elements are themselves in @racket[read-syntax] mode, so that the result is a list or pair of syntax objects that is itself wrapped as a syntax object. If the reader constructs nested pairs because the input included a single delimited @litchar{.}, then only the innermost pair -and outermost pair are wrapped as syntax objects. Whether wrapping a -pair or list, if the pair or list was formed with @litchar{[} and -@litchar{]}, then a @indexed-racket['paren-shape] property is attached -to the result with the value @racket[#\[]; if the list or pair was -formed with @litchar["{"] and @litchar["}"], then a -@racket['paren-shape] property is attached to the result with the -value @racket[#\{]. +and outermost pair are wrapped as syntax objects. + +Whether wrapping a pair or list, if the pair or list was formed with +@litchar{[} and @litchar{]}, then a @indexed-racket['paren-shape] +property is attached to the result with the value @racket[#\[]. If the +@racket[read-square-bracket-with-tag] @tech{parameter} is set to +@racket[#t], then the resulting pair or list is wrapped by the +equivalent of @racket[(cons '#%brackets _pair-or-list)]. + +Similarly, if the list or pair was formed with @litchar["{"] and +@litchar["}"], then a @racket['paren-shape] property is attached to +the result with the value @racket[#\{]. If the +@racket[read-curly-brace-with-tag] @tech{parameter} is set to +@racket[#t], then the resulting pair or list is wrapped by the +equivalent of @racket[(cons '#%braces _pair-or-list)]. If a delimited @litchar{.} appears in any other configuration, then the @exnraise[exn:fail:read]. Similarly, if the reader encounters a @@ -412,12 +420,14 @@ being parsed, then the @exnraise[exn:fail:read]. "(1 . 2 . 3)" ] -If the @racket[read-square-bracket-as-paren] @tech{parameter} is set to +If the @racket[read-square-bracket-as-paren] and +@racket[read-square-bracket-with-tag] @tech{parameter}s are set to @racket[#f], then when the reader encounters @litchar{[} and @litchar{]}, the @exnraise{exn:fail:read}. Similarly, if the -@racket[read-curly-brace-as-paren] @tech{parameter} is set to @racket[#f], -then when the reader encounters @litchar["{"] and @litchar["}"], the -@exnraise{exn:fail:read}. +@racket[read-curly-brace-as-paren] and +@racket[read-curly-brace-with-tag] @tech{parameter}s are set to +@racket[#f], then when the reader encounters @litchar["{"] and +@litchar["}"], the @exnraise{exn:fail:read}. If the @racket[read-accept-dot] @tech{parameter} is set to @racket[#f], then a delimited @litchar{.} triggers an @@ -631,7 +641,7 @@ The elements of the vector are recursively read until a matching lists (see @secref["parse-pair"]). A delimited @litchar{.} is not allowed among the vector elements. In the case of @tech{flvectors}, the recursive read for element is implicitly prefixed with @litchar{#i} -and must produce a @tech{flonum}. In the case of @tech{flvectors}, +and must produce a @tech{flonum}. In the case of @tech{fxvectors}, the recursive read for element is implicitly prefixed with @litchar{#e} and must produce a @tech{fixnum}. @@ -931,6 +941,30 @@ If the @racket[read-accept-reader] or @racket[read-accept-lang] @tech{parameter} is set to @racket[#f], then if the reader encounters @litchar{#lang} or equivalent @litchar{#!}, the @exnraise[exn:fail:read]. +@section[#:tag "parse-cdot"]{Reading with C-style infix dot notation} + +When the @racket[read-cdot] @tech{parameter} is set to @racket[#t], +then a variety of changes occur in the reader. + +First, symbols can no longer include the character @litchar{.}, unless +the entire symbol is quoted with @litchar{|}. + +Second, numbers can no longer include the character @litchar{.}, +unless the number is prefixed with @litchar{#e} or @litchar{#i}, or an +equivalent prefix as discussed in @secref["parse-number"]. If these +numbers are followed by a @litchar{.} intended to be read as a C-style +infix dot, then there must be separating whitespace. + +Finally, after reading any value, @racket[_x], the reader will seek +over whitespace until it reaches a non-whitespace character. If the +character is not @litchar{.}, then the value, @racket[_x], is returned +as usual. If the character is @litchar{.}, then another value, +@racket[_y], is read and the result @racket[(list '#%dot _x _y)] is +returned. In @racket[read-syntax] mode, the @racket['#%dot] symbol has +the source location information of the @litchar{.} character and the +entire list has the source location information spanning from the +start of @racket[_x] to the end of @racket[_y]. + @subsection{S-Expression Reader Language} @defmodulelang[s-exp] diff --git a/pkgs/racket-doc/scribblings/reference/readtables.scrbl b/pkgs/racket-doc/scribblings/reference/readtables.scrbl index 9c7ba4ee26..2f32fc32ae 100644 --- a/pkgs/racket-doc/scribblings/reference/readtables.scrbl +++ b/pkgs/racket-doc/scribblings/reference/readtables.scrbl @@ -67,7 +67,7 @@ otherwise. } -@defproc[(make-readtable [readtable readtable?] +@defproc[(make-readtable [readtable (or/c readtable? #f)] [key (or/c char? #f)] [mode (or/c (or/c 'terminating-macro 'non-terminating-macro diff --git a/pkgs/racket-doc/scribblings/reference/reference.scrbl b/pkgs/racket-doc/scribblings/reference/reference.scrbl index ba9103632d..29a7af9425 100644 --- a/pkgs/racket-doc/scribblings/reference/reference.scrbl +++ b/pkgs/racket-doc/scribblings/reference/reference.scrbl @@ -32,7 +32,7 @@ friendlier (though less precise and less complete) overview of the language. @margin-note{The source of this manual is available on -@hyperlink["https://github.com/plt/racket/tree/master/pkgs/racket-doc/scribblings/reference"]{GitHub}.} +@hyperlink["https://github.com/racket/racket/tree/master/pkgs/racket-doc/scribblings/reference"]{GitHub}.} @defmodulelang*[(racket/base racket) ;; Use sources for overlap with `scheme' and `mzscheme': diff --git a/pkgs/racket-doc/scribblings/reference/regexps.scrbl b/pkgs/racket-doc/scribblings/reference/regexps.scrbl index 5a218ddc1f..9472e06c95 100644 --- a/pkgs/racket-doc/scribblings/reference/regexps.scrbl +++ b/pkgs/racket-doc/scribblings/reference/regexps.scrbl @@ -240,7 +240,7 @@ returns the source byte string for a @tech{regexp value}. @examples[ (byte-regexp #"ap*le") (object-name #rx#"ap*le") -(byte-regexp "ap*le") +(eval:error (byte-regexp "ap*le")) ]} @defproc[(byte-pregexp [bstr bytes?]) byte-pregexp?]{ diff --git a/pkgs/racket-doc/scribblings/reference/sandbox.scrbl b/pkgs/racket-doc/scribblings/reference/sandbox.scrbl index 45d8b6a43b..03a5655594 100644 --- a/pkgs/racket-doc/scribblings/reference/sandbox.scrbl +++ b/pkgs/racket-doc/scribblings/reference/sandbox.scrbl @@ -6,7 +6,7 @@ racket/gui/dynamic)) @(define box-eval (make-base-eval)) -@(interaction-eval #:eval box-eval (require racket/sandbox)) +@examples[#:hidden #:eval box-eval (require racket/sandbox)] @title{Sandboxed Evaluation} @@ -147,11 +147,12 @@ The following examples illustrate the difference between an evaluator that puts the program in a module and one that merely initializes a top-level namespace: -@interaction[ +@examples[#:label #f #:eval box-eval -(define base-module-eval - (code:comment @#,t{a module cannot have free variables...}) - (make-evaluator 'racket/base '(define (f) later))) +(eval:error + (define base-module-eval + (code:comment @#,t{a module cannot have free variables...}) + (make-evaluator 'racket/base '(define (f) later)))) (define base-module-eval (make-evaluator 'racket/base '(define (f) later) '(define later 5))) @@ -229,9 +230,10 @@ of communication makes it impossible to have nested (or concurrent) calls to a single evaluator. Usually this is not a problem, but in some cases you can get the evaluator function available inside the sandboxed code, for example: -@interaction[#:eval box-eval -(let ([e (make-evaluator 'racket/base)]) - (e `(,e 1))) +@examples[#:label #f #:eval box-eval +(eval:error + (let ([e (make-evaluator 'racket/base)]) + (e `(,e 1)))) ] An error will be signaled in such cases. diff --git a/pkgs/racket-doc/scribblings/reference/sequences.scrbl b/pkgs/racket-doc/scribblings/reference/sequences.scrbl index d82c0bb81d..4891e55e13 100644 --- a/pkgs/racket-doc/scribblings/reference/sequences.scrbl +++ b/pkgs/racket-doc/scribblings/reference/sequences.scrbl @@ -26,7 +26,7 @@ vice-versa. @(define sequence-evaluator (let ([evaluator (make-base-eval)]) (evaluator '(require racket/generic racket/list racket/stream racket/sequence - racket/contract)) + racket/contract racket/dict)) evaluator)) @guideintro["sequences"]{sequences} @@ -152,7 +152,7 @@ each element in the sequence. Returns @racket[#t] if @racket[v] can be used as a @tech{sequence}, @racket[#f] otherwise. -@interaction[#:eval sequence-evaluator +@examples[#:eval sequence-evaluator (sequence? 42) (sequence? '(a b c)) (sequence? "word") @@ -169,12 +169,12 @@ each element in the sequence. @racket[step] is non-negative, or less or equal to @racket[end] if @racket[step] is negative. @speed[in-range "number"] - Example: gaussian sum - @interaction[#:eval sequence-evaluator + + @examples[#:label "Example: gaussian sum" #:eval sequence-evaluator (for/sum ([x (in-range 10)]) x)] - Example: sum of even numbers - @interaction[#:eval sequence-evaluator + + @examples[#:label "Example: sum of even numbers" #:eval sequence-evaluator (for/sum ([x (in-range 0 100 2)]) x)] } @@ -184,7 +184,7 @@ each element in the sequence. integers starting with @racket[start], where each element is one more than the preceding element. @speed[in-naturals "integer"] - @interaction[#:eval sequence-evaluator + @examples[#:eval sequence-evaluator (for/list ([k (in-naturals)] [x (in-range 10)]) (list k x))] @@ -197,7 +197,7 @@ each element in the sequence. @info-on-seq["pairs" "lists"] @speed[in-list "list"] - @interaction[#:eval sequence-evaluator + @examples[#:eval sequence-evaluator (for/list ([x (in-list '(3 1 4))]) `(,x ,(* x x)))] } @@ -207,7 +207,7 @@ each element in the sequence. @info-on-seq["mpairs" "mutable lists"] @speed[in-mlist "mutable list"] - @interaction[#:eval sequence-evaluator + @examples[#:eval sequence-evaluator (for/list ([x (in-mlist (mcons "RACKET" (mcons "LANG" '())))]) (string-length x))] } @@ -242,7 +242,7 @@ each element in the sequence. @speed[in-vector "vector"] - @interaction[#:eval sequence-evaluator + @examples[#:eval sequence-evaluator (define (histogram vector-of-words) (define a-hash (make-hash)) (for ([word (in-vector vector-of-words)]) @@ -266,7 +266,7 @@ each element in the sequence. @speed[in-string "string"] - @interaction[#:eval sequence-evaluator + @examples[#:eval sequence-evaluator (define (line-count str) (for/sum ([ch (in-string str)]) (if (char=? #\newline ch) 1 0))) @@ -288,7 +288,7 @@ each element in the sequence. @speed[in-bytes "byte string"] - @interaction[#:eval sequence-evaluator + @examples[#:eval sequence-evaluator (define (has-eof? bs) (for/or ([ch (in-bytes bs)]) (= ch 0))) @@ -384,6 +384,48 @@ each element in the sequence. content of a directory, use the result of @racket[directory-list] as a sequence. +@examples[ + (code:comment @#,t{Given a directory tree:}) + (code:comment @#,t{}) + (code:comment @#,t{ /example}) + (code:comment @#,t{ ├── a}) + (code:comment @#,t{ │ ├── alpha}) + (code:comment @#,t{ │ └── apple}) + (code:comment @#,t{ ├── b}) + (code:comment @#,t{ │ └── beta}) + (code:comment @#,t{ └── c}) + (code:comment @#,t{}) + (eval:alts + (parameterize ([current-directory "/example"]) + (for ([p (in-directory)]) + (printf "~a\n" p))) + (for ([p (in-list '("a" + "a/alpha" + "a/apple" + "b" + "b/beta" + "c"))]) + (printf "~a\n" p))) + (eval:alts + (for ([p (in-directory "/example")]) + (printf "~a\n" p)) + (for ([p (in-list '("/example/a" + "/example/a/alpha" + "/example/a/apple" + "/example/b" + "/example/b/beta" + "/example/c"))]) + (printf "~a\n" p))) + (eval:alts + (let ([f (lambda (path) (regexp-match? #rx"/example/b.*" path))]) + (for ([p (in-directory "/example" f)]) + (printf "~a\n" p))) + (for ([p (in-list '("/example/a" + "/example/b" + "/example/b/beta" + "/example/c"))]) + (printf "~a\n" p)))] + @history[#:changed "6.0.0.1" @elem{Added @racket[use-dir?] argument.}]} @@ -755,27 +797,30 @@ for instance, a wrapped list is not guaranteed to satisfy @racket[list?]. If @racket[min-count] is a number, the stream is required to have at least that many elements in it. -@defexamples[ +@examples[ #:eval sequence-evaluator (define/contract predicates (sequence/c (-> any/c boolean?)) (in-list (list integer? string->symbol))) -(for ([P predicates]) - (printf "~s\n" (P "cat"))) +(eval:error + (for ([P predicates]) + (printf "~s\n" (P "cat")))) (define/contract numbers&strings (sequence/c number? string?) (in-dict (list (cons 1 "one") (cons 2 "two") (cons 3 'three)))) -(for ([(N S) numbers&strings]) - (printf "~s: ~a\n" N S)) +(eval:error + (for ([(N S) numbers&strings]) + (printf "~s: ~a\n" N S))) (define/contract a-sequence (sequence/c #:min-count 2 char?) "x") -(for ([x a-sequence] - [i (in-naturals)]) - (printf "~a is ~a\n" i x)) +(eval:error + (for ([x a-sequence] + [i (in-naturals)]) + (printf "~a is ~a\n" i x))) ] } @@ -1160,11 +1205,12 @@ values from the generator. literal, exact, non-negative integer. @examples[#:eval generator-eval - (let ([g (in-generator - (let loop ([n 3]) - (unless (zero? n) (yield n (add1 n)) (loop (sub1 n)))))]) - (let-values ([(not-empty? next) (sequence-generate g)]) - (let loop () (when (not-empty?) (next) (loop))) 'done)) + (eval:error + (let ([g (in-generator + (let loop ([n 3]) + (unless (zero? n) (yield n (add1 n)) (loop (sub1 n)))))]) + (let-values ([(not-empty? next) (sequence-generate g)]) + (let loop () (when (not-empty?) (next) (loop))) 'done))) (let ([g (in-generator #:arity 2 (let loop ([n 3]) (unless (zero? n) (yield n (add1 n)) (loop (sub1 n)))))]) @@ -1174,7 +1220,7 @@ values from the generator. To use an existing generator as a sequence, use @racket[in-producer] with a stop-value known for the generator: - @interaction[#:eval generator-eval + @examples[#:label #f #:eval generator-eval (define abc-generator (generator () (for ([x '(a b c)]) (yield x)))) diff --git a/pkgs/racket-doc/scribblings/reference/serialization.scrbl b/pkgs/racket-doc/scribblings/reference/serialization.scrbl index 980bdd5dc2..2962dc1db5 100644 --- a/pkgs/racket-doc/scribblings/reference/serialization.scrbl +++ b/pkgs/racket-doc/scribblings/reference/serialization.scrbl @@ -2,7 +2,7 @@ @(require "mz.rkt" racket/serialize (for-label racket/serialize racket/fasl)) @(define ser-eval (make-base-eval)) -@(interaction-eval #:eval ser-eval (require racket/serialize)) +@examples[#:hidden #:eval ser-eval (require racket/serialize)] @title[#:tag "serialization"]{Serialization} diff --git a/pkgs/racket-doc/scribblings/reference/sets.scrbl b/pkgs/racket-doc/scribblings/reference/sets.scrbl index 9500bfd8e8..63d0b1aff3 100644 --- a/pkgs/racket-doc/scribblings/reference/sets.scrbl +++ b/pkgs/racket-doc/scribblings/reference/sets.scrbl @@ -3,7 +3,7 @@ @title[#:tag "sets"]{Sets} @(define set-eval (make-base-eval)) -@(interaction-eval #:eval set-eval (require racket/set)) +@examples[#:hidden #:eval set-eval (require racket/set)] A @deftech{set} represents a collection of distinct elements. The following datatypes are all sets: @@ -203,17 +203,21 @@ named by the @racket[sym]s. 'dont-care] [#:kind kind (or/c 'dont-care 'immutable 'mutable 'weak 'mutable-or-weak) - 'immutable]) + 'immutable] + [#:lazy? lazy? any/c + (not (and (equal? kind 'immutable) + (flat-contract? elem/c)))] + [#:equal-key/c equal-key/c contract? any/c]) contract?]{ Constructs a contract that recognizes sets whose elements match - @racket[contract]. + @racket[elem/c]. If @racket[kind] is @racket['immutable], @racket['mutable], or @racket['weak], the resulting contract accepts only @tech{hash sets} that are respectively immutable, mutable with strongly-held keys, or mutable with weakly-held keys. If @racket[kind] is @racket['mutable-or-weak], the - resulting contract accepts any mutable @racket{hash sets}, regardless of + resulting contract accepts any mutable @tech{hash sets}, regardless of key-holding strength. If @racket[cmp] is @racket['equal], @racket['eqv], or @racket['eq], the @@ -221,12 +225,34 @@ named by the @racket[sym]s. using @racket[equal?], @racket[eqv?], or @racket[eq?], respectively. If @racket[cmp] is @racket['eqv] or @racket['eq], then @racket[elem/c] must - be a flat contract. + be a @tech{flat contract}. If @racket[cmp] and @racket[kind] are both @racket['dont-care], then the resulting contract will accept any kind of set, not just @tech{hash sets}. + If @racket[lazy?] is not @racket[#f], then the elements of the set are not checked + immediately by the contract and only the set itself is checked (according to the + @racket[cmp] and @racket[kind] arguments). If @racket[lazy?] is + @racket[#f], then the elements are checked immediately by the contract. + The @racket[lazy?] argument is ignored when the set contract accepts generic sets + (i.e., when @racket[cmp] and @racket[kind] are both @racket['dont-care]); in that + case, the value being checked in that case is a @racket[list?], then the contract + is not lazy otherwise the contract is lazy. + + If @racket[kind] allows mutable sets (i.e., is @racket['dont-care], + @racket['mutable], @racket['weak], or + @racket['mutable-or-weak]) and @racket[lazy?] is @racket[#f], then the elements + are checked both immediately and when they are accessed from the set. + + The @racket[equal-key/c] contract is used when values are passed to the comparison + and hashing functions used internally. + + The result contract will be a @tech{flat contract} when @racket[elem/c] + and @racket[equal-key/c] are both @tech{flat contracts}, + @racket[lazy?] is @racket[#f], and @racket[kind] is @racket['immutable]. + The result will be a @tech{chaperone contract} when @racket[elem/c] is a + @tech{chaperone contract}. } @section{Generic Set Interface} @@ -446,7 +472,7 @@ Supported for any @racket[st] that @impl{implements} @racket[set-add] and @supp (set-union (seteq)) (set-union (set 1 2) (set 2 3)) (set-union (list 1 2) (list 2 3)) -(set-union (set 1 2) (seteq 2 3)) (code:comment "Sets of different types cannot be unioned.") +(eval:error (set-union (set 1 2) (seteq 2 3))) (code:comment "Sets of different types cannot be unioned") ]} @defproc[(set-union! [st0 generic-set?] [st generic-set?] ...) void?]{ @@ -518,7 +544,7 @@ both @racket[set-clear] and @racket[set-add], and @supp{supports} @racket[set->s } -@defproc[(set-subtract! [st0 generic-set?] [st generic-set?] ...) generic-set?]{ +@defproc[(set-subtract! [st0 generic-set?] [st generic-set?] ...) void?]{ Removes every element from @racket[st0] that is contained by any of the @racket[st]s. @@ -557,7 +583,7 @@ Supported for any @racket[st] that @impl{implements} @racket[set-remove] or both } -@defproc[(set-symmetric-difference! [st0 generic-set?] [st generic-set?] ...) generic-set?]{ +@defproc[(set-symmetric-difference! [st0 generic-set?] [st generic-set?] ...) void?]{ Adds and removes elements of @racket[st0] so that it includes all of the elements contained an odd number of times in the @racket[st]s and the @@ -598,8 +624,7 @@ Supported for any @racket[st] and @racket[st2] that both @supp{support} (set=? (set 1 2 3) (set 1)) (set=? (set 1 2 3) (set 1 2 3)) (set=? (seteq 1 2) (mutable-seteq 2 1)) -(set=? (seteq 1 2) (seteqv 1 2)) (code:comment "Sets of different types cannot -be compared.") +(eval:error (set=? (seteq 1 2) (seteqv 1 2))) (code:comment "Sets of different types cannot be compared") ] } @@ -696,6 +721,77 @@ Supported for any @racket[st] that @supp{supports} @racket[set->stream]. } +@defproc[(impersonate-hash-set [st (or/c mutable-set? weak-set?)] + [inject-proc (or/c #f (-> set? any/c any/c))] + [add-proc (or/c #f (-> set? any/c any/c))] + [shrink-proc (or/c #f (-> set? any/c any/c))] + [extract-proc (or/c #f (-> set? any/c any/c))] + [clear-proc (or/c #f (-> set? any)) #f] + [equal-key-proc (or/c #f (-> set? any/c any/c)) #f] + [prop impersonator-property?] + [prop-val any/c] ... ...) + (and/c (or/c mutable-set? weak-set?) impersonator?)]{ + Impersonates @racket[st], redirecting various set operations via the given procedures. + + The @racket[inject-proc] procedure + is called whenever an element is temporarily put into the set for the purposes + of comparing it with other elements that may already be in the set. For example, + when evaluating @racket[(set-member? s e)], @racket[e] will be passed to the + @racket[inject-proc] before comparing it with other elements of @racket[s]. + + The @racket[add-proc] procedure is called when adding an element to a set, e.g., + via @racket[set-add] or @racket[set-add!]. The result of the @racket[add-proc] is + stored in the set. + + The @racket[shrink-proc] procedure is called when building a new set with + one fewer element. For example, when evaluating @racket[(set-remove s e)] + or @racket[(set-remove! s e)], + an element is removed from a set, e.g., + via @racket[set-remove] or @racket[set-remove!]. The result of the @racket[shrink-proc] + is the element actually removed from the set. + + The @racket[extract-proc] procedure is called when an element is pulled out of + a set, e.g., by @racket[set-first]. The result of the @racket[extract-proc] is + the element actually produced by from the set. + + The @racket[clear-proc] is called by @racket[set-clear] and @racket[set-clear!] + and if it returns (as opposed to escaping, perhaps via raising an exception), + the clearing operation is permitted. Its result is ignored. If @racket[clear-proc] + is @racket[#f], then clearing is done element by element (via calls into the other + supplied procedures). + + The @racket[equal-key-proc] is called when an element's hash code is needed of when an + element is supplied to the underlying equality in the set. The result of + @racket[equal-key-proc] is used when computing the hash or comparing for equality. + + If any of the @racket[inject-proc], @racket[add-proc], @racket[shrink-proc], or + @racket[extract-proc] arguments are @racket[#f], then they all must be @racket[#f], + the @racket[clear-proc] and @racket[equal-key-proc] must also be @racket[#f], + and there must be at least one property supplied. + + Pairs of @racket[prop] and @racket[prop-val] (the number of arguments to + @racket[impersonate-hash-set] must be odd) add @tech{impersonator properties} or + override impersonator property values of @racket[st]. +} + +@defproc[(chaperone-hash-set [st (or/c set? mutable-set? weak-set?)] + [inject-proc (or/c #f (-> set? any/c any/c))] + [add-proc (or/c #f (-> set? any/c any/c))] + [shrink-proc (or/c #f (-> set? any/c any/c))] + [extract-proc (or/c #f (-> set? any/c any/c))] + [clear-proc (or/c #f (-> set? any)) #f] + [equal-key-proc (or/c #f (-> set? any/c any/c)) #f] + [prop impersonator-property?] + [prop-val any/c] ... ...) + (and/c (or/c set? mutable-set? weak-set?) chaperone?)]{ + Chaperones @racket[st]. Like @racket[impersonate-hash-set] but with + the constraints that the results of the @racket[inject-proc], + @racket[add-proc], @racket[shrink-proc], @racket[extract-proc], and + @racket[equal-key-proc] must be + @racket[chaperone-of?] their second arguments. Also, the input + may be an @racket[immutable?] set. +} + @section{Custom Hash Sets} @defform[(define-custom-set-types name @@ -710,7 +806,7 @@ Supported for any @racket[st] that @supp{supports} @racket[set->stream]. (code:line hash1-expr) (code:line hash1-expr hash2-expr)])]{ -Creates a new set type based on the given comparison @racket[comparison-expr], +Creates a new hash set type based on the given comparison @racket[comparison-expr], hash functions @racket[hash1-expr] and @racket[hash2-expr], and element predicate @racket[predicate-expr]; the interfaces for these functions are the same as in @racket[make-custom-set-types]. The new set type has three @@ -750,6 +846,8 @@ initial elements. (make-mutable-string-set '("apple" "banana"))) (generic-set? imm) (generic-set? mut) +(set? imm) +(generic-set? imm) (string-set? imm) (string-set? mut) (immutable-string-set? imm) diff --git a/pkgs/racket-doc/scribblings/reference/shared.scrbl b/pkgs/racket-doc/scribblings/reference/shared.scrbl index e2fad691e4..ecdcfd3cfc 100644 --- a/pkgs/racket-doc/scribblings/reference/shared.scrbl +++ b/pkgs/racket-doc/scribblings/reference/shared.scrbl @@ -3,7 +3,7 @@ @(define shared-eval (make-base-eval)) -@(interaction-eval #:eval shared-eval (require racket/shared)) +@examples[#:hidden #:eval shared-eval (require racket/shared)] @(define maker (make-element #f (list @@ -125,11 +125,11 @@ that can be created via mutation). (shared ([a (cons 1 b)] [b 7]) a) -(shared ([a a]) (code:comment @#,t{no indirection...}) - a) -(shared ([a (cons 1 b)] (code:comment @#,t{@racket[b] is early...}) - [b a]) - a) +(eval:error (shared ([a a]) (code:comment @#,t{no indirection...}) + a)) +(eval:error (shared ([a (cons 1 b)] (code:comment @#,t{@racket[b] is early...}) + [b a]) + a)) (shared ([a (mcons 1 b)] (code:comment @#,t{@racket[b] is patchable...}) [b a]) a) diff --git a/pkgs/racket-doc/scribblings/reference/splicing.scrbl b/pkgs/racket-doc/scribblings/reference/splicing.scrbl index d657dfd1c6..1d24b111af 100644 --- a/pkgs/racket-doc/scribblings/reference/splicing.scrbl +++ b/pkgs/racket-doc/scribblings/reference/splicing.scrbl @@ -2,9 +2,9 @@ @(require "mz.rkt" (for-label racket/splicing racket/stxparam racket/local)) @(define splice-eval (make-base-eval)) -@interaction-eval[#:eval splice-eval (require racket/splicing - racket/stxparam - (for-syntax racket/base))] +@examples[#:hidden #:eval splice-eval (require racket/splicing + racket/stxparam + (for-syntax racket/base))] @title[#:tag "splicing"]{Local Binding with Splicing Body} @@ -35,7 +35,7 @@ definition context (in the same way as for @racket[begin]). (splicing-let-syntax ([one (lambda (stx) #'1)]) (define o one)) o -one +(eval:error one) ] When a splicing binding form occurs in a @tech{top-level context} or @@ -46,9 +46,10 @@ once during compilation as in @racket[let-syntax], etc. @examples[ #:eval splice-eval -(splicing-letrec ([x bad] - [bad 1]) - x)] +(eval:error + (splicing-letrec ([x bad] + [bad 1]) + x))] If a definition within a splicing form is intended to be local to the splicing body, then the identifier should have a true value for the diff --git a/pkgs/racket-doc/scribblings/reference/string-ports.scrbl b/pkgs/racket-doc/scribblings/reference/string-ports.scrbl index 0c53ddba87..9894e605ca 100644 --- a/pkgs/racket-doc/scribblings/reference/string-ports.scrbl +++ b/pkgs/racket-doc/scribblings/reference/string-ports.scrbl @@ -2,7 +2,7 @@ @(require "mz.rkt") @(define sp-eval (make-base-eval)) -@(interaction-eval #:eval sp-eval (require racket/list)) +@examples[#:hidden #:eval sp-eval (require racket/list)] @title[#:tag "stringport"]{String Ports} diff --git a/pkgs/racket-doc/scribblings/reference/strings.scrbl b/pkgs/racket-doc/scribblings/reference/strings.scrbl index 9439bb362a..97427350e8 100644 --- a/pkgs/racket-doc/scribblings/reference/strings.scrbl +++ b/pkgs/racket-doc/scribblings/reference/strings.scrbl @@ -378,7 +378,7 @@ allocated string).} @note-lib[racket/string] @(define string-eval (make-base-eval)) -@(interaction-eval #:eval string-eval (require racket/string racket/list)) +@examples[#:hidden #:eval string-eval (require racket/string racket/list)] @defproc[(string-append* [str string?] ... [strs (listof string?)]) string?]{ @; Note: this is exactly the same description as the one for append* diff --git a/pkgs/racket-doc/scribblings/reference/struct.scrbl b/pkgs/racket-doc/scribblings/reference/struct.scrbl index 4fc17890de..1d0aa270ba 100644 --- a/pkgs/racket-doc/scribblings/reference/struct.scrbl +++ b/pkgs/racket-doc/scribblings/reference/struct.scrbl @@ -197,52 +197,52 @@ The result of @racket[make-struct-type] is five values: @examples[ #:eval struct-eval -(define-values (struct:a make-a a? a-ref a-set!) - (make-struct-type 'a #f 2 1 'uninitialized)) -(define an-a (make-a 'x 'y)) + +(eval:no-prompt + (define-values (struct:a make-a a? a-ref a-set!) + (make-struct-type 'a #f 2 1 'uninitialized)) + (define an-a (make-a 'x 'y))) + (a-ref an-a 1) (a-ref an-a 2) (define a-first (make-struct-field-accessor a-ref 0)) (a-first an-a) -] -@interaction[ -#:eval struct-eval -(define-values (struct:b make-b b? b-ref b-set!) - (make-struct-type 'b struct:a 1 2 'b-uninitialized)) -(define a-b (make-b 'x 'y 'z)) +(eval:no-prompt + (define-values (struct:b make-b b? b-ref b-set!) + (make-struct-type 'b struct:a 1 2 'b-uninitialized)) + (define a-b (make-b 'x 'y 'z))) + (a-ref a-b 1) (a-ref a-b 2) (b-ref a-b 0) (b-ref a-b 1) (b-ref a-b 2) -] -@interaction[ -#:eval struct-eval -(define-values (struct:c make-c c? c-ref c-set!) - (make-struct-type - 'c struct:b 0 0 #f null (make-inspector) #f null - (code:comment #,(t "guard checks for a number, and makes it inexact")) - (lambda (a1 a2 b1 name) - (unless (number? a2) - (error (string->symbol (format "make-~a" name)) - "second field must be a number")) - (values a1 (exact->inexact a2) b1)))) -(make-c 'x 'y 'z) +(eval:no-prompt + (define-values (struct:c make-c c? c-ref c-set!) + (make-struct-type + 'c struct:b 0 0 #f null (make-inspector) #f null + (code:comment #,(t "guard checks for a number, and makes it inexact")) + (lambda (a1 a2 b1 name) + (unless (number? a2) + (error (string->symbol (format "make-~a" name)) + "second field must be a number")) + (values a1 (exact->inexact a2) b1))))) + +(eval:error (make-c 'x 'y 'z)) (define a-c (make-c 'x 2 'z)) (a-ref a-c 1) -]} -@interaction[ -#:eval struct-eval -(define p1 #s(p a b c)) -(define-values (struct:p make-p p? p-ref p-set!) - (make-struct-type 'p #f 3 0 #f null 'prefab #f '(0 1 2))) +(eval:no-prompt + (define p1 #s(p a b c)) + (define-values (struct:p make-p p? p-ref p-set!) + (make-struct-type 'p #f 3 0 #f null 'prefab #f '(0 1 2)))) + (p? p1) (p-ref p1 0) (make-p 'x 'y 'z) -] +]} @defproc[(make-struct-field-accessor [accessor-proc struct-accessor-procedure?] [field-pos exact-nonnegative-integer?] @@ -667,7 +667,7 @@ the inaccessible fields are omitted from the list. (struct->list (make-open 'a 'b)) (struct->list #s(pre 1 2 3)) (define-struct (secret open) (x y)) -(struct->list (make-secret 0 1 17 22)) +(eval:error (struct->list (make-secret 0 1 17 22))) (struct->list (make-secret 0 1 17 22) #:on-opaque 'return-false) (struct->list (make-secret 0 1 17 22) #:on-opaque 'skip) (struct->list 'not-a-struct #:on-opaque 'return-false) diff --git a/pkgs/racket-doc/scribblings/reference/stx-comp.scrbl b/pkgs/racket-doc/scribblings/reference/stx-comp.scrbl index 762da318bf..8b4478c889 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-comp.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-comp.scrbl @@ -2,7 +2,7 @@ @(require "mz.rkt") @(define stx-eval (make-base-eval)) -@(interaction-eval #:eval stx-eval (require (for-syntax racket/base))) +@examples[#:hidden #:eval stx-eval (require (for-syntax racket/base))] @title[#:tag "stxcmp"]{Syntax Object Bindings} diff --git a/pkgs/racket-doc/scribblings/reference/stx-expand.scrbl b/pkgs/racket-doc/scribblings/reference/stx-expand.scrbl index 895f9f9bdc..df0faf8063 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-expand.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-expand.scrbl @@ -105,6 +105,14 @@ to the syntax object: list of @tech{module path index}es (or symbols) representing the modules explicitly for-template imported into the module.} + @item{@indexed-racket['module-direct-for-meta-requires] --- a list of + lists: each list is an integer or @racket[#f] representing a + @tech{phase level} followed by a list of @tech{module path index}es + (or symbols) representing the modules explicitly imported into the + module at the corresponding phase. + + @history[#:added "6.4.0.1"]} + @item{@indexed-racket['module-variable-provides] --- a list of provided items, where each item is one of the following: @@ -138,5 +146,35 @@ to the syntax object: be exported indirectly through macro expansions. Definitions of macro-generated identifiers create uninterned symbols in this list.} + @item{@indexed-racket['module-body-context] --- a syntax + object whose @tech{lexical information} corresponds to the inside of + the module, so it includes the expansion's @tech{outside-edge scope} + and its @tech{inside-edge scope}; that is, the syntax object + simulates an identifier that is present in the original module body + and inaccessible to manipulation by any macro, so that its lexical + information includes bindings for the module's imports and + definitions. + + @history[#:added "6.4.0.1"]} + + @item{@indexed-racket['module-body-inside-context] --- a syntax + object whose @tech{lexical information} corresponds to an identifier + that starts with no lexical context and is moved into the macro, so + that it includes only the expansions's @tech{inside-edge scope}. + + @history[#:added "6.4.0.1"]} + + @item{@indexed-racket['module-body-context-simple?] --- a boolean, + where @racket[#t] indicates that the bindings of the module's body + (as recorded in the @tech{lexical information} of the value of the + @racket['module-body-inside-context] property) can be directly + reconstructed from the values of @racket['module-direct-requires], + @racket['module-direct-for-syntax-requires], + @racket['module-direct-for-template-requires], and + @racket['module-direct-for-meta-requires]. + + @history[#:added "6.4.0.1"]} + + ] diff --git a/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl b/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl index 9ba322a818..3616be07a1 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl @@ -1,5 +1,5 @@ #lang scribble/doc -@(require "mz.rkt" scribble/eval) +@(require "mz.rkt") @(define stx-eval (make-base-eval)) @(stx-eval '(require (for-syntax racket/base))) diff --git a/pkgs/racket-doc/scribblings/reference/stx-param.scrbl b/pkgs/racket-doc/scribblings/reference/stx-param.scrbl index d17a3d02b5..047e00384b 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-param.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-param.scrbl @@ -1,6 +1,5 @@ #lang scribble/doc @(require "mz.rkt" - scribble/eval (for-label racket/stxparam racket/stxparam-exptime racket/splicing)) @(define the-eval (make-base-eval)) @@ -30,7 +29,7 @@ used as a macro that expands to a use of the target identifier, but @racket[syntax-local-value] of @racket[id] does not produce the target's value. -@defexamples[#:eval the-eval +@examples[#:eval the-eval (define-syntax-parameter current-class #f) (define-syntax-parameter yield (make-rename-transformer #'abort)) (define-syntax-parameter define/public @@ -59,7 +58,7 @@ used as a macro that expands to a use of the target identifier, but @racket[syntax-local-value] of @racket[id] does not produce the target's value. -@defexamples[#:eval the-eval +@examples[#:eval the-eval (define-syntax-parameter abort (syntax-rules ())) (define-syntax forever @@ -80,6 +79,34 @@ the target's value. (if t then else)))])) ]} +@defform[(define-rename-transformer-parameter id expr)]{ + +Binds @racket[id] as syntax to a @tech{syntax parameter} that must +be bound to a @racket[make-rename-transformer] result and, unlike +@racket[define-syntax-parameter], @racket[syntax-local-value] of +@racket[id] @emph{does} produce the target's value, including inside +of @racket[syntax-parameterize]. + +@examples[#:eval the-eval #:escape UNSYNTAX + (define-syntax (test stx) + (syntax-case stx () + [(_ t) + #`#,(syntax-local-value #'t)])) + (define-syntax one 1) + (define-syntax two 2) + (define-syntax-parameter not-num + (make-rename-transformer #'one)) + (test not-num) + + (define-rename-transformer-parameter num + (make-rename-transformer #'one)) + (test num) + (syntax-parameterize ([num (make-rename-transformer #'two)]) + (test num)) +] + +@history[#:added "6.3.0.14"]} + @; ---------------------------------------------------------------------- @section{Syntax Parameter Inspection} diff --git a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl index db3f8f36b3..6e9de282cf 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl +++ b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl @@ -5,10 +5,11 @@ racket/require-syntax racket/provide-transform racket/provide-syntax - racket/keyword-transform)) + racket/keyword-transform + syntax/intdef)) @(define stx-eval (make-base-eval)) -@(interaction-eval #:eval stx-eval (require (for-syntax racket/base))) +@examples[#:hidden #:eval stx-eval (require (for-syntax racket/base))] @(define (transform-time) @t{This procedure must be called during the dynamic extent of a @tech{syntax transformer} application by the @@ -197,10 +198,12 @@ the target identifier is extracted from the structure instance; if the field value is not an identifier, then an identifier @racketidfont{?} with an empty context is used, instead. -If the property value is a procedure that takes one argument, then the procedure -is called to obtain the identifier that the rename transformer will use -as a target identifier. If the procedure returns any value that is not -an identifier, the @racket[exn:fail:contract] exception is raised. +If the property value is a procedure that takes one argument, then the +procedure is called to obtain the identifier that the rename +transformer will use as a target identifier. The returned identifier +should probably have the @racket['not-free-identifier=?] syntax +property. If the procedure returns any value that is not an +identifier, the @racket[exn:fail:contract] exception is raised. @examples[#:eval stx-eval #:escape UNSYNTAX (code:comment "Example of a procedure argument for prop:rename-transformer") @@ -298,6 +301,13 @@ context is meant to splice into an immediately enclosing context, then when @racket[syntax-local-context] produces a list, @racket[cons] the generated value onto that list. +When expressions are expanded via @racket[local-expand] with an +internal-definition context @racket[intdef-ctx], and when the expanded +expressions are incorporated into an overall form @racket[_new-stx], +then typically @racket[internal-definition-context-track] should be +applied to @racket[intdef-ctx] and @racket[_new-stx] to provide +expansion history to external tools. + @transform-time[] @examples[#:eval stx-eval @@ -456,6 +466,18 @@ match the number of identifiers, otherwise the @transform-time[]} +@defproc[(internal-definition-context-binding-identifiers + [intdef-ctx internal-definition-context?]) + (listof identifier?)]{ + +Returns a list of all binding identifiers registered for +@racket[intdef-ctx] through @racket[syntax-local-bind-syntaxes]. Each +identifier in the returned list includes the @tech{internal-definition +context}'s @tech{scope}. + +@history[#:added "6.3.0.4"]} + + @defproc[(internal-definition-context-introduce [intdef-ctx internal-definition-context?] [stx syntax?] [mode (or/c 'flip 'add 'remove) 'flip]) @@ -489,6 +511,8 @@ provided for backward compatibility; the more general @history[#:changed "6.3" @elem{Simplified the operation to @tech{scope} removal.}]} + + @defthing[prop:expansion-contexts struct-type-property?]{ A @tech{structure type property} to constrain the use of macro @@ -570,7 +594,7 @@ if not @racket[#f]. If @racket[failure-thunk] is @racket[false], the @examples[#:eval stx-eval (define-syntax (transformer-2 stx) (syntax-local-value #'something-else (λ () (error "no binding")))) - (transformer-2) + (eval:error (transformer-2)) ] @examples[#:eval stx-eval (define-syntax nachos #'(printf "nachos~n")) @@ -629,7 +653,9 @@ Other syntactic forms can capture lifts by using @racket[local-expand/capture-lifts] or @racket[local-transformer-expand/capture-lifts]. -@transform-time[]} +@transform-time[] In addition, this procedure can be called only when +a lift target is available, as indicated by +@racket[syntax-transforming-with-lifts?].} @defproc[(syntax-local-lift-values-expression [n exact-nonnegative-integer?] [stx syntax?]) (listof identifier?)]{ @@ -855,6 +881,21 @@ transformer} application by the expander and while a module is being @tech{visit}ed, @racket[#f] otherwise.} +@defproc[(syntax-transforming-with-lifts?) boolean?]{ + +Returns @racket[#t] if @racket[(syntax-transforming?)] produces +@racket[#t] and a target context is available for lifting expressions +(via @racket[syntax-local-lift-expression]), @racket[#f] otherwise. + +For example, during an immedate macro expansion triggered by +@racket[local-expand], as opposed to +@racket[local-expand/capture-lifts], @racket[(syntax-transforming?)] +produces @racket[#t] while @racket[(syntax-transforming-with-lifts?)] +produces @racket[#f]. + +@history[#:added "6.3.0.9"]} + + @defproc[(syntax-transforming-module-expression?) boolean?]{ Returns @racket[#t] during the dynamic extent of a @tech{syntax @@ -916,7 +957,7 @@ and different result procedures use distinct scopes. added the optional operation argument in the result procedure.}]} -@defproc[(make-syntax-delta-introducer [ext-stx syntax?] +@defproc[(make-syntax-delta-introducer [ext-stx identifier?] [base-stx (or/c syntax? #f)] [phase-level (or/c #f exact-integer?) (syntax-local-phase-level)]) @@ -925,8 +966,10 @@ and different result procedures use distinct scopes. Produces a procedure that behaves like the result of @racket[make-syntax-introducer], but using the @tech{scopes} of @racket[ext-stx] that are not shared with @racket[base-stx]. +A @racket[#f] value for @racket[base-stx] is equivalent to a syntax +object with no @tech{scopes}. -This procedure is potentially useful when @racket[_m-id] has a +This procedure is potentially useful when some @racket[_m-id] has a transformer binding that records some @racket[_orig-id], and a use of @racket[_m-id] introduces a binding of @racket[_orig-id]. In that case, the @tech{scopes} one the use of @racket[_m-id] added since the diff --git a/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl b/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl index d3cf4cb2af..3028db2646 100644 --- a/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl +++ b/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl @@ -2,7 +2,7 @@ @(require scribble/struct "mz.rkt" (for-syntax mzscheme)) @(define racket-eval (make-base-eval)) -@(interaction-eval #:eval racket-eval (require (for-syntax racket/base))) +@examples[#:hidden #:eval racket-eval (require (for-syntax racket/base))] @;------------------------------------------------------------------------ @title[#:tag "syntax-model"]{Syntax Model} @@ -742,9 +742,7 @@ internal-definition context are equivalent to local binding via @racket[letrec-syntaxes+values]; macro expansion converts internal definitions to a @racket[letrec-syntaxes+values] form. -Expansion of an internal-definition context begins with the -introduction of a fresh @tech{scope} for the context. Thereafter, -expansion relies on @tech{partial expansion} of each @racket[_body] in +Expansion relies on @tech{partial expansion} of each @racket[_body] in an internal-definition sequence. Partial expansion of each @racket[_body] produces a form matching one of the following cases: @@ -782,8 +780,25 @@ are then converted to bindings in a @racket[letrec-syntaxes+values] form, and all expressions after the last definition become the body of the @racket[letrec-syntaxes+values] form. +Before partial expansion begins, expansion of an internal-definition +context begins with the introduction of a fresh @deftech{outside-edge +scope} on the content of the internal-definition context. This +outside-edge scope effectively identifies syntax objects that are +present in the original form. An @deftech{inside-edge scope} is also +created and added to the original content; furthermore, the +inside-edge scope is added to the result of any partial expansion. +This inside-edge scope ensures that all bindings introduced by the +internal-definition context have a particular scope in common. + @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -@subsection[#:tag "mod-parse"]{Module Phases and Visits} +@subsection[#:tag "mod-parse"]{Module Expansion, Phases, and Visits} + +Expansion of a @racket[module] form proceeds in a similar way to +@seclink["intdef-body"]{expansion of an internal-definition context}: +an @tech{outside-edge scope} is created for the original module +content, and an @tech{inside-edge scope} is added to both the original +module and any form that appears during a partial expansion of the +module's top-level forms to uncover definitions and imports. A @racket[require] form not only introduces @tech{bindings} at expansion time, but also @deftech{visits} the referenced module when @@ -893,7 +908,7 @@ bucket-2 (define (odd x) (if (zero? x) #f (even (sub1 x)))) (define (even x) (if (zero? x) #t (odd (sub1 x)))) (odd 17))])) -(defs-and-uses/fail) +(eval:error (defs-and-uses/fail)) (define-syntax defs-and-uses (syntax-rules () diff --git a/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl b/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl index d4125b3507..50a482d9e6 100644 --- a/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl +++ b/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl @@ -36,13 +36,13 @@ in the argument list are automatically converted to symbols. [(make-pred name) (format-id #'name "~a?" (syntax-e #'name))])) (make-pred pair) -(make-pred none-such) +(eval:error (make-pred none-such)) (define-syntax (better-make-pred stx) (syntax-case stx () [(better-make-pred name) (format-id #'name #:source #'name "~a?" (syntax-e #'name))])) -(better-make-pred none-such) +(eval:error (better-make-pred none-such)) ] (Scribble doesn't show it, but the DrRacket pinpoints the location of @@ -108,9 +108,10 @@ is prefixed with the special form name as described under @racket[current-syntax-context]. @examples[#:eval the-eval -(wrong-syntax #'here "expected ~s" 'there) -(parameterize ([current-syntax-context #'(look over here)]) - (wrong-syntax #'here "expected ~s" 'there)) +(eval:error (wrong-syntax #'here "expected ~s" 'there)) +(eval:error + (parameterize ([current-syntax-context #'(look over here)]) + (wrong-syntax #'here "expected ~s" 'there))) ] A macro using @racket[wrong-syntax] might set the syntax context at the very diff --git a/pkgs/racket-doc/scribblings/reference/syntax.scrbl b/pkgs/racket-doc/scribblings/reference/syntax.scrbl index 4308848967..fde18939ba 100644 --- a/pkgs/racket-doc/scribblings/reference/syntax.scrbl +++ b/pkgs/racket-doc/scribblings/reference/syntax.scrbl @@ -282,7 +282,7 @@ form. See also @racket[module-compiled-language-info], See also @secref["module-eval-model"] and @secref["mod-parse"]. -@defexamples[#:eval (syntax-eval) +@examples[#:eval (syntax-eval) #:once (module duck racket/base (provide num-eggs quack) (define num-eggs 2) @@ -510,13 +510,13 @@ bindings of each @racket[require-spec] are visible for expanding later is not in the set that @racket[require-spec] describes, a syntax error is reported. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (require (only-in racket/tcp tcp-listen [tcp-accept my-accept])) tcp-listen my-accept - tcp-accept + (eval:error tcp-accept) ]} @defsubform[(except-in require-spec id ...)]{ Like @@ -525,11 +525,11 @@ bindings of each @racket[require-spec] are visible for expanding later in the set that @racket[require-spec] describes, a syntax error is reported. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (require (except-in racket/tcp tcp-listen)) tcp-accept - tcp-listen + (eval:error tcp-listen) ]} @defsubform[(prefix-in prefix-id require-spec)]{ Like @@ -538,7 +538,7 @@ bindings of each @racket[require-spec] are visible for expanding later @racket[prefix-id] is ignored, and instead preserved from the identifiers before prefixing. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (require (prefix-in tcp: racket/tcp)) tcp:tcp-accept tcp:tcp-listen @@ -550,7 +550,7 @@ bindings of each @racket[require-spec] are visible for expanding later @racket[orig-id] is not in the set that @racket[require-spec] describes, a syntax error is reported. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (require (rename-in racket/tcp (tcp-accept accept) (tcp-listen listen))) @@ -563,7 +563,7 @@ bindings of each @racket[require-spec] are visible for expanding later @racket[require-spec]s have the same identifier name but they do not refer to the same original binding, a syntax error is reported. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (require (combine-in (only-in racket/tcp tcp-accept) (only-in racket/tcp tcp-listen))) tcp-accept @@ -588,7 +588,7 @@ bindings of each @racket[require-spec] are visible for expanding later The following example imports bindings only at @tech{phase level} 1, the transform phase: - @interaction[#:eval meta-in-eval + @examples[#:label #f #:eval meta-in-eval (module nest racket (provide (for-syntax meta-eggs) (for-meta 1 meta-chicks) @@ -604,13 +604,13 @@ bindings of each @racket[require-spec] are visible for expanding later #'(void)) (desc) - num-eggs + (eval:error num-eggs) ] The following example imports only bindings at @tech{phase level} 0, the normal phase. - @interaction[#:eval meta-in-eval + @examples[#:label #f #:eval meta-in-eval (require (only-meta-in 0 'nest)) num-eggs ]} @@ -622,7 +622,7 @@ bindings of each @racket[require-spec] are visible for expanding later @tech{label phase level} corresponds to @racket[#f], and a shifting combination that involves @racket[#f] produces @racket[#f]. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide num-eggs) (define num-eggs 2)) @@ -894,7 +894,7 @@ level} 0 are imported. (let () (local-require racket/control) fcontrol) - fcontrol + (eval:error fcontrol) ]} @@ -944,7 +944,7 @@ as follows. identifier must match (otherwise, the external name could be ambiguous). - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide num-eggs) (define num-eggs 2)) @@ -968,7 +968,7 @@ as follows. macro-introduced imports are not re-exported, unless the @racket[(all-defined-out)] form was introduced at the same time. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide (all-defined-out)) (define num-eggs 2)) @@ -987,7 +987,7 @@ as follows. macro-introduced imports are not re-exported, unless the @racket[module-path] was introduced at the same time. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide num-eggs) (define num-eggs 2)) @@ -1003,13 +1003,13 @@ as follows. the relevant @tech{phase level}. The symbolic name for each export is @racket[export-id] instead @racket[orig-d]. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide (rename-out [count num-eggs])) (define count 2)) (require 'nest) num-eggs - count + (eval:error count) ]} @defsubform[(except-out provide-spec provide-spec ...)]{ Like the @@ -1019,7 +1019,7 @@ as follows. reported. The symbolic export name information in the latter @racket[provide-spec]s is ignored; only the bindings are used. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide (except-out (all-defined-out) num-chicks)) @@ -1027,14 +1027,14 @@ as follows. (define num-chicks 3)) (require 'nest) num-eggs - num-chicks + (eval:error num-chicks) ]} @defsubform[(prefix-out prefix-id provide-spec)]{ Like @racket[provide-spec], but with each symbolic export name from @racket[provide-spec] prefixed with @racket[prefix-id]. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide (prefix-out chicken: num-eggs)) (define num-eggs 2)) @@ -1055,7 +1055,7 @@ as follows. accessor and mutator bindings of the super-type are @italic{not} included by @racket[struct-out] for export. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide (struct-out egg)) (struct egg (color wt))) @@ -1066,7 +1066,7 @@ as follows. @defsubform[(combine-out provide-spec ...)]{ The union of the @racket[provide-spec]s. - @defexamples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide (combine-out num-eggs num-chicks)) (define num-eggs 2) @@ -1084,7 +1084,7 @@ as follows. For more details, see @secref["modprotect"]. The @racket[provide-spec] must specify only bindings that are defined within the exporting module. - @examples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (provide num-eggs (protect-out num-chicks)) (define num-eggs 2) @@ -1102,7 +1102,7 @@ as follows. (require 'nest) (list num-eggs num-chicks) (weak-eval 'num-eggs) - (weak-eval 'num-chicks) + (eval:error (weak-eval 'num-chicks)) ]} @specsubform[#:literals (for-meta) @@ -1118,7 +1118,7 @@ as follows. @racket[all-from-out] exports bindings imported with a shift by @racket[phase-level]. - @examples[#:eval (syntax-eval) + @examples[#:eval (syntax-eval) #:once (module nest racket (begin-for-syntax (define eggs 2)) @@ -1132,11 +1132,12 @@ as follows. (test-eggs) chickens - (module broken-nest racket - (define eggs 2) - (define chickens 3) - (provide (for-syntax eggs) - chickens)) + (eval:error + (module broken-nest racket + (define eggs 2) + (define chickens 3) + (provide (for-syntax eggs) + chickens))) (module nest2 racket (begin-for-syntax @@ -1309,7 +1310,7 @@ Like @racket[require-spec], but including only imports whose names match @racket[regexp]. The @racket[regexp] must be a literal regular expression (see @secref["regexp"]). -@defexamples[#:eval (syntax-eval) +@examples[#:eval (syntax-eval) #:once (module zoo racket/base (provide tunafish swordfish blowfish monkey lizard ant) @@ -1324,7 +1325,7 @@ Like @racket[require-spec], but including only imports whose names tunafish swordfish blowfish -monkey +(eval:error monkey) ]} @defform[(subtract-in require-spec subtracted-spec ...)]{ @@ -1332,7 +1333,7 @@ monkey Like @racket[require-spec], but omitting those imports that would be imported by one of the @racket[subtracted-spec]s. -@defexamples[#:eval (syntax-eval) +@examples[#:eval (syntax-eval) #:once (module earth racket (provide land sea air) (define land 1) @@ -1350,7 +1351,7 @@ Like @racket[require-spec], but omitting those imports that would be (require racket/require) (require (subtract-in 'solar-system 'earth)) -land +(eval:error land) aliens ]} @@ -1517,7 +1518,7 @@ introduces @racketidfont{#%datum} identifiers. @mz-examples[ (#%datum . 10) (#%datum . x) -(#%datum . #:x) +(eval:error (#%datum . #:x)) ] } @@ -1532,14 +1533,14 @@ expression. @mz-examples[ (#%expression (+ 1 2)) -(#%expression (define x 10)) +(eval:error (#%expression (define x 10))) ] The @racket[#%expression] form is helpful in recursive definition contexts where expanding a subsequent definition can provide compile-time information for the current expression. For example, consider a @racket[define-sym-case] macro that simply records some symbols at compile-time in a given identifier. -@interaction/no-prompt[#:eval meta-in-eval +@examples[#:label #f #:no-prompt #:eval meta-in-eval (define-syntax (define-sym-case stx) (syntax-case stx () [(_ id sym ...) @@ -1548,7 +1549,7 @@ macro that simply records some symbols at compile-time in a given identifier. '(sym ...))]))] and then a variant of @racket[case] that checks to make sure the symbols used in the expression match those given in the earlier definition: -@interaction/no-prompt[#:eval meta-in-eval +@examples[#:label #f #:no-prompt #:eval meta-in-eval (define-syntax (sym-case stx) (syntax-case stx () [(_ id val-expr [(sym) expr] ...) @@ -1575,18 +1576,19 @@ If the definition follows the use like this, then the @racket[define-sym-case] macro does not have a chance to bind @racket[id] and the @racket[sym-case] macro signals an error: -@interaction[#:eval meta-in-eval -(let () - (sym-case land-creatures 'bear - [(bear) 1] - [(fox) 2]) - (define-sym-case land-creatures bear fox)) +@examples[#:label #f #:eval meta-in-eval +(eval:error + (let () + (sym-case land-creatures 'bear + [(bear) 1] + [(fox) 2]) + (define-sym-case land-creatures bear fox))) ] But if the @racket[sym-case] is wrapped in an @racket[#%expression], then the expander does not need to expand it to know it is an expression and it moves on to the @racket[define-sym-case] expression. -@interaction[#:eval meta-in-eval +@examples[#:label #f #:eval meta-in-eval (let () (#%expression (sym-case sea-creatures 'whale [(whale) 1] @@ -1740,7 +1742,7 @@ expander introduces @racketidfont{#%app} identifiers. @mz-examples[ (#%app + 1 2) (#%app (lambda (x #:arg y) (list y x)) #:arg 2 1) -(#%app cons) +(eval:error (#%app cons)) ]} @defform*[[(#%plain-app proc-expr arg-expr ...) @@ -2342,13 +2344,14 @@ in @math{O(log N)} time for @math{N} @racket[datum]s. (case (list 'quote 'x) [(x) "ex"] [('x) "quoted ex"]) -] -@def+int[ -(define (classify c) - (case (char-general-category c) - [(ll lu lt ln lo) "letter"] - [(nd nl no) "number"] - [else "other"])) + +(eval:no-prompt + (define (classify c) + (case (char-general-category c) + [(ll lu lt ln lo) "letter"] + [(nd nl no) "number"] + [else "other"]))) + (classify #\A) (classify #\1) (classify #\!) @@ -2394,19 +2397,20 @@ In a context that allows @tech{liberal expansion} of @racket[define], @racket[lambda] form with keyword arguments or @racket[args] include keyword arguments. -@defexamples[ -(define x 10) +@examples[ +(eval:no-prompt (define x 10)) x -] -@def+int[ -(define (f x) - (+ x 1)) -(f 10) -] -@def+int[ -(define ((f x) [y 20]) - (+ x y)) +(eval:no-prompt + (define (f x) + (+ x 1))) + +(f 10) + +(eval:no-prompt + (define ((f x) [y 20]) + (+ x y))) + ((f 10) 30) ((f 10)) ] @@ -2427,7 +2431,7 @@ and the top-level mapping of each @racket[id] (in the @techlink{namespace} linked with the compiled definition) is set to the binding at the same time. -@defexamples[ +@examples[ (define-values () (values)) (define-values (x y z) (values 1 2 3)) z @@ -2459,7 +2463,7 @@ expands to a definition of the first form where the @racket[expr] is a In an @tech{internal-definition context} (see @secref["intdef-body"]), a @racket[define-syntax] form introduces a local binding. -@defexamples[#:eval (syntax-eval) +@examples[#:eval (syntax-eval) #:once (define-syntax foo (syntax-rules () ((_ a ...) @@ -2490,7 +2494,7 @@ binding; see @secref["macro-introduced-bindings"]. In an @tech{internal-definition context} (see @secref["intdef-body"]), a @racket[define-syntaxes] form introduces local bindings. -@defexamples[#:eval (syntax-eval) +@examples[#:eval (syntax-eval) #:once (define-syntaxes (foo1 foo2 foo3) (let ([transformer1 (lambda (syntax-object) (syntax-case syntax-object () @@ -2526,14 +2530,14 @@ form must be expanded before the use is expanded). In particular, mutually recursive functions bound by @racket[define-for-syntax] must be defined by the same @racket[define-for-syntax] form. -@defexamples[#:eval (syntax-eval) +@examples[#:eval (syntax-eval) #:once (define-for-syntax helper 2) (define-syntax (make-two syntax-object) (printf "helper is ~a\n" helper) #'2) (make-two) (code:comment @#,t{`helper' is not bound in the runtime phase}) -helper +(eval:error helper) (define-for-syntax (filter-ids ids) (filter identifier? ids)) @@ -2552,7 +2556,7 @@ Like @racket[define-for-syntax], but @racket[expr] must produce as many values as supplied @racket[id]s, and all of the @racket[id]s are bound (at @tech{phase level} 1).} -@defexamples[#:eval (syntax-eval) +@examples[#:eval (syntax-eval) #:once (define-values-for-syntax (foo1 foo2) (values 1 2)) (define-syntax (bar syntax-object) (printf "foo1 is ~a foo2 is ~a\n" foo1 foo2) @@ -2768,14 +2772,14 @@ variable} that has not been defined, the @exnraise[exn:fail:contract]. See also @racket[compile-allow-set!-undefined]. -@defexamples[ +@examples[ (define x 12) (set! x (add1 x)) x (let ([x 5]) (set! x (add1 x)) x) -(set! i-am-not-defined 10) +(eval:error (set! i-am-not-defined 10)) ]} @defform[(set!-values (id ...) expr)]{ @@ -2859,7 +2863,7 @@ other way than as @racket[(#,unquote-id _expr)] or (eval:alts (#,(racket quasiquote) (0 1 2)) `(0 1 2)) (eval:alts (#,(racket quasiquote) (0 (#,unquote-id (+ 1 2)) 4)) `(0 ,(+ 1 2) 4)) (eval:alts (#,(racket quasiquote) (0 (#,unquote-splicing-id (list 1 2)) 4)) `(0 ,@(list 1 2) 4)) -(eval:alts (#,(racket quasiquote) (0 (#,unquote-splicing-id 1) 4)) `(0 ,@1 4)) +(eval:error (eval:alts (#,(racket quasiquote) (0 (#,unquote-splicing-id 1) 4)) `(0 ,@1 4))) (eval:alts (#,(racket quasiquote) (0 (#,unquote-splicing-id 1))) `(0 ,@1)) ] @@ -2922,8 +2926,8 @@ Similar to @racket[quote], but produces a @tech{syntax object} that preserves the @tech{lexical information} and source-location information attached to @racket[datum] at expansion time. -When @racket[#:local] is specified, than all @tech{scopes} in the -syntax object's @tech{lexical information} is preserved. When +When @racket[#:local] is specified, then all @tech{scopes} in the +syntax object's @tech{lexical information} are preserved. When @racket[#:local] is omitted, then the @tech{scope sets} within @racket[datum] are pruned to omit the @tech{scope} for any binding form that appears between the @racket[quote-syntax] form and the diff --git a/pkgs/racket-doc/scribblings/reference/trace.scrbl b/pkgs/racket-doc/scribblings/reference/trace.scrbl index e0f83fc39e..f5eeb393f4 100644 --- a/pkgs/racket-doc/scribblings/reference/trace.scrbl +++ b/pkgs/racket-doc/scribblings/reference/trace.scrbl @@ -1,6 +1,5 @@ #lang scribble/doc -@(require "mz.rkt" (for-label racket/trace) - scribble/eval) +@(require "mz.rkt" (for-label racket/trace)) @(begin (define ev (make-base-eval)) (ev '(require racket/trace)) diff --git a/pkgs/racket-doc/scribblings/reference/values.scrbl b/pkgs/racket-doc/scribblings/reference/values.scrbl index fb7f3d678f..614a0a42bc 100644 --- a/pkgs/racket-doc/scribblings/reference/values.scrbl +++ b/pkgs/racket-doc/scribblings/reference/values.scrbl @@ -31,5 +31,5 @@ the @racket[call-with-values] call. @examples[ (call-with-values (lambda () (values 1 2)) +) -(call-with-values (lambda () 1) (lambda (x y) (+ x y))) +(eval:error (call-with-values (lambda () 1) (lambda (x y) (+ x y)))) ]} diff --git a/pkgs/racket-doc/scribblings/reference/vectors.scrbl b/pkgs/racket-doc/scribblings/reference/vectors.scrbl index 8f8141aa44..9ff98f7df7 100644 --- a/pkgs/racket-doc/scribblings/reference/vectors.scrbl +++ b/pkgs/racket-doc/scribblings/reference/vectors.scrbl @@ -151,8 +151,8 @@ _i)] is the value produced by @racket[(proc _i)]. @note-lib[racket/vector] @(define vec-eval (make-base-eval)) -@(interaction-eval #:eval vec-eval - (require racket/vector)) +@examples[#:hidden #:eval vec-eval + (require racket/vector)] @defproc[(vector-set*! [vec (and/c vector? (not/c immutable?))] [pos exact-nonnegative-integer?] diff --git a/pkgs/racket-doc/scribblings/style/testing.scrbl b/pkgs/racket-doc/scribblings/style/testing.scrbl index e40cd24c5f..c350d6c34f 100644 --- a/pkgs/racket-doc/scribblings/style/testing.scrbl +++ b/pkgs/racket-doc/scribblings/style/testing.scrbl @@ -16,7 +16,7 @@ Most of our collections come with test suites. These tests suites tend to Run the test suites before you commit. To facilitate testing, we urge you to add a @tt{TESTME.txt} file to your collections. Ideally, you may also wish to have a file in this directory that runs the basic tests. See the - @hyperlink["https://github.com/plt/racket/tree/master/collects/2htdp/"]{2htdp}, + @hyperlink["https://github.com/racket/racket/tree/master/collects/2htdp/"]{2htdp}, which is one of the collections with its own testing style. The file should describe where the tests are located, how to run these tests, and what to look for in terms of successes and failures. These files are necessary @@ -30,7 +30,7 @@ After you commit, watch for and read(!) parts: @tt{success} and @tt{failure}. The former is for tests that should succeed now, and the latter is for tests that are currently expected to fail. See the - @hyperlink["https://github.com/plt/racket/tree/master/collects/tests/typed-scheme"]{Typed + @hyperlink["https://github.com/racket/racket/tree/master/collects/tests/typed-scheme"]{Typed Racket testing arrangement} for an example. When you create such @tt{failure} tests, you may wish to disable DrDr's checking like this: @verbatim[#:indent 2]{ diff --git a/pkgs/racket-doc/syntax/scribblings/free-vars.scrbl b/pkgs/racket-doc/syntax/scribblings/free-vars.scrbl index 0077a7b4e3..f5ba88658f 100644 --- a/pkgs/racket-doc/syntax/scribblings/free-vars.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/free-vars.scrbl @@ -5,7 +5,9 @@ @defmodule[syntax/free-vars] -@defproc[(free-vars [expr-stx syntax?] [insp inspector? _mod-decl-insp]) +@defproc[(free-vars [expr-stx syntax?] + [insp inspector? _mod-decl-insp] + [#:module-bound? module-bound? any/c #f]) (listof identifier?)]{ Returns a list of free @racket[lambda]- and @racket[let]-bound @@ -18,3 +20,6 @@ The inspector @racket[insp] is used to disarm @racket[expr-stx] and sub-expressions before extracting identifiers. The default @racket[insp] is the declaration-time inspector of the @racketmodname[syntax/free-vars] module.} + +If @racket[module-bound?] is non-false, the list of free variables also +includes free module-bound identifiers. diff --git a/pkgs/racket-doc/syntax/scribblings/id-table.scrbl b/pkgs/racket-doc/syntax/scribblings/id-table.scrbl index a1ad334f79..3cea9b42f4 100644 --- a/pkgs/racket-doc/syntax/scribblings/id-table.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/id-table.scrbl @@ -118,6 +118,16 @@ the @racket[failure] argument is applied if it is a procedure, or simply returned otherwise. } +@defproc[(free-id-table-ref! [table mutable-free-id-table?] + [id identifier?] + [failure any/c]) + any]{ + +Like @racket[hash-ref!]. + +@history[#:added "6.3.0.6"] +} + @defproc[(free-id-table-set! [table mutable-free-id-table?] [id identifier?] [v any/c]) @@ -134,6 +144,26 @@ Like @racket[hash-set!]. Like @racket[hash-set]. } +@defproc[(free-id-table-set*! [table mutable-free-id-table?] + [id identifier?] + [v any/c] ...) + void?]{ + +Like @racket[hash-set*!]. + +@history[#:added "6.3.0.6"] +} + +@defproc[(free-id-table-set* [table immutable-free-id-table?] + [id identifier?] + [v any/c] ...) + immutable-free-id-table?]{ + +Like @racket[hash-set*]. + +@history[#:added "6.3.0.6"] +} + @defproc[(free-id-table-remove! [table mutable-free-id-table?] [id identifier?]) void?]{ @@ -148,6 +178,30 @@ Like @racket[hash-remove!]. Like @racket[hash-remove]. } +@defproc[(free-id-table-update! [table mutable-free-id-table?] + [id identifier?] + [updater (any/c . -> . any/c)] + [failure any/c + (lambda () (raise (make-exn:fail .....)))]) + void?]{ + +Like @racket[hash-update!]. + +@history[#:added "6.3.0.6"] +} + +@defproc[(free-id-table-update [table immutable-free-id-table?] + [id identifier?] + [updater (any/c . -> . any/c)] + [failure any/c + (lambda () (raise (make-exn:fail .....)))]) + immutable-free-id-table?]{ + +Like @racket[hash-update]. + +@history[#:added "6.3.0.6"] +} + @defproc[(free-id-table-map [table free-id-table?] [proc (-> identifier? any/c any)]) list?]{ @@ -155,6 +209,30 @@ Like @racket[hash-remove]. Like @racket[hash-map]. } +@defproc[(free-id-table-keys [table free-id-table?]) + (listof identifier?)]{ + +Like @racket[hash-keys]. + +@history[#:added "6.3.0.3"] +} + +@defproc[(free-id-table-values [table free-id-table?]) + (listof any/c)]{ + +Like @racket[hash-values]. + +@history[#:added "6.3.0.3"] +} + +@defproc[(in-free-id-table [table free-id-table?]) + sequence?]{ + +Like @racket[in-hash]. + +@history[#:added "6.3.0.3"] +} + @defproc[(free-id-table-for-each [table free-id-table?] [proc (-> identifier? any/c any)]) void?]{ @@ -230,6 +308,10 @@ etc) can be used on bound-identifier tables. [failure any/c (lambda () (raise (make-exn:fail .....)))]) any] +@defproc[(bound-id-table-ref! [table mutable-bound-id-table?] + [id identifier?] + [failure any/c]) + any] @defproc[(bound-id-table-set! [table mutable-bound-id-table?] [id identifier?] [v any/c]) @@ -238,15 +320,41 @@ etc) can be used on bound-identifier tables. [id identifier?] [v any/c]) immutable-bound-id-table?] +@defproc[(bound-id-table-set*! [table mutable-bound-id-table?] + [id identifier?] + [v any/c] ...) + void?] +@defproc[(bound-id-table-set* [table immutable-bound-id-table?] + [id identifier?] + [v any/c] ...) + immutable-bound-id-table?] @defproc[(bound-id-table-remove! [table mutable-bound-id-table?] [id identifier?]) void?] @defproc[(bound-id-table-remove [table immutable-bound-id-table?] [id identifier?]) immutable-bound-id-table?] +@defproc[(bound-id-table-update! [table mutable-bound-id-table?] + [id identifier?] + [updater (any/c . -> . any/c)] + [failure any/c + (lambda () (raise (make-exn:fail .....)))]) + void?] +@defproc[(bound-id-table-update [table immutable-bound-id-table?] + [id identifier?] + [updater (any/c . -> . any/c)] + [failure any/c + (lambda () (raise (make-exn:fail .....)))]) + immutable-bound-id-table?] @defproc[(bound-id-table-map [table bound-id-table?] [proc (-> identifier? any/c any)]) list?] +@defproc[(bound-id-table-keys [table bound-id-table?]) + (listof identifier?)] +@defproc[(bound-id-table-values [table bound-id-table?]) + (listof any/c)] +@defproc[(in-bound-id-table [table bound-id-table?]) + sequence?] @defproc[(bound-id-table-for-each [table bound-id-table?] [proc (-> identifier? any/c any)]) void?] @@ -273,6 +381,11 @@ Like the procedures for free-identifier tables (@racket[make-free-id-table], @racket[free-id-table-ref], etc), but for bound-identifier tables, which use @racket[bound-identifier=?] to compare keys. + +@history[#:changed "6.3.0.3" "Added bound-id-table-keys, bound-id-table-values, in-bound-id-table." + #:changed "6.3.0.6" + @string-append{Added bound-id-table-ref!, bound-id-table-set*, + bound-id-table-set*!, bound-id-table-update!, and bound-id-table-update}] } -@close-eval[id-table-eval] \ No newline at end of file +@close-eval[id-table-eval] diff --git a/pkgs/racket-doc/syntax/scribblings/intdef.scrbl b/pkgs/racket-doc/syntax/scribblings/intdef.scrbl new file mode 100644 index 0000000000..696bd4509e --- /dev/null +++ b/pkgs/racket-doc/syntax/scribblings/intdef.scrbl @@ -0,0 +1,22 @@ +#lang scribble/doc +@(require "common.rkt" (for-label syntax/intdef)) + +@title[#:tag "intdef"]{Internal-Definition Context Helpers} + +@defmodule[syntax/intdef] + +@history[#:added "6.3.0.4"] + +@defproc[(internal-definition-context-track + [intdef-ctx internal-definition-context?] + [stx syntax?]) + syntax?]{ + +Adjusts the @tech[#:doc refman]{syntax properties} of @racket[stx] to +record that parts of @racket[stx] were expanded via +@racket[intdef-ctx]. + +Specifically, the identifiers produced by +@racket[(internal-definition-context-binding-identifiers intdef-ctx)] +are added to the @racket['disappeared-bindings] property of +@racket[stx].} diff --git a/pkgs/racket-doc/syntax/scribblings/name.scrbl b/pkgs/racket-doc/syntax/scribblings/name.scrbl index c9ad9ac6d1..71a8cf0d17 100644 --- a/pkgs/racket-doc/syntax/scribblings/name.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/name.scrbl @@ -8,8 +8,8 @@ @defproc[(syntax-local-infer-name [stx syntax?] [use-local? any/c #t]) any/c]{ Similar to @racket[syntax-local-name], except that @racket[stx] is -checked for an @racket['inferred-name] property that is a symbol -(which overrides any inferred name) or @|void-const|. +checked for an @racket['inferred-name] property +(which overrides any inferred name). If neither @racket[syntax-local-name] nor @racket['inferred-name] produce a name, or if the @racket['inferred-name] property value is @|void-const|, then a name diff --git a/pkgs/racket-doc/syntax/scribblings/syntax.scrbl b/pkgs/racket-doc/syntax/scribblings/syntax.scrbl index 72458c85c8..dfc3018e8d 100644 --- a/pkgs/racket-doc/syntax/scribblings/syntax.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/syntax.scrbl @@ -35,4 +35,6 @@ @include-section["macro-testing.scrbl"] +@include-section["intdef.scrbl"] + @index-section[] diff --git a/pkgs/racket-doc/syntax/scribblings/toplevel.scrbl b/pkgs/racket-doc/syntax/scribblings/toplevel.scrbl index 30f79feb9d..3874194286 100644 --- a/pkgs/racket-doc/syntax/scribblings/toplevel.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/toplevel.scrbl @@ -12,7 +12,7 @@ Expands @racket[stx] as a top-level expression, and evaluates its compile-time portion for the benefit of later expansions. The expander recognizes top-level @racket[begin] expressions, and -interleaves the evaluation and expansion of of the @racket[begin] +interleaves the evaluation and expansion of the @racket[begin] body, so that compile-time expressions within the @racket[begin] body affect later expansions within the body. (In other words, it ensures that expanding a @racket[begin] is the same as expanding separate diff --git a/pkgs/racket-doc/version/version.scrbl b/pkgs/racket-doc/version/version.scrbl index 112d108235..f1bfd22f0e 100644 --- a/pkgs/racket-doc/version/version.scrbl +++ b/pkgs/racket-doc/version/version.scrbl @@ -36,7 +36,7 @@ but may be updated by patches to DrRacket.} Checks the currently available version on the PLT website (@selflink["http://download.racket-lang.org"]) and returns a value that -indicates the current state of the curent installation: +indicates the current state of the current installation: @itemize[ @@ -76,12 +76,12 @@ indicates the current state of the curent installation: utilities for dealing with version strings. Unless explicitly noted, these functions do not handle legacy versions of Racket.} -@defproc[(valid-version? [str string?]) boolean?]{ - Returns @racket[#t] if @racket[str] is a valid Racket version +@defproc[(valid-version? [v any/c]) boolean?]{ + Returns @racket[#t] if @racket[v] is a valid Racket version string, @racket[#f] otherwise.} @defproc[(version->list [str valid-version?]) - (list integer? integer? integer? integer?)]{ + (list/c integer? integer? integer? integer?)]{ Returns a list of four numbers that the given version string represent. @racket[str] is assumed to be a valid version.} @@ -99,7 +99,7 @@ indicates the current state of the curent installation: Returns @racket[#t] if the version that @racket[str] represents is an alpha version. @racket[str] is assumed to be a valid version.} -@defproc[(version->integer [str string?]) (or/c integer? false/c)]{ +@defproc[(version->integer [str string?]) (or/c integer? #f)]{ Converts the version string into an integer. For version @racket["X.YY.ZZZ.WWW"], the result will be @racketvalfont{XYYZZZWWW}. This function works also for legacy Racket versions, by diff --git a/pkgs/racket-index/LICENSE.txt b/pkgs/racket-index/LICENSE.txt index fd82edbca7..3d17c1c0c4 100644 --- a/pkgs/racket-index/LICENSE.txt +++ b/pkgs/racket-index/LICENSE.txt @@ -1,5 +1,5 @@ racket-index -Copyright (c) 2010-2015 PLT Design Inc. +Copyright (c) 2010-2016 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link this package into proprietary diff --git a/pkgs/racket-index/scribblings/main/license.scrbl b/pkgs/racket-index/scribblings/main/license.scrbl index f2984b252f..1b53202392 100644 --- a/pkgs/racket-index/scribblings/main/license.scrbl +++ b/pkgs/racket-index/scribblings/main/license.scrbl @@ -26,7 +26,7 @@ directory for more information. @copyright{ Racket - Copyright (c) 2010-2015 PLT Design Inc. + Copyright (c) 2010-2016 PLT Design Inc. } Racket software includes or extends the following copyrighted material: diff --git a/pkgs/racket-index/scribblings/main/private/manuals.rkt b/pkgs/racket-index/scribblings/main/private/manuals.rkt index 3e74a9d51f..981e8647d0 100644 --- a/pkgs/racket-index/scribblings/main/private/manuals.rkt +++ b/pkgs/racket-index/scribblings/main/private/manuals.rkt @@ -28,7 +28,7 @@ (truncate (/ (caar l) 10))))]) (if sep? (cons (mk-sep lbl) l) l))])))) -(define (get-docs all? tag) +(define (get-docs all? tag #:custom-secs [custom-secs (make-hash)]) (let* ([recs (find-relevant-directory-records (list tag) (if all? 'all-available 'no-user))] [infos (map get-info/full (map directory-record-path recs))] [docs (append-map @@ -55,7 +55,10 @@ ;; Category (let ([the-cat (if (pair? new-cat) (car new-cat) 'unknown)]) - (or (and (or (eq? the-cat 'omit) + (or (and (string? the-cat) + (let ([the-cat-sym (gensym)]) + (hash-ref! custom-secs the-cat the-cat-sym))) + (and (or (eq? the-cat 'omit) (eq? the-cat 'omit-start)) the-cat) (ormap (lambda (sec) @@ -90,7 +93,18 @@ (cdr l))) (define (make-start-page all?) - (let* ([docs (get-docs all? 'scribblings)] + (let* ([custom-secs (make-hash)] + [docs (get-docs all? 'scribblings + #:custom-secs custom-secs)] + [sections+custom + (append-map (λ (sec) + (if (eq? 'library (sec-cat sec)) + (append (for/list ([label (sort (hash-keys custom-secs) + string<=?)]) + (make-sec (hash-ref custom-secs label) label)) + (list sec)) + (list sec))) + sections)] [plain-line (lambda content (list (make-flow (list (make-paragraph content)))))] @@ -151,5 +165,5 @@ renderer part resolve-info))]) (string-ci (car ad) (car bd)))))))]))) - sections)))) + sections+custom)))) (make-delayed-block contents))) diff --git a/pkgs/racket-index/setup/scribble.rkt b/pkgs/racket-index/setup/scribble.rkt index e27f085c50..7026b98f1f 100644 --- a/pkgs/racket-index/setup/scribble.rkt +++ b/pkgs/racket-index/setup/scribble.rkt @@ -162,7 +162,8 @@ (or (not name) (collection-name-element? name)) (and (list? cat) (<= 1 (length cat) 2) - (symbol? (car cat)) + (or (symbol? (car cat)) + (string? (car cat))) (or (null? (cdr cat)) (real? (cadr cat)))) (and (exact-positive-integer? out-count)) diff --git a/pkgs/racket-lib/LICENSE.txt b/pkgs/racket-lib/LICENSE.txt index 9b2aface7f..fda0e79022 100644 --- a/pkgs/racket-lib/LICENSE.txt +++ b/pkgs/racket-lib/LICENSE.txt @@ -1,5 +1,5 @@ racket-lib -Copyright (c) 2010-2015 PLT Design Inc. +Copyright (c) 2010-2016 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link this package into proprietary diff --git a/pkgs/racket-lib/info.rkt b/pkgs/racket-lib/info.rkt index ededc6b1cd..400af92e46 100644 --- a/pkgs/racket-lib/info.rkt +++ b/pkgs/racket-lib/info.rkt @@ -6,6 +6,9 @@ '(("racket-win32-i386-2" #:platform "win32\\i386") ("racket-win32-x86_64-2" #:platform "win32\\x86_64") ("racket-x86_64-linux-natipkg-2" #:platform "x86_64-linux-natipkg") + ("racket-x86_64-macosx-2" #:platform "x86_64-macosx") + ("racket-i386-macosx-2" #:platform "i386-macosx") + ("racket-ppc-macosx-2" #:platform "ppc-macosx") ("db-ppc-macosx" #:platform "ppc-macosx") ("db-win32-i386" #:platform "win32\\i386") ("db-win32-x86_64" #:platform "win32\\x86_64") diff --git a/pkgs/racket-test-core/LICENSE.txt b/pkgs/racket-test-core/LICENSE.txt index 46232662cc..413cec8000 100644 --- a/pkgs/racket-test-core/LICENSE.txt +++ b/pkgs/racket-test-core/LICENSE.txt @@ -1,5 +1,5 @@ racket-test -Copyright (c) 2010-2015 PLT Design Inc. +Copyright (c) 2010-2016 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link this package into proprietary diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index 482e62d849..8275f6468e 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -348,6 +348,28 @@ (test (vector 1110 1111) values in) (check-proc-prop f mk))) +;; Single argument, no post filter, set continuation mark: +(as-chaperone-or-impersonator + ([chaperone-procedure impersonate-procedure + chaperone-procedure** + impersonate-procedure**]) + (let* ([f (lambda (x) (list x (continuation-mark-set-first #f 'the-mark)))] + [in #f] + [mk (lambda (f) + (chaperone-procedure + f + (lambda (x) + (set! in x) + (values 'mark 'the-mark 8 x))))] + [f2 (mk f)]) + (with-continuation-mark 'the-mark + 7 + (test '(110 7) f 110)) + (test #f values in) + (test '(111 8) f2 111) + (test 111 values in) + (check-proc-prop f mk))) + ;; Single argument, post filter on single value: (as-chaperone-or-impersonator ([chaperone-procedure impersonate-procedure @@ -400,6 +422,42 @@ (test (vector 'b '(a c)) values out) (check-proc-prop f mk))) +;; Multiple arguments, post filter on multiple values +;; and set multiple continuation marks: +(as-chaperone-or-impersonator + ([chaperone-procedure impersonate-procedure + chaperone-procedure** + impersonate-procedure**]) + (let* ([f (lambda (x y z) (values y (list x z + (continuation-mark-set-first #f 'the-mark) + (continuation-mark-set-first #f 'the-other-mark))))] + [in #f] + [out #f] + [mk (lambda (f) + (chaperone-procedure + f + (lambda (x y z) + (set! in (vector x y z)) + (values (lambda (y z) + (set! out (vector y z)) + (values y z)) + 'mark 'the-mark 88 + 'mark 'the-other-mark 86 + x y z))))] + [f2 (mk f)]) + (with-continuation-mark 'the-mark + 77 + (with-continuation-mark 'the-other-mark + 79 + (begin + (test-values '(b (a c 77 79)) (lambda () (f 'a 'b 'c))) + (test #f values in) + (test #f values out) + (test-values '(b (a c 88 86)) (lambda () (f2 'a 'b 'c))) + (test (vector 'a 'b 'c) values in) + (test (vector 'b '(a c 88 86)) values out) + (check-proc-prop f mk)))))) + ;; Optional keyword arguments: (as-chaperone-or-impersonator ([chaperone-procedure impersonate-procedure @@ -432,6 +490,43 @@ (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2))) (check-proc-prop f mk))) +;; Optional keyword arguments with mark: +(as-chaperone-or-impersonator + ([chaperone-procedure impersonate-procedure + chaperone-procedure**/kw + impersonate-procedure**/kw]) + (let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b (continuation-mark-set-first #f 'the-mark)))] + [in #f] + [mk (lambda (f) + (chaperone-procedure + f + (lambda (x #:a [a 'nope] #:b [b 'nope]) + (if (and (eq? a 'nope) (eq? b 'nope)) + (values 'mark 'the-mark 8 + x) + (values + 'mark 'the-mark 8 + (append + (if (eq? a 'nope) null (list a)) + (if (eq? b 'nope) null (list b))) + x)))))] + [f2 (mk f)]) + (with-continuation-mark 'the-mark + 7 + (begin + (test '(1 a b 7) f 1) + (test '(1 a b 8) f2 1) + (test '(1 2 b 7) f 1 #:a 2) + (test '(1 2 b 8) f2 1 #:a 2) + (test '(1 a 3 7) f 1 #:b 3) + (test '(1 a 3 8) f2 1 #:b 3) + (test '(1 2 3 7) f 1 #:a 2 #:b 3) + (test '(1 2 3 8) f2 1 #:a 2 #:b 3) + (test 1 procedure-arity f2) + (test 'f object-name f2) + (test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2))) + (check-proc-prop f mk))))) + ;; Optional keyword arguments with result chaperone: (as-chaperone-or-impersonator ([chaperone-procedure impersonate-procedure @@ -502,7 +597,7 @@ (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))) (check-proc-prop f mk))) -;; Required keyword arguments: +;; Required keyword arguments with result chaperone: (as-chaperone-or-impersonator ([chaperone-procedure impersonate-procedure chaperone-procedure**/kw @@ -538,6 +633,46 @@ (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))) (check-proc-prop f mk))) +;; Required keyword arguments with result chaperone and marks: +(as-chaperone-or-impersonator + ([chaperone-procedure impersonate-procedure + chaperone-procedure**/kw + impersonate-procedure**/kw]) + (let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b (continuation-mark-set-first #f 'the-mark)))] + [in #f] + [out #f] + [mk (lambda (f) + (chaperone-procedure + f + (lambda (x #:a [a 'nope] #:b [b 'nope]) + (set! in (list x a b)) + (if (and (eq? a 'nope) (eq? b 'nope)) + x + (values + (lambda (z) (set! out z) z) + 'mark 'the-mark 9 + (append + (if (eq? a 'nope) null (list a)) + (if (eq? b 'nope) null (list b))) + x)))))] + [f2 (mk f)]) + (with-continuation-mark 'the-mark + 7 + (begin + (err/rt-test (f 1)) + (err/rt-test (f2 1)) + (err/rt-test (f 1 #:a 2)) + (err/rt-test (f2 1 #:a 2)) + (test '(1 a 3 7) f 1 #:b 3) + (test '(1 a 3 9) f2 1 #:b 3) + (test '((1 nope 3) (1 a 3 9)) list in out) + (test '(1 2 3 7) f 1 #:a 2 #:b 3) + (test '(1 2 3 9) f2 1 #:a 2 #:b 3) + (test 1 procedure-arity f2) + (test 'f object-name f2) + (test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2))) + (check-proc-prop f mk))))) + (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1)) (err/rt-test ((impersonate-procedure (lambda (x) x) (lambda (y) (values y y))) 1)) (err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y y))) 1)) @@ -1067,11 +1202,15 @@ (test #t chaperone? (mk)) (test #t chaperone? (mk #f)) (test #t chaperone? (mk (lambda (ht) (void)))) + (test #t chaperone? (mk (lambda (ht) (void)) (lambda (ht k) (void)))) + (test #t chaperone? (mk #f (lambda (ht k) (void)))) (err/rt-test (mk (lambda (a b) (void)))) (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue)) (test #t chaperone? (mk prop:blue 'ok)) (test #t chaperone? (mk #f prop:blue 'ok)) - (err/rt-test (mk (lambda (a b) (void)) prop:blue 'ok))) + (test #t chaperone? (mk #f #f prop:blue 'ok)) + (err/rt-test (mk (lambda (a b) (void)) prop:blue 'ok)) + (err/rt-test (mk #f (lambda (a) (void)) prop:blue 'ok))) (for-each (lambda (make-hash) @@ -1335,7 +1474,124 @@ (define ht4 (hash-clear ht2)) (test #t values hit?) (test 0 hash-count ht4)))) - + +;; Check use of equal-key-proc argument: +(as-chaperone-or-impersonator + ([chaperone-hash impersonate-hash] + [chaperone-procedure impersonate-procedure]) + (define saw null) + (define (mk ht) + (chaperone-hash ht + (lambda (h k) + (values k + (lambda (h k v) v))) + (lambda (h k v) + (values k v)) + (lambda (h k) k) + (lambda (h k) k) + #f + (lambda (h k) (set! saw (cons k saw)) k))) + (for ([make-hash (in-list (list make-hash make-weak-hash))]) + (set! saw null) + (define ht (make-hash)) + (define cht (mk ht)) + (hash-set! cht "x" 1) + (test '("x") values saw) + (define new-x (make-string 1 #\x)) + (void (hash-ref cht new-x)) + (test '("x" "x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t)) + (set! saw null) + (hash-set! cht new-x 5) + (test '("x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t)) + (set! saw null) + (hash-remove! cht new-x) + (test '("x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t))) + (unless (eq? chaperone-hash impersonate-hash) + (for ([hash (in-list (list hash))]) + (set! saw null) + (define ht (mk (hash))) + (define ht1 (hash-set ht "x" 1)) + (test '("x") values saw) + (define new-x (make-string 1 #\x)) + (void (hash-ref ht1 new-x)) + (test '("x" "x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t)) + (set! saw null) + (void (hash-set ht1 new-x 5)) + (test '("x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t)) + (set! saw null) + (void (hash-remove ht1 new-x)) + (test '("x" "x") values saw) + (test #t 'new-x (and (member new-x saw) #t))))) + +;; Check that hash table stores given key while +;; coercing key for hashing and equality: +(let () + (define (mk ht) + (impersonate-hash ht + (lambda (h k) + (values k + (lambda (h k v) v))) + (lambda (h k v) + (values k v)) + (lambda (h k) k) + (lambda (h k) k) + #f + (lambda (h k) (inexact->exact (floor k))))) + (for ([make-hash (in-list (list make-hash make-weak-hash))]) + (define ht (make-hash)) + (define cht (mk ht)) + (hash-set! cht 1.2 'one) + (test 'one hash-ref cht 1.3 #f) + (test #f hash-ref ht 1.3 #f) + ;; Trying to find 1.2 in `ht` likely won't work, because the hash code was mangled + (test '(1.2) hash-keys ht) + (test '(1.2) hash-keys cht) + (hash-set! cht 1.3 'two) + (test 'two hash-ref cht 1.2 #f)) + (let-values ([(prop:blue blue? blue-ref) (make-impersonator-property 'blue)]) + (define (mk ht) + (chaperone-hash ht + (lambda (h k) + (values k + (lambda (h k v) v))) + (lambda (h k v) + (values k v)) + (lambda (h k) k) + (lambda (h k) k) + #f + (lambda (h k) (chaperone-vector k + (lambda (vec i v) + (if (= i 1) + (error "ONE") + v)) + (lambda (vec i v) v))))) + (define (one-exn? s) (regexp-match? #rx"ONE" (exn-message s))) + (let () + (define cht (mk (hash))) + (err/rt-test (hash-set cht (vector 1 2) 'vec) one-exn?) + (define ht1 (hash-set cht (vector 1) 'vec)) + (test 'vec hash-ref ht1 (vector 1) #f) + (test #f hash-ref ht1 (vector 2) #f)) + (for ([make-hash (in-list (list make-hash make-weak-hash))]) + (define ht (make-hash)) + (define cht (mk ht)) + (define key (vector 1 2)) + (define key7 (vector 7)) + (hash-set! cht key7 'vec7) + (test 'vec7 hash-ref cht (vector 7) #f) + (test 'vec7 hash-ref ht (vector 7) #f) + (hash-set! ht key 'vec2) + (test 'vec2 hash-ref ht (vector 1 2)) + (err/rt-test (hash-ref cht (vector 1 2) #f) one-exn?) + (test 2 length (hash-keys cht)) ; can extract keys without hashing or comparing + (test 'vec2 hash-ref ht key) + (test 'vec7 hash-ref ht key7)))) + ;; ---------------------------------------- ;; Check broken key impersonator: @@ -1927,7 +2183,7 @@ #:a "x")) ;; ---------------------------------------- -;; Check that importantor transformations are applied for printing: +;; Check that impersonator transformations are applied for printing: (let () (define ht diff --git a/pkgs/racket-test-core/tests/racket/filelib.rktl b/pkgs/racket-test-core/tests/racket/filelib.rktl index 13c337682f..a76c8b8754 100644 --- a/pkgs/racket-test-core/tests/racket/filelib.rktl +++ b/pkgs/racket-test-core/tests/racket/filelib.rktl @@ -181,6 +181,172 @@ (delete-file tempfile) (delete-file (make-lock-file-name tempfile)) +;;---------------------------------------------------------------------- +;; Atomic output + +(define (try-atomic-output fn) + (call-with-output-file* + fn + #:exists 'truncate + (lambda (o) (display "()" o))) + (define ts + (append + ;; Writers + (for/list ([i 10]) + (thread (lambda () + (for ([j 100]) + (call-with-atomic-output-file + fn + (lambda (o tmp-path) + (test (or (path-only fn) (current-directory)) + path-only tmp-path) + (display "(" o) + (flush-output o) + (sync (system-idle-evt)) + (display ")" o))))))) + ;; Readers + (for/list ([i 10]) + (thread (lambda () + (for ([j 100]) + (sync (system-idle-evt)) + (test '() call-with-input-file fn read))))))) + (for-each sync ts) + (delete-file fn)) + +(try-atomic-output (make-temporary-file)) +;; The user's add-on directory should be writable and might be a +;; different filesystem, so try that: +(let ([addon-dir (find-system-path 'addon-dir)]) + (make-directory* addon-dir) + (parameterize ([current-directory addon-dir]) + (try-atomic-output (format "atomic-output-~a" (current-inexact-milliseconds))))) + +;; ---------------------------------------- + +(let ([dir (make-temporary-file "pathlist~a" 'directory)]) + (define parents + (let loop ([dir dir]) + (define-values (base name dir?) (split-path dir)) + (if (path? base) + (append (loop base) (list (path->directory-path dir))) + (list dir)))) + (define (p . args) + (maybe-as-directory + args + (apply build-path dir args))) + (define (maybe-as-directory args p) + (if (regexp-match? #rx"^d" (last args)) + (path->directory-path p) + p)) + (define (touch f) + (call-with-output-file* f void)) + (touch (p "f1")) + (make-directory (p "d1")) + (make-directory (p "d2")) + (touch (p "d1" "f1")) + (touch (p "d2" "f1")) + (touch (p "d2" "f2")) + + (unless (eq? 'windows (system-type)) + (make-file-or-directory-link "d1" (p "l3")) + (make-file-or-directory-link "l3" (p "l4")) + (make-directory (p "d5")) + (make-file-or-directory-link (build-path 'up "d2" "f1") (p "d5" "l5"))) + + (make-directory (p "d6")) + (touch (p "d6" "f1")) + (make-directory (p "d6" "d7")) + (touch (p "d6" "d7" "f1")) + (touch (p "d6" "d7" "f2")) + + (define (check p parents) + (test (append + parents + (list (p "d1") + (p "d1" "f1"))) + pathlist-closure + (list (p "d1"))) + (test (append + parents + (list (p "d1") + (p "d1" "f1") + (p "f1"))) + pathlist-closure + (list (p "d1") + (p "f1"))) + (test (append + parents + (list (p "d1") + (p "d2") + (p "d2" "f2"))) + pathlist-closure + (list (p "d1") + (p "d2")) + #:path-filter (lambda (f) (not (regexp-match? #rx"f1$" f)))) + (test (append + parents + (list (p "d1") + (p "d1" "f1") + (p "d2") + (p "d2" "f2"))) + pathlist-closure + (list (p "d1") + (p "d1" "f1") + (p "d2")) + #:path-filter (lambda (f) (not (regexp-match? #rx"f1$" f)))) + (test (append + parents + (list (p "d6") + (p "d6" "f1"))) + pathlist-closure + (list (p "d6")) + #:path-filter (lambda (f) (not (regexp-match? #rx"d7$" f)))) + (unless (eq? 'windows (system-type)) + (test (append + parents + (list (p "l3"))) + pathlist-closure + (list (p "l3"))) + (test (append + parents + (list (p "l4"))) + pathlist-closure + (list (p "l4"))) + (test (append + parents + (list (p "d5") + (p "d5" "l5"))) + pathlist-closure + (list (p "d5" "l5"))) + (test (append + parents + (list (p "d1") + (p "d1" "f1"))) + pathlist-closure + (list (p "l3")) + #:follow-links? #t) + (test (append + parents + (list (p "d1") + (p "d1" "f1"))) + pathlist-closure + (list (p "l4")) + #:follow-links? #t) + (test (append + parents + (list (p "d2") + (p "d2" "f1"))) + pathlist-closure + (list (p "d5" "l5")) + #:follow-links? #t))) + + (parameterize ([current-directory dir]) + (check (lambda args (maybe-as-directory args (apply build-path args))) null)) + (check p parents) + + + (delete-directory/files dir)) + ;; ---------------------------------------- (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index 33b904889f..1a43c52f12 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/pkgs/racket-test-core/tests/racket/foreign-test.rktl @@ -171,6 +171,11 @@ [c7 _c7_list] [i2 _int])) +(let () + (define-cstruct _posn ([x _int] + [y _int])) + (test #t equal? 'posn posn-tag)) + (define _borl (_union _byte _long)) (define _ic7iorl (_union _ic7i _long)) diff --git a/pkgs/racket-test-core/tests/racket/id-table-test.rktl b/pkgs/racket-test-core/tests/racket/id-table-test.rktl index f824b89c6e..d47d8622bd 100644 --- a/pkgs/racket-test-core/tests/racket/id-table-test.rktl +++ b/pkgs/racket-test-core/tests/racket/id-table-test.rktl @@ -26,6 +26,8 @@ (test 4 bound-id-table-count (make-immutable-bound-id-table alist)) (test 3 free-id-table-count (make-free-id-table alist)) (test 3 free-id-table-count (make-immutable-free-id-table alist)) + (test 3 length (free-id-table-keys (make-immutable-free-id-table alist))) + (test 3 length (free-id-table-values (make-immutable-free-id-table alist))) (let () ;; Test in-dict, iteration methods for immutable id-tables @@ -34,10 +36,18 @@ (define d2 (for/fold ([d (make-immutable-bound-id-table)]) ([(id v) (in-dict d1)]) (dict-set d id (add1 v)))) + ;; Test in-bound-id-table + (define d3 (for/fold ([d (make-immutable-bound-id-table)]) + ([(id v) (in-bound-id-table d1)]) + (dict-set d id (add1 v)))) (test 2 bound-id-table-ref d2 a) (test 3 bound-id-table-ref d2 b) (test 4 bound-id-table-ref d2 b2) - (test 5 bound-id-table-ref d2 b3)) + (test 5 bound-id-table-ref d2 b3) + (test 2 bound-id-table-ref d3 a) + (test 3 bound-id-table-ref d3 b) + (test 4 bound-id-table-ref d3 b2) + (test 5 bound-id-table-ref d3 b3)) (let () ;; Test in-dict, iteration methods for mutable id-tables @@ -46,7 +56,13 @@ (test (+ 1 2 3 4) (lambda () (for/sum ([(id v) (in-dict d1)]) v))) (for ([(id v) (in-dict d1)]) (bound-id-table-set! d1 id (add1 v))) - (test (+ 2 3 4 5) (lambda () (for/sum ([(id v) (in-dict d1)]) v))))) + (test (+ 2 3 4 5) (lambda () (for/sum ([(id v) (in-dict d1)]) v))) + ;; Repeat test with in-bound-id-table + (define d2 (make-bound-id-table alist)) + (test (+ 1 2 3 4) (lambda () (for/sum ([(id v) (in-bound-id-table d2)]) v))) + (for ([(id v) (in-bound-id-table d2)]) + (bound-id-table-set! d2 id (add1 v))) + (test (+ 2 3 4 5) (lambda () (for/sum ([(id v) (in-bound-id-table d2)]) v))))) (let () ;; contains-same? : (listof x) (listof x) -> boolean @@ -91,6 +107,10 @@ contains-same? (list 2 4) (bound-id-table-map table (lambda (x y) y))) + (test #t + contains-same? + (list 2 4) + (bound-id-table-values table)) (test #t contains-same? (list 2 4) @@ -133,6 +153,10 @@ contains-same? (list 2 4) (free-id-table-map table (lambda (x y) y))) + (test #t + contains-same? + (list 2 4) + (free-id-table-values table)) (test #t contains-same? (list 2 4) @@ -181,6 +205,10 @@ contains-same? (list 1 2 3 4) (bound-id-table-map table (lambda (x y) y))) + (test #t + contains-same? + (list 1 2 3 4) + (bound-id-table-values table)) (test #t contains-same? (list 1 2 3 4) @@ -223,6 +251,10 @@ contains-same? (list 2 4) (free-id-table-map table (lambda (x y) y))) + (test #t + contains-same? + (list 2 4) + (free-id-table-values table)) (test #t contains-same? (list 2 4) @@ -334,6 +366,64 @@ )) +;; Tests for id-table-keys +(let () + ;; contains-same-keys? : (listof id) (listof id) -> boolean + (define (contains-same-keys? l1 l2 id=?) + (and (andmap (lambda (x) (member x l2 id=?)) l1) + (andmap (lambda (x) (member x l1 id=?)) l2) + #t)) + + (test #t + contains-same-keys? + (list #'x #'y) + (free-id-table-keys + (make-immutable-free-id-table + (list (cons #'x 0) (cons #'x 1) (cons #'y 2)))) + free-identifier=?) + (test #t + contains-same-keys? + (list #'x #'y) + (bound-id-table-keys + (make-immutable-bound-id-table + (list (cons #'x 0) (cons #'x 1) (cons #'y 2)))) + bound-identifier=?)) + +;; Tests for id-table-set*, set*!, update, update!, ref! +(let () + (define table (make-bound-id-table)) + (define table2 (make-immutable-bound-id-table)) + (define x0 #'x) + (define x1 ((make-syntax-introducer) x0)) + (define y0 #'y) + (define y1 ((make-syntax-introducer) y0)) + + (test 0 bound-id-table-ref! table x0 0) + (test 1 bound-id-table-ref! table x1 1) + (test 0 bound-id-table-ref table x0) + (test 1 bound-id-table-ref (bound-id-table-update table2 y0 add1 0) y0) + (test 1 bound-id-table-ref (bound-id-table-set* table2 y0 0 y1 1) y1) + (test (void) bound-id-table-set*! table y0 1 y1 5) + (test (void) bound-id-table-update! table y0 add1 0) + (test 2 bound-id-table-ref table y0)) + +(let () + (define table (make-free-id-table)) + (define table2 (make-immutable-free-id-table)) + (define x0 #'x) + (define x1 #'x1) + (define y0 #'y) + (define y1 #'y1) + + (test 0 free-id-table-ref! table x0 0) + (test 1 free-id-table-ref! table x1 1) + (test 0 free-id-table-ref table x0) + (test 1 free-id-table-ref (free-id-table-update table2 y0 add1 0) y0) + (test 1 free-id-table-ref (free-id-table-set* table2 y0 0 y1 1) y1) + (test (void) free-id-table-set*! table y0 1 y1 5) + (test (void) free-id-table-update! table y0 add1 0) + (test 2 free-id-table-ref table y0)) + (define-syntax name-for-boundmap-test 'dummy) (define-syntax alias-for-boundmap-test (make-rename-transformer #'name-for-boundmap-test)) (define table (make-free-id-table)) diff --git a/pkgs/racket-test-core/tests/racket/list.rktl b/pkgs/racket-test-core/tests/racket/list.rktl index cc185354c4..51eb4b4452 100644 --- a/pkgs/racket-test-core/tests/racket/list.rktl +++ b/pkgs/racket-test-core/tests/racket/list.rktl @@ -422,6 +422,42 @@ (test expected length+sum (shuffle l))) (when (pair? l) (loop (cdr l)))) +;; ---------- combinations ---------- +(let () + (define (combnamespace (build-path tmp "b.rkt"))) + (test #t + 'mapped-symbols + (and (for/and ([name '(a b c)]) + (member name (namespace-mapped-symbols ns))) + #t)) + (delete-directory/files tmp)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(module exports-x*-as-x racket/base + (define x* 5) + (provide (rename-out [x* x]))) + +(module exports-x**-as-x racket/base + (require 'exports-x*-as-x) + (define x* 5) + (define-syntax-rule (x**) x*) + (provide (rename-out [x x***]) + (rename-out [x** x]))) + +(require 'exports-x**-as-x) +(test 5 'five (x)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check 'module-body-context-simple? and 'module-body-...context properties + +(define (check-module-body-context-properties with-kar?) + (define m (expand `(module m racket/base + ,@(if with-kar? + `((require (rename-in racket/base [car kar]))) + null) + (define inside 7)))) + + (test (not with-kar?) syntax-property m 'module-body-context-simple?) + + (define i (syntax-property m 'module-body-context)) + (define o (syntax-property m 'module-body-inside-context)) + + (test #t syntax? i) + (test #t syntax? o) + + (test car eval-syntax (datum->syntax i 'car)) + (test 'inside cadr (identifier-binding (datum->syntax i 'inside))) + (test #f identifier-binding (datum->syntax o 'inside)) + (test (if with-kar? 'car #f) + 'kar-binding + (let ([v (identifier-binding (datum->syntax i 'kar))]) + (and v (cadr v))))) + +(check-module-body-context-properties #f) +(check-module-body-context-properties #t) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/number.rktl b/pkgs/racket-test-core/tests/racket/number.rktl index d6dd69800d..99ba500a1d 100644 --- a/pkgs/racket-test-core/tests/racket/number.rktl +++ b/pkgs/racket-test-core/tests/racket/number.rktl @@ -3,6 +3,8 @@ (Section 'numbers) +(require racket/extflonum racket/random racket/list) + (test #f number? 'a) (test #f complex? 'a) (test #f real? 'a) @@ -566,6 +568,14 @@ (test 0.0f0 expt -0.9999f0 (expt 2 5000)) (test -0.0f0 expt -0.9999f0 (add1 (expt 2 5000))) +(test +inf.0 expt -4.0 (expt 2 5000)) +(test -inf.0 expt -4.0 (add1 (expt 2 5000))) +(test +inf.f expt -4.0f0 (expt 2 5000)) +(test -inf.f expt -4.0f0 (add1 (expt 2 5000))) +;; exponent large enough to overflow singles, but not doubles +(test +inf.f expt -4.0f0 (lcm (exact-round -1.7976931348623151e+308))) +(test -inf.f expt -4.0f0 (add1 (lcm (exact-round -1.7976931348623151e+308)))) + (define (inf-non-real? x) (and (not (real? x)) (= +inf.0 (abs (imag-part x))) @@ -1607,6 +1617,9 @@ (test +inf.0 magnitude 0.0+inf.0i) (test +nan.0 magnitude +nan.0+inf.0i) (test +nan.0 magnitude +inf.0+nan.0i) +(test +inf.f magnitude 3.0f0-inf.fi) +(test +nan.f magnitude 3.0f0+nan.fi) +(test 3.0f0 magnitude 3.0f0+0.0f0i) (test 0 angle 1) (test 0 angle 1.0) @@ -2401,24 +2414,64 @@ (err/rt-test (string->number "1" "1")) (err/rt-test (string->number 1 1)) +(define (string->extfl-number s) + (read (open-input-string s))) + +;; Test inexacts with large exponents +(test 0.0 string->number "0e401") +(test 0.0 string->number "0e6001") +(test -0.0 string->number "-0e401") +(test -0.0 string->number "-0e6001") +(test +inf.0 string->number "0.1e401") +(test +inf.0 string->number "0.1e6001") +(test -inf.0 string->number "-0.1e401") +(test -inf.0 string->number "-0.1e6001") +(test 0.0 string->number (string-append "0." (make-string 400 #\0) "0e400")) +(test 0.0 string->number (string-append "0." (make-string 8000 #\0) "0e8000")) +(test #t extflonum? (string->extfl-number (string-append "0." (make-string 400 #\0) "0t9000"))) +(test -0.0 string->number (string-append "-0." (make-string 400 #\0) "0e400")) +(test -0.0 string->number (string-append "-0." (make-string 8000 #\0) "0e8000")) +(test #t extflonum? (string->extfl-number (string-append "-0." (make-string 400 #\0) "0t9000"))) +(test 0.1 string->number (string-append "0." (make-string 400 #\0) "1e400")) +(test 0.1 string->number (string-append "0." (make-string 8000 #\0) "1e8000")) +(test 1.0e-101 string->number (string-append "0." (make-string 8000 #\0) "1e7900")) +(test +inf.0 string->number (string-append "0." (make-string 400 #\0) "1e1000")) +(test -inf.0 string->number (string-append "-0." (make-string 400 #\0) "1e1000")) +(test +inf.0 string->number (string-append "0." (make-string 8000 #\0) "1e8400")) +(test -inf.0 string->number (string-append "-0." (make-string 8000 #\0) "1e8400")) +(test #t extflonum? (string->extfl-number (string-append "0." (make-string 8000 #\0) "1t8400"))) +(test #t extflonum? (string->extfl-number (string-append "-0." (make-string 8000 #\0) "1t8400"))) +(test #f string->number (string-append "-0." (make-string 8000 #\0) "9e10000") 8) +(test #f string->number (string-append "0." (make-string 8000 #\0) "e1008") 8) + (test #t andmap (lambda (x) (and (>= x 0) (< x 10))) (map random '(10 10 10 10))) (test (void) random-seed 5) (test (begin (random-seed 23) (list (random 10) (random 20) (random 30))) 'random-seed-same (begin (random-seed 23) (list (random 10) (random 20) (random 30)))) +(test (begin (random-seed 23) (list (random 10 20) (random 20 30) (random 30 40))) + 'random-seed-same2 + (begin (random-seed 23) (list (random 10 20) (random 20 30) (random 30 40)))) +(test (begin (random-seed 23) (list (random-ref '(1 2 3)) (random-ref '(4 5 6)) (random-ref '(7 8 9)))) + 'random-seed-same3 + (begin (random-seed 23) (list (random-ref '#(1 2 3)) (random-ref '#(4 5 6)) (random-ref '#(7 8 9))))) +(test (begin (random-seed 23) (list (random-ref "123") (random-ref "123") (random-ref "123"))) + 'random-seed-same4 + (begin (random-seed 23) (list (random-ref "123") (random-ref "123") (random-ref "123")))) (arity-test random-seed 1 1) -(arity-test random 0 2) +(arity-test random 0 3) (err/rt-test (random-seed "apple")) (err/rt-test (random-seed 4.5)) (err/rt-test (random-seed -1)) (err/rt-test (random-seed (expt 2 31))) (err/rt-test (random-seed big-num)) -(err/rt-test (random "apple")) +(err/rt-test (random 'apple)) (err/rt-test (random 0)) (err/rt-test (random -6)) (err/rt-test (random 4294967088)) (err/rt-test (random (expt 2 32))) (err/rt-test (random big-num)) +(err/rt-test (random 10 5)) (random-seed 101) (define x (list (random 10) (random 20) (random 30))) @@ -2458,6 +2511,25 @@ (test 5353 random 10000) (test 8571 random 10000) (test 9729 random 10000)) +(parameterize ([current-pseudo-random-generator + (vector->pseudo-random-generator + #(3620087466 1904163406 3177592043 1406334318 257151704 3090455638))]) + (test 1 random-ref '(1 2 3 4 5)) + (test 6 random-ref '#(7 6 8 9 10)) + (test #\a random-ref "abcde")) +(parameterize ([current-pseudo-random-generator + (vector->pseudo-random-generator + #(3620087466 1904163406 3177592043 1406334318 257151704 3090455638))]) + (test '(1) random-sample '(1 2 3 4 5) 1) + (test '(5 5 5) random-sample '(1 2 3 4 5) 3) + (test '(1 4 3) random-sample '(1 2 3 4 5) 3 #:replacement? #f) + ;; distribution is uniform + (test '(100077 100479 100375 99943 99869 100055 100482 99979 99405 99336) + values ; to avoid the whole pre-`length` list being printed if test fails + (map length (group-by values + (apply append (for/list ([i 10000]) + (random-sample (range 10) 100))))))) + (test #t = 0 0) (test #f = 0 (expt 2 32)) @@ -2724,6 +2796,8 @@ (test (- (sub1 (expt 2 256))) string->number "-ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" 16) (test #f string->number "144r" 10) (err/rt-test (string->number "10" 30)) +(test 0.0 string->number "0e401") +(test 0.0 string->number "00000.00000e9999999999") (define (q-test quotient) (test 0 quotient 0 12345678909876532341) @@ -3160,9 +3234,107 @@ (test #t list? (filter n-digit-has-nth-root? (build-list 5000 (lambda (x) (+ x 1)))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; exact->inexact precision (thanks to Neil Toronto) +;; exact->inexact precision on bignums (round-trip and proper rounding) -(require racket/extflonum) +(define max-53-bit-number (sub1 (arithmetic-shift 1 53))) + +(define (check-conversion 53-bit-number) + ;; Any 53-bit integer fits in a 64-bit floating point: + (unless (= 53-bit-number (inexact->exact (exact->inexact 53-bit-number))) + (error 'random-exact->inexact "round-trip failed ~s" 53-bit-number)) + + ;; The same holds if we shift by up to (- 1023 52): + (define (check-shift p) + (define n2 (arithmetic-shift 53-bit-number p)) + (unless (= n2 (inexact->exact (exact->inexact n2))) + (error 'random-exact->inexact "round-trip of shifted failed ~s" n2))) + (check-shift (- 1023 52)) + (for ([i 10]) + (check-shift (random (- 1023 52)))) + + ;; The same holds if we shift by up to (- -1022 52): + (define (check-div p) + (define n2 (/ 53-bit-number (arithmetic-shift 1 (- p)))) + (unless (= n2 (inexact->exact (exact->inexact n2))) + (error 'random-exact->inexact "round-trip of shifted failed ~s" n2))) + (check-div (- (+ 1022 52))) + (for ([i 10]) + (check-div (- (random (+ 1022 52))))) + + ;; Helper for checking rounding: + (define (check-random-pairs check-shift-pair) + (check-shift-pair 1 0) + (check-shift-pair (- 1023 52 1) 0) + (check-shift-pair 1 (- 1023 52 2)) + (for ([i 10]) + (define zeros (add1 (random (- 1023 52 3)))) + (define extra (random (- 1023 52 1 zeros))) + (check-shift-pair zeros extra))) + + ;; If we add a zero bit and then a non-zero bit anywhere later, + ;; conversion to inexact should round down. + (define (check-shift-plus-bits-to-truncate num-zeros extra-p) + (define n2 (arithmetic-shift + (bitwise-ior (arithmetic-shift 53-bit-number (add1 num-zeros)) + 1) + extra-p)) + (define n3 (inexact->exact (exact->inexact n2))) + (unless (= n3 (arithmetic-shift 53-bit-number (+ num-zeros 1 extra-p))) + (error 'random-exact->inexact "truncating round failed ~s" n2))) + (check-random-pairs check-shift-plus-bits-to-truncate) + + ;; If we add a one bit and then a non-zero bit anywhere later, + ;; conversion to inexact should round up. + (unless (= 53-bit-number max-53-bit-number) + (define (check-shift-plus-bits-to-up num-one-then-zeros extra-p) + (define n2 (arithmetic-shift + (bitwise-ior (arithmetic-shift + (bitwise-ior (arithmetic-shift 53-bit-number 1) + 1) + num-one-then-zeros) + 1) + extra-p)) + (define n3 (inexact->exact (exact->inexact n2))) + (unless (= n3 (arithmetic-shift (add1 53-bit-number) (+ num-one-then-zeros 1 extra-p))) + (error 'random-exact->inexact "round up failed ~s" n2))) + (check-random-pairs check-shift-plus-bits-to-up)) + + ;; If we add a one bit and then only zero bits, + ;; conversion to inexact should round to even. + (unless (= 53-bit-number max-53-bit-number) + (define (check-shift-plus-bits-to-even num-one-then-zeros extra-p) + (define n2 (arithmetic-shift + (bitwise-ior (arithmetic-shift 53-bit-number 1) + 1) + (+ num-one-then-zeros extra-p))) + (define n3 (inexact->exact (exact->inexact n2))) + (unless (= n3 (arithmetic-shift (if (even? 53-bit-number) + 53-bit-number + (add1 53-bit-number)) + (+ num-one-then-zeros 1 extra-p))) + (error 'random-exact->inexact "round to even failed ~s" n2))) + (check-random-pairs check-shift-plus-bits-to-even))) + +(check-conversion max-53-bit-number) +(for ([i 100]) + (check-conversion + ;; Random 53-bit number: + (+ (arithmetic-shift 1 52) + (arithmetic-shift (random (expt 2 24)) 24) + (random (expt 2 28))))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check roun-to-even of rationale conversion (thanks to Robby) + +(let () + (define l (floating-point-bytes->real #"\x1a\xd8\x9c\x17\x21\x2e\xfd\x25" #t)) + (define r (floating-point-bytes->real #"\x1a\xd8\x9c\x17\x21\x2e\xfd\x26" #t)) + (test r exact->inexact (/ (+ (inexact->exact l) + (inexact->exact r)) + 2))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; exact->inexact precision (thanks to Neil Toronto) (define (check start end exact-> ->exact >=?) (define delta (/ (- end start) 300)) diff --git a/pkgs/racket-test-core/tests/racket/numstrs.rktl b/pkgs/racket-test-core/tests/racket/numstrs.rktl index bf01770a18..061229bf23 100644 --- a/pkgs/racket-test-core/tests/racket/numstrs.rktl +++ b/pkgs/racket-test-core/tests/racket/numstrs.rktl @@ -53,6 +53,10 @@ (-0.0 "-1#e-10000000000000000000000000000000") (1e-134 "0.00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001") + (-0.0 "-632.3206524753840966914228247597079196012717570277972845484e-399") + (1e-300 + ;; check e->i only after division is performed + "#i500000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000/500000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000") (10.0 "1#") (10.0 "1#e0") (10.0 "1####e-3") diff --git a/pkgs/racket-test-core/tests/racket/object.rktl b/pkgs/racket-test-core/tests/racket/object.rktl index 1a7d6941e4..db12dd35cf 100644 --- a/pkgs/racket-test-core/tests/racket/object.rktl +++ b/pkgs/racket-test-core/tests/racket/object.rktl @@ -2153,6 +2153,53 @@ (class c% (super-new) (field [x 0]))) exn:fail?) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check for Check-Syntax support for a `struct` +;; form in `class`, which depends on proper handling +;; of bindings from an internal-definition context + +(let () + (define binds null) + (define refs null) + + (define (inspect stx) + (when (and (identifier? stx) + (eq? 's (syntax-e stx))) + (set! refs (cons stx refs))) + (cond + [(syntax? stx) + (check stx 'disappeared-binding) + (inspect (syntax-e stx)) + (inspect (syntax-property stx 'origin))] + [(pair? stx) + (inspect (car stx)) + (inspect (cdr stx))])) + + (define (check stx prop) + (define v (syntax-property stx prop)) + (when (and v (get-s v)) + (set! binds (cons (get-s v) binds)))) + + (define (get-s e) + (or (and (identifier? e) + (eq? 's (syntax-e e)) + e) + (and (pair? e) + (or (get-s (car e)) + (get-s (cdr e)))) + (and (syntax? e) + (get-s (syntax-e e))))) + + (inspect (expand #'(module m racket/base + (require racket/class) + (class object% + (define-struct s ()) + s)))) + + (for ([r (in-list refs)]) + (test #t 'has-binding-match? (for/or ([b (in-list binds)]) + (free-identifier=? r b))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index 43a0abae7f..df465a98f8 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -9,7 +9,10 @@ racket/unsafe/undefined racket/unsafe/ops compiler/zo-parse - compiler/zo-marshal) + compiler/zo-marshal + ;; `random` from `racket/base is a Racket function, which makes + ;; compilation less predictable than a primitive + (only-in '#%kernel random)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1494,6 +1497,12 @@ '(lambda (x y) (car x) (unbox y) (eq? x y))) (test-comp '(lambda (x) (car x) #f) '(lambda (x) (car x) (eq? x (box 0)))) +(test-comp '(lambda (x) (car x) #f) + '(lambda (x) (car x) (eq? (begin (newline) x) (box 0))) + #f) +(test-comp '(lambda (x) (car x) #f) + '(lambda (x) (car x) (eq? x (begin (newline) (box 0)))) + #f) (test-comp '(lambda (w) (car w) (mcar w)) '(lambda (w) (car w) (mcar w) (random))) @@ -1528,6 +1537,32 @@ (test-comp '(lambda () (begin (random 1) (random 2))) '(lambda () (cdr (cons (random 1) (random 2))))) +(test-comp '(lambda () (begin (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin (car (cons (random 1) (random 2))) (random 3) (random 4)))) ; +(test-comp '(lambda () (begin (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin (cdr (cons (random 1) (random 2))) (random 3) (random 4)))) +(test-comp '(lambda () (begin (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin (random 1) (car (cons (random 2) (random 3))) (random 4)))) ; +(test-comp '(lambda () (begin (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin (random 1) (cdr (cons (random 2) (random 3))) (random 4)))) +(test-comp '(lambda () (begin (random 1) (random 2) (begin0 (random 3) (random 4)))) + '(lambda () (begin (random 1) (random 2) (car (cons (random 3) (random 4)))))) +(test-comp '(lambda () (begin (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin (random 1) (random 2) (cdr (cons (random 3) (random 4)))))) + +(test-comp '(lambda () (begin0 (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin0 (car (cons (random 1) (random 2))) (random 3) (random 4)))) +(test-comp '(lambda () (begin0 (begin (random 1) (random 2)) (random 3) (random 4))) + '(lambda () (begin0 (cdr (cons (random 1) (random 2))) (random 3) (random 4)))) +(test-comp '(lambda () (begin0 (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin0 (random 1) (car (cons (random 2) (random 3))) (random 4)))) ; +(test-comp '(lambda () (begin0 (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin0 (random 1) (cdr (cons (random 2) (random 3))) (random 4)))) +(test-comp '(lambda () (begin0 (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin0 (random 1) (random 2) (car (cons (random 3) (random 4)))))) ; +(test-comp '(lambda () (begin0 (random 1) (random 2) (random 3) (random 4))) + '(lambda () (begin0 (random 1) (random 2) (cdr (cons (random 3) (random 4)))))) + (test-comp '(lambda (w) (begin (random) w)) '(lambda (w) @@ -1890,6 +1925,28 @@ (define (g y) (+ y 1)))) + +(test-comp '(let () + (define (f x) + (procedure-specialize + (lambda (y) (+ x y)))) + ((f 10) 12)) + '22) + +(test-comp '(let () + (define (f x) + (procedure-specialize + (lambda (y) (+ x y)))) + (procedure? (f 10))) + '#t) + +(test-comp '(let ([f (procedure-specialize + (lambda (y) (+ 1 y)))]) + (list f (procedure-arity-includes? f 1))) + '(let ([f (procedure-specialize + (lambda (y) (+ 1 y)))]) + (list f #t))) + (test-comp '(values 10) 10) (test-comp '(let ([x (values 10)]) @@ -3572,6 +3629,30 @@ (set! f 0)) #f) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that the type information is shifted in the +;; right direction while inlining. +;; The first example triggered a bug in 6.3. + +(test-comp '(let ([zz (lambda (x) (lambda (y) 0))]) + (lambda (a b c) + ((zz (let ([loop (lambda () 0)]) loop)) (car a)) + (list c (pair? c)))) + '(let ([zz (lambda (x) (lambda (y) 0))]) + (lambda (a b c) + ((zz (let ([loop (lambda () 0)]) loop)) (car a)) + (list c #t))) + #f) + +(test-comp '(let ([zz (lambda (x) (lambda (y) 0))]) + (lambda (a b c) + ((zz (let ([loop (lambda () 0)]) loop)) (car a)) + (list a (pair? a)))) + '(let ([zz (lambda (x) (lambda (y) 0))]) + (lambda (a b c) + ((zz (let ([loop (lambda () 0)]) loop)) (car a)) + (list a #t)))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check that the unused continuations are removed @@ -4122,9 +4203,9 @@ (test-values '(-100001.0t0 100001.0t0) tail))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Check for corect fixpoint calculation when lifting +;; Check for correct fixpoint calculation when lifting -;; This test is especilly fragile. It's a minimized(?) variant +;; This test is especially fragile. It's a minimized(?) variant ;; of PR 12910, where just enbought `with-continuation-mark's ;; are needed to thwart inlining, and enough functions are ;; present in the right order to require enough fixpoint @@ -5010,6 +5091,27 @@ (dup rep)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check specialization with a capturing lambda: + +(let () + (define (f x) + (procedure-specialize + (lambda (y) + (lambda () (+ x y))))) + (set! f f) + (test 11 ((f 10) 1))) + + +(let () + (define (f x) + (set! x (add1 x)) + (procedure-specialize + (lambda (y) + (lambda () (+ x y))))) + (set! f f) + (test 12 ((f 10) 1))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/phantom-bytes.rkt b/pkgs/racket-test-core/tests/racket/phantom-bytes.rkt new file mode 100644 index 0000000000..9e656655ac --- /dev/null +++ b/pkgs/racket-test-core/tests/racket/phantom-bytes.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +;; An extra test of phantom bytes. + +(define (make-one) + (make-phantom-bytes (expt 2 29))) + +(define pbs (list (make-one))) + +(define (check) + (unless (> (current-memory-use) (* (length pbs) + (expt 2 29))) + (error "failed")) + (for ([pb (in-list pbs)]) + (set-phantom-bytes! pb 0)) + (unless (< (current-memory-use) (expt 2 29)) + (error "failed after zeros:" (current-memory-use))) + (for ([pb (in-list pbs)]) + (set-phantom-bytes! pb (expt 2 29))) + (unless (> (current-memory-use) (* (length pbs) + (expt 2 29))) + (error "failed after restore:" (current-memory-use)))) + +(check) +(collect-garbage) +(check) + +(define mem (make-bytes (* 250 1024 1024))) +(check) +(collect-garbage) +(check) +(set! pbs (cons (make-one) pbs)) +(check) +(collect-garbage) +(check) +(collect-garbage) +(check) + +(void (bytes-length mem)) + +'ok + +(module test racket/base + (require compiler/find-exe + racket/system) + + (define exe (find-exe)) + (unless (system* exe "-l" "tests/racket/phantom-bytes") + (error "run failed")) + + ;; Also try in incremental mode + (void (putenv "PLT_INCREMENTAL_GC" "yes")) + (unless (system* exe "-l" "tests/racket/phantom-bytes") + (error "run failed"))) diff --git a/pkgs/racket-test-core/tests/racket/place-utils.rkt b/pkgs/racket-test-core/tests/racket/place-utils.rkt index ec2ee243df..2f362468b1 100644 --- a/pkgs/racket-test-core/tests/racket/place-utils.rkt +++ b/pkgs/racket-test-core/tests/racket/place-utils.rkt @@ -86,4 +86,11 @@ #'(time body ...) |# ])) + +(module place-test-submod racket/base + (require racket/place) + (provide p) + (define (p x) + (place-channel-get (place/context ch + (place-channel-put ch x))))) diff --git a/pkgs/racket-test-core/tests/racket/place.rktl b/pkgs/racket-test-core/tests/racket/place.rktl index 8dab0d0c4e..f8bcb705e1 100644 --- a/pkgs/racket-test-core/tests/racket/place.rktl +++ b/pkgs/racket-test-core/tests/racket/place.rktl @@ -102,4 +102,8 @@ (test (not (place-enabled?)) place-message-allowed? (cons v 1)) (test (not (place-enabled?)) place-message-allowed? (vector v))) + +(require (submod "place-utils.rkt" place-test-submod)) +(test 0 p 0) + (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/port.rktl b/pkgs/racket-test-core/tests/racket/port.rktl index 77a06e6091..d53324ace8 100644 --- a/pkgs/racket-test-core/tests/racket/port.rktl +++ b/pkgs/racket-test-core/tests/racket/port.rktl @@ -888,6 +888,24 @@ (delete-file path)) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check reader error-message formatting for a struct port + +(let () + (define-struct wrapper (other port) + #:property prop:input-port 1) + (err/rt-test + (read (wrapper #f + (make-input-port "wrapped" + (lambda (bstr) + (bytes-set! bstr 0 (char->integer #\))) + 1) + (lambda (bstr d evt) + (bytes-set! bstr 0 (char->integer #\))) + 1) + void))) + exn:fail:read?)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/read.rktl b/pkgs/racket-test-core/tests/racket/read.rktl index 8348d7783e..67f79a2b08 100644 --- a/pkgs/racket-test-core/tests/racket/read.rktl +++ b/pkgs/racket-test-core/tests/racket/read.rktl @@ -2,7 +2,7 @@ (load-relative "loadtest.rktl") (Section 'reading) -(define readstr +(define core-readstr (lambda (s) (let* ([o (open-input-string s)] [read (lambda () (read o))]) @@ -12,6 +12,40 @@ last (loop v))))))) +(define (readstr s) + (if (current-readtable) + (core-readstr s) + ;; Try using a readtable that behaves the same as the default, + ;; since that triggers some different paths in the reader: + (let* ([normal (with-handlers ([exn:fail? values]) + (core-readstr s))] + [c-normal (adjust-result-to-compare normal)] + [rt (adjust-result-to-compare + (with-handlers ([exn:fail? values]) + (parameterize ([current-readtable (make-readtable (current-readtable))]) + (core-readstr s))))]) + (if (equal? c-normal rt) + (if (exn? normal) + (raise normal) + normal) + (list "different with readtable" s c-normal rt))))) + +(require racket/extflonum) + +(define (adjust-result-to-compare v) + ;; Make results from two readstrs comparable + (cond + [(hash? v) + (for/fold ([ht (hash)]) ([(k hv) (in-hash v)]) + (hash-update ht + (if (eq? k v) 'SELF k) + (lambda (vht) + (hash-set vht hv #t)) + (hash)))] + [(exn? v) (exn-message v)] + [(extflonum? v) (format "~s" v)] + [else v])) + (define readerrtype (lambda (x) x)) @@ -54,6 +88,9 @@ (err/rt-test (readstr "(8 . 9 . ]") exn:fail:read?) (err/rt-test (readstr "(8 . 9 . 1 . )") exn:fail:read?) (err/rt-test (readstr "(8 . 9 . 1 . 10)") exn:fail:read?) +(err/rt-test (readstr "(8 . 9 . #;1)") exn:fail:read?) +(err/rt-test (readstr "(8 . 9 . ;\n)") exn:fail:read?) +(err/rt-test (readstr "(8 . 9 . #|x|#)") exn:fail:read?) (let ([w-suffix (lambda (s) @@ -857,7 +894,31 @@ (err/rt-test (read (make-p (list #"|x" a-special #"y|") (lambda (x) 1) void)) exn:fail:read:non-char?)) (run-delim-special a-special) (run-delim-special special-comment) +(parameterize ([current-readtable (make-readtable #f)]) + (run-delim-special special-comment)) +(require racket/flonum + racket/fixnum) + +(define (run-comment-special) + (test (list 5) read (make-p (list #"(" special-comment #"5)") (lambda (x) 1) void)) + (test (list 5) read (make-p (list #"(5" special-comment #")") (lambda (x) 1) void)) + (test (cons 1 5) read (make-p (list #"(1 . " special-comment #"5)") (lambda (x) 1) void)) + (test (cons 1 5) read (make-p (list #"(1 . 5" special-comment #")") (lambda (x) 1) void)) + (err/rt-test (read (make-p (list #"(1 . " special-comment #")") (lambda (x) 1) void)) exn:fail:read?) + (test (list 2 1 5) read (make-p (list #"(1 . 2 . " special-comment #"5)") (lambda (x) 1) void)) + (test (list 2 1 a-special 5) read (make-p (list #"(1 . 2 ." a-special #"5)") (lambda (x) 1) void)) + (test (list 2 1 5) read (make-p (list #"(1 . " special-comment #"2 . 5)") (lambda (x) 1) void)) + (test (list 2 1 5) read (make-p (list #"(1 . 2 " special-comment #" . 5)") (lambda (x) 1) void)) + (test (vector 1 2 5) read (make-p (list #"#(1 2 " special-comment #"5)") (lambda (x) 1) void)) + (test (flvector 1.0) read (make-p (list #"#fl(1.0 " special-comment #")") (lambda (x) 1) void)) + (test (fxvector 1) read (make-p (list #"#fx(1 " special-comment #")") (lambda (x) 1) void)) + (err/rt-test (read (make-p (list #"#fl(1.0 " a-special #")") (lambda (x) 1) void)) exn:fail:read?) + (err/rt-test (read (make-p (list #"#fx(1 " a-special #")") (lambda (x) 1) void)) exn:fail:read?)) +(run-comment-special) +(parameterize ([current-readtable (make-readtable #f)]) + (run-comment-special)) + ;; Test read-char-or-special: (let ([p (make-p (list #"x" a-special #"y") (lambda (x) 5) void)]) (test #\x peek-char-or-special p) @@ -1134,6 +1195,9 @@ (test #t equal? (fxvector 1000 76 100000 100000 100000 100000 100000 100000 100000 100000) (readstr "#fx10(1000 76 100000)")) (test #t equal? (flvector 0.0 0.0 0.0) (readstr "#fl3()")) (test #t equal? (flvector 2.0 1.0 1.0) (readstr "#fl3(2 1)")) +(test #t equal? (flvector 2.0 1.0) (readstr "#fl(2 #;5 1)")) +(test #t equal? (flvector 2.0 1.0) (readstr "#fl(2 #|5|# 1)")) +(test #t equal? (flvector 2.0 1.0) (readstr "#fl(2 ;5\n 1)")) (test #t equal? (fxvector 0 0 0) (readstr "#fx3()")) (test #t equal? (fxvector 2 1 1) (readstr "#fx3(2 1)")) @@ -1151,6 +1215,11 @@ (err/rt-test (read-syntax 'x (open-input-string "#fx()")) exn:fail:read?) (err/rt-test (read-syntax 'x (open-input-string "#fl()")) exn:fail:read?) +(parameterize ([current-readtable (make-readtable + #f + #f 'non-terminating-macro (lambda args 3.0))]) + (test #t equal? (flvector 3.0) (readstr "#fl(3)"))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require racket/extflonum) diff --git a/pkgs/racket-test-core/tests/racket/set.rktl b/pkgs/racket-test-core/tests/racket/set.rktl index 50f9525b02..99013eeaeb 100644 --- a/pkgs/racket-test-core/tests/racket/set.rktl +++ b/pkgs/racket-test-core/tests/racket/set.rktl @@ -561,39 +561,223 @@ (add1 i))) ;; ---------------------------------------- -;; set/c tests +;; chaperone-hash-set tests -(err/rt-test (set/c '(not a contract))) -(err/rt-test (set/c any/c #:cmp 'not-a-comparison)) -(err/rt-test (set/c any/c #:kind 'not-a-kind-of-set)) -(err/rt-test (set/c (-> integer? string?) #:cmp 'eq)) -(err/rt-test (set/c (-> integer? string?) #:cmp 'eqv)) +(let () + + ;; adds a tracing chaperone to 's', runs 'go' on it, and returns the trace + (define (counting-chaperone s go equal-key?) + (define trace '()) + (define (add-to-trace ele) (set! trace (cons ele trace))) + (define (count name) + (procedure-rename + (λ (s ele) (add-to-trace (list name ele)) ele) + name)) + (go + (chaperone-hash-set + s + (count 'inject) + (count 'add) + (count 'shrink) + (count 'extract) + (λ (s) (add-to-trace 'clear)) + (if equal-key? (count 'equal-key) (λ (s ele) ele)))) + (reverse trace)) + + (test '((extract 1)) + counting-chaperone + (set 1) + (λ (s) (set-first s)) + #f) + (test '((add 1)) + counting-chaperone + (set) + (λ (s) (set-add s 1)) + #f) + (test '((extract 1)) + counting-chaperone + (mutable-set 1) + (λ (s) (set-first s)) + #f) + (test '((extract 1)) + counting-chaperone + (weak-set 1) + (λ (s) (set-first s)) + #f) + (test '((add 2)) + counting-chaperone + (mutable-set 1) + (λ (s) (set-add! s 2)) + #f) + (test '((inject 2)) + counting-chaperone + (mutable-set 1) + (λ (s) (set-member? s 2)) + #f) + (test '((inject 1)) + counting-chaperone + (mutable-set 1) + (λ (s) (set-member? s 1)) + #f) + (test '((shrink 1)) + counting-chaperone + (set 1) + (λ (s) (set-remove s 1)) + #f) + (test '((shrink 1)) + counting-chaperone + (mutable-set 1) + (λ (s) (set-remove! s 1)) + #f) + (test '((inject 2) (equal-key 2) (equal-key 2)) + counting-chaperone + (set 2) + (λ (s) (set-member? s 2)) + #t) + (test '((extract 0)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define ele #f) + (set-add (make-immutable-set2) 0)) + (λ (s) (set-first s)) + #f) + (test '((extract 0)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define s (make-weak-set2)) + (set-add! s 0) + s) + (λ (s) (set-first s)) + #f) + (test '((add 0) (extract 0)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (make-immutable-set2)) + (λ (s) + (set-first (set-add s 0))) + #f) + (test '((extract 1)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define ele #f) + (set-add (make-immutable-set2) 1)) + (λ (s) (set-first s)) + #f) + (test '((add 1)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define ele #f) + (make-immutable-set2)) + (λ (s) (set-add s 1)) + #f) + (test '((extract 1)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define s (make-mutable-set2)) + (set-add! s 1) + s) + (λ (s) (set-first s)) + #f) + (test '((extract 1)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define s (make-weak-set2)) + (set-add! s 1) + s) + (λ (s) (set-first s)) + #f) + (test '((add 2)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define s (make-mutable-set2)) + (set-add! s 1) + s) + (λ (s) (set-add! s 2)) + #f) + (test '((inject 2)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define s (make-mutable-set2)) + (set-add! s 1) + s) + (λ (s) (set-member? s 2)) + #f) + (test '((inject 1)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define s (make-mutable-set2)) + (set-add! s 1) + s) + (λ (s) (set-member? s 1)) + #f) + (test '((shrink 1)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define ele #f) + (set-add (make-immutable-set2) 1)) + (λ (s) (set-remove s 1)) + #f) + (test '((inject 2) (equal-key 2) (equal-key 2)) + counting-chaperone + (let () + (define-custom-set-types set2 equal? equal-hash-code) + (define ele #f) + (set-add (make-immutable-set2) 2)) + (λ (s) (set-member? s 2)) + #t)) -(define (app-ctc ctc value) - (contract ctc value 'positive 'negative)) +(let ([s (set 1 2 3)]) + (test #t equal? + (chaperone-hash-set s (λ (x y) y) (λ (x y) y) (λ (x y) y) (λ (x y) y)) + s)) +(let ([s (set 1 2 3)]) + (test #t equal? + s + (chaperone-hash-set s (λ (x y) y) (λ (x y) y) (λ (x y) y) (λ (x y) y)))) -(define (positive-error? exn) - (and exn:fail:contract? - (regexp-match? "blaming: positive" (exn-message exn)))) -(define (negative-error? exn) - (and exn:fail:contract? - (regexp-match? "blaming: negative" (exn-message exn)))) +(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) + (make-impersonator-property 'p)]) + (let ([s (chaperone-hash-set (set) (λ (s l) l) (λ (s l) l) (λ (s l) l) (λ (s l) l) + impersonator-prop:p 11)]) + (test #t has-impersonator-prop:p? s))) -(define-syntax-rule (test/blame-pos e) - (thunk-error-test (lambda () e) #'e positive-error?)) -(define-syntax-rule (test/blame-neg e) - (thunk-error-test (lambda () e) #'e negative-error?)) +(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) + (make-impersonator-property 'p)]) + (let ([s (chaperone-hash-set (set) (λ (s l) l) (λ (s l) l) (λ (s l) l) (λ (s l) l) + impersonator-prop:p 11)]) + (test 11 get-impersonator-prop:p s))) -;; check dont-care defaults -(test #t set? (app-ctc (set/c any/c) (set))) -(test #t set? (app-ctc (set/c any/c) (seteq))) +(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) + (make-impersonator-property 'p)]) + (let ([s (impersonate-hash-set (weak-set) (λ (s l) l) (λ (s l) l) (λ (s l) l) (λ (s l) l) + impersonator-prop:p 11)]) + (test #t has-impersonator-prop:p? s))) -(test/blame-pos (app-ctc (set/c any/c) (mutable-set))) ; check immutable default -(test/blame-pos (app-ctc (set/c any/c #:cmp 'eq) (set))) -(test/blame-pos (app-ctc (set/c any/c #:kind 'mutable) (set))) -(test/blame-pos (app-ctc (set/c string? #:kind 'immutable) (set 1))) -(test/blame-pos (app-ctc (set/c string?) (set 1))) -(test/blame-pos (set-first (app-ctc (set/c string?) (set 1)))) -(test/blame-neg (set-add! (app-ctc (set/c string? #:kind 'mutable) (mutable-set)) 1)) +(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) + (make-impersonator-property 'p)]) + (let ([s (impersonate-hash-set (mutable-set) (λ (s l) l) (λ (s l) l) (λ (s l) l) (λ (s l) l) + impersonator-prop:p 11)]) + (test 11 get-impersonator-prop:p s))) + +(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) + (make-impersonator-property 'p)]) + (let ([s (chaperone-hash-set (set) #f #f #f #f impersonator-prop:p 11)]) + (test #t has-impersonator-prop:p? s))) + +(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) + (make-impersonator-property 'p)]) + (let ([s (impersonate-hash-set (mutable-set) #f #f #f #f impersonator-prop:p 11)]) + (test 11 get-impersonator-prop:p s))) (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index 838992b882..01813acefc 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/pkgs/racket-test-core/tests/racket/stx.rktl @@ -148,6 +148,17 @@ (test #f syntax-original? ((make-syntax-introducer) #'here)) (test #t syntax-original? ((make-syntax-introducer #t) #'here)) +(let* ([a (datum->syntax #f 'a)] + [a1 ((make-syntax-introducer) a)] + [a2 ((make-syntax-introducer) a)]) + (test #f bound-identifier=? a1 a2) + (test #t bound-identifier=? a1 ((make-syntax-delta-introducer a1 a2) a)) + (test #t bound-identifier=? a2 ((make-syntax-delta-introducer a2 a1) a)) + (test #t bound-identifier=? a2 ((make-syntax-delta-introducer a2 #f) a)) + (test #t bound-identifier=? + ((make-syntax-delta-introducer a1 a2) a2) + ((make-syntax-delta-introducer a2 a1) a1))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test basic expansion and property propagation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1814,6 +1825,18 @@ (test #t free-identifier=? #'begin (syntax-case a-b-stx () [(b . _) (datum->syntax #'b 'begin)])))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syntax-debug-info + +(let ([check (lambda (syntax-debug-info) + (test 'x hash-ref (syntax-debug-info #'x) 'name) + (test 'nope hash-ref (syntax-debug-info #'1) 'name 'nope) + (test 'nope hash-ref (syntax-debug-info #'(x y)) 'name 'nope))]) + (check syntax-debug-info) + (parameterize ([current-namespace (make-base-namespace)]) + (eval '(require (prefix-in foo: racket/base))) + (check (lambda (stx) (syntax-debug-info (namespace-syntax-introduce stx)))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check that attacks are thwarted via `syntax-local-get-shadower' ;; or `make-syntax-delta-introducer': @@ -2095,7 +2118,7 @@ (err/rt-test (apply raise-syntax-error #f "oops" a0 a1 args) (lambda (exn) (and (exn:fail:syntax? exn) - (regexp-match? (format "^[^:\n]*:~a:~a:" + (regexp-match? (format "^([a-zA-Z]:)?[^:\n]*:~a:~a:" (or (syntax-line a1) (syntax-line a0)) (or (syntax-column a1) @@ -2227,6 +2250,50 @@ [current-load-relative-directory (build-path dir "inner")]) (read i))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that shadowing doesn't create an ill-formed internal +;; representation of binding: + +(let () + ;; Make introducers before namespace, so they have older scopes, which + ;; means that bindings will be attached to the namespace's scope: + (define i1 (make-syntax-introducer)) + (define i2 (make-syntax-introducer)) + (define ns (make-base-namespace)) + (eval `(define car 0) ns) + (eval `(define ,(i1 (datum->syntax #f 'car)) 1) ns) + (eval `(define ,(i2 (datum->syntax #f 'car)) 2) ns) + (eval `(require racket/base) ns) ; replaces plain `car` mapping + (write (compile-syntax + #`(quote-syntax #,(parameterize ([current-namespace ns]) + (namespace-syntax-introduce (datum->syntax #f 'car))))) + (open-output-bytes))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that reading a compiled module doesn't mutate the +;; shared "self" modix for a submodule: + +(parameterize ([current-namespace (make-base-namespace)]) + (define o (open-output-bytes)) + (write (compile `(module name-1 racket/base (module+ inside))) o) + (define m + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes (get-output-bytes o))))) + (define s (expand `(module name-2 racket/base (module+ inside (define check-me 1))))) + (test "(|expanded module| inside)" + format + "~s" + (resolved-module-path-name + (let loop ([s s]) + (cond + [(identifier? s) + (and (equal? 'check-me (syntax-e s)) + (module-path-index-resolve (car (identifier-binding s))))] + [(syntax? s) (loop (syntax-e s))] + [(pair? s) + (or (loop (car s)) (loop (cdr s)))] + [else #f]))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/stxparam.rktl b/pkgs/racket-test-core/tests/racket/stxparam.rktl index 317614f3b8..179adf31dc 100644 --- a/pkgs/racket-test-core/tests/racket/stxparam.rktl +++ b/pkgs/racket-test-core/tests/racket/stxparam.rktl @@ -132,5 +132,28 @@ ;; ---------------------------------------- +(let () + (define-syntax (slv stx) + (syntax-case stx () + [(_ t) + #`#,(syntax-local-value #'t)])) + (define-syntax one 1) + (define-syntax two 2) + (define-syntax three 3) + (define-rename-transformer-parameter num + (make-rename-transformer #'one)) + (test #t = (slv num) 1) + (syntax-parameterize ([num (make-rename-transformer #'two)]) + (test #t = (slv num) 2)) + (splicing-syntax-parameterize ([num (make-rename-transformer #'two)]) + (define too (slv num))) + (test #t = too 2) + (splicing-syntax-parameterize ([num (make-rename-transformer #'two)]) + (splicing-syntax-parameterize ([num (make-rename-transformer #'three)]) + (define trois (slv num)))) + (test #t = trois 3)) + +;; ---------------------------------------- + (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/syntax.rktl b/pkgs/racket-test-core/tests/racket/syntax.rktl index bb2dc38bae..2e1d4a920e 100644 --- a/pkgs/racket-test-core/tests/racket/syntax.rktl +++ b/pkgs/racket-test-core/tests/racket/syntax.rktl @@ -1952,6 +1952,15 @@ procedure? (eval (datum->syntax #'here '(lambda () (sort '(1))) (list 'a #f #f #f #f))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check marshaling of a top-level `begin-for-syntax`: + +(parameterize ([current-namespace (make-base-namespace)]) + (eval '(require (for-syntax racket/base))) + (write (compile '(begin-for-syntax + (require racket/match))) + (open-output-bytes))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/will.rktl b/pkgs/racket-test-core/tests/racket/will.rktl index a10573e4cc..d43dd1c4fb 100644 --- a/pkgs/racket-test-core/tests/racket/will.rktl +++ b/pkgs/racket-test-core/tests/racket/will.rktl @@ -293,6 +293,25 @@ (if (car p) (add1 n) n)))) (test #t < fraction-retained 1/2))) +;; ---------------------------------------- +;; Check space safety conversion for nested `if`s + +(let ([ht (make-weak-hasheq)]) + (letrec ([f (lambda (false long-vector values n) + (begin + (if false + (if (random) 7 (length long-vector)) + 'long-vector-not-cleared-here) + (if (zero? n) + (begin + (collect-garbage) + (hash-count ht)) + (let ([vec (make-vector 1000)]) + (hash-set! ht vec #t) + (values (f false vec values (sub1 n)))))))]) + (set! f f) + (test #t < (f #f #f values 100) 33))) + ;; ---------------------------------------- (report-errs) diff --git a/pkgs/racket-test/LICENSE.txt b/pkgs/racket-test/LICENSE.txt index 46232662cc..413cec8000 100644 --- a/pkgs/racket-test/LICENSE.txt +++ b/pkgs/racket-test/LICENSE.txt @@ -1,5 +1,5 @@ racket-test -Copyright (c) 2010-2015 PLT Design Inc. +Copyright (c) 2010-2016 PLT Design Inc. This package is distributed under the GNU Lesser General Public License (LGPL). This means that you can link this package into proprietary diff --git a/pkgs/racket-test/tests/file/packers.rkt b/pkgs/racket-test/tests/file/packers.rkt index 2bc77569f4..2e3942c7f4 100644 --- a/pkgs/racket-test/tests/file/packers.rkt +++ b/pkgs/racket-test/tests/file/packers.rkt @@ -49,7 +49,9 @@ (and (directory-exists? dest) (compare-attributes src dest) (let* ([sort-paths (λ (l) (sort l bytesbytes))] - [srcs (sort-paths (directory-list src))] + [srcs (sort-paths (for/list ([p (in-list (directory-list src))] + #:unless (regexp-match? #rx"skip" p)) + p))] [dests (sort-paths (directory-list dest))]) (and (equal? srcs dests) (for/and ([src-item (in-list srcs)] @@ -64,7 +66,8 @@ (define (zip-tests zip unzip timestamps? #:dir-name [ex1 "ex1"] #:file-name [f2 "f2"] - #:links? [links? #f]) + #:links? [links? #f] + #:filter-path? [filter-path? #f]) (make-directory* ex1) (make-file (build-path ex1 "f1")) (make-file (build-path ex1 f2)) @@ -76,6 +79,10 @@ (make-file-or-directory-link "f1" (build-path ex1 "f1-link")) (make-file-or-directory-link "more" (build-path ex1 "more-link")) (make-file-or-directory-link "no" (build-path ex1 "no-link"))) + (when filter-path? + (make-file (build-path ex1 "skip1")) + (make-directory (build-path ex1 "skip2")) + (make-file (build-path ex1 "skip2" "nope"))) (zip "a.zip" ex1) (when timestamps? (sleep 3)) ; at least 2 seconds, plus 1 to likely change parity @@ -116,11 +123,20 @@ (zip-tests zip unzip #f) (zip-tests (make-zip #f) (make-unzip #f) 'file) (zip-tests (make-zip #t) (make-unzip #t) 'file) - (zip-tests tar untar #t #:links? #t) + (zip-tests tar untar #t #:links? (not (eq? 'windows (system-type)))) (zip-tests tar untar #t - #:links? #t + #:links? (not (eq? 'windows (system-type))) #:dir-name (make-string 64 #\d) - #:file-name (make-string 64 #\f))) + #:file-name (make-string 64 #\f)) + (zip-tests (lambda (#:path-prefix [prefix #f] . args) + (apply + tar + args + #:path-prefix prefix + #:path-filter (lambda (p) + (define-values (base name dir?) (split-path p)) + (not (regexp-match? #rx"skip" name))))) + untar #t #:filter-path? #t)) (delete-directory/files work-dir) diff --git a/pkgs/racket-test/tests/match/plt-match-tests.rkt b/pkgs/racket-test/tests/match/main.rkt similarity index 100% rename from pkgs/racket-test/tests/match/plt-match-tests.rkt rename to pkgs/racket-test/tests/match/main.rkt diff --git a/pkgs/racket-test/tests/pkg/tests-config.rkt b/pkgs/racket-test/tests/pkg/tests-config.rkt index bcef764690..92db1deffe 100644 --- a/pkgs/racket-test/tests/pkg/tests-config.rkt +++ b/pkgs/racket-test/tests/pkg/tests-config.rkt @@ -8,7 +8,7 @@ (with-fake-root (shelly-case "reading and writing configs" - $ "raco pkg config catalogs" =stdout> "http://pkgs.racket-lang.org\nhttp://planet-compats.racket-lang.org\n" + $ "raco pkg config catalogs" =stdout> "https://pkgs.racket-lang.org\nhttps://planet-compats.racket-lang.org\n" $ "raco pkg config -u --set catalogs http://localhost:9000" $ "raco pkg config -u catalogs" =stdout> "http://localhost:9000\n" diff --git a/pkgs/racket-test/tests/pkg/tests-locking.rkt b/pkgs/racket-test/tests/pkg/tests-locking.rkt index 0cd93a2d0e..7fd9de67e1 100644 --- a/pkgs/racket-test/tests/pkg/tests-locking.rkt +++ b/pkgs/racket-test/tests/pkg/tests-locking.rkt @@ -14,21 +14,30 @@ ;; Step 1: Start a special server that waits for our signal to respond (initialize-catalogs) - (define okay-to-start?-sema (make-semaphore)) - (define okay-to-respond?-sema (make-semaphore)) + + (define succeed-catalog (make-channel)) + (define fail-catalog (make-channel)) + (thread (λ () + (define first-time? #t) (serve/servlet (pkg-index/basic (λ (pkg-name) - (semaphore-post okay-to-start?-sema) - (semaphore-wait okay-to-respond?-sema) + ;; only do the synchronization protocol once: + ;; `pkg-index/basic` can decide to return 500 + ;; which triggers a retry, and since no one is + ;; posting a second time to these channels, we + ;; would get stuck. + (when first-time? + (channel-put fail-catalog 'go) + (define v (sync fail-catalog)) ;; => 'continue + (set! first-time? #f)) (define r (hash-ref *index-ht-1* pkg-name #f)) r) (λ () *index-ht-1*)) #:command-line? #t #:servlet-regexp #rx"" - #:port 9967) - (sleep 2))) + #:port 9967))) ;; Step 2: Assign it as our server $ "raco pkg config --set catalogs http://localhost:9967" @@ -37,11 +46,14 @@ (thread (λ () (shelly-begin - $ "raco pkg install pkg-test1"))) - (semaphore-wait okay-to-start?-sema) + $ "raco pkg install pkg-test1") + (channel-put succeed-catalog 'done))) + (sync fail-catalog) ;; => 'go ;; Step 4: Start the installation request that will fail $ "raco pkg install pkg-test1" =exit> 1 ;; Step 5: Free the other one - (semaphore-post okay-to-respond?-sema)))) + (channel-put fail-catalog 'continue) + (sync succeed-catalog) ;; => 'done + ))) diff --git a/pkgs/racket-test/tests/racket/contract-opt-tests.rkt b/pkgs/racket-test/tests/racket/contract-opt-tests.rkt deleted file mode 100644 index 8c5cd17f6b..0000000000 --- a/pkgs/racket-test/tests/racket/contract-opt-tests.rkt +++ /dev/null @@ -1,282 +0,0 @@ -#lang racket/base -(require racket/contract - rackunit - rackunit/text-ui) - -(define ((blame-to whom) exn) - (and (exn:fail:contract:blame? exn) - (regexp-match? (regexp-quote (format "blaming: ~a" whom)) - (exn-message exn)))) - -(define ((match-msg . msgs) exn) - (and (exn:fail? exn) - (for/and ([msg (in-list msgs)]) - (regexp-match (regexp-quote msg) (exn-message exn))))) - -(define-simple-check (check-pred2 func thunk) - (let-values ([(a b) (thunk)]) - (func a b))) - -(define-simple-check (check-name expected ctc) - (let ((got (contract-name ctc))) - (equal? expected got))) - -(define opt-tests - (test-suite - "Tests for opt/c" - - (test-case - "or 1" - (check-pred (λ (x) (= x 1)) - (contract (opt/c (or/c number? boolean?)) 1 'pos 'neg))) - - (test-case - "or 2" - (check-pred (λ (x) (eq? x #t)) - (contract (opt/c (or/c number? boolean?)) #t 'pos 'neg))) - - (test-exn - "or 3" - (blame-to 'pos) - (λ () - (contract (opt/c (or/c number? boolean?)) "string" 'pos 'neg))) - - (test-case - "or 4" - (check-pred (λ (x) (= x 1)) - ((contract (opt/c (or/c number? (-> boolean? number?))) - (λ (x) 1) 'pos 'neg) #t))) - - (test-case - "or 5" - (check-pred (λ (x) (= x 1)) - ((contract (opt/c (or/c (-> boolean? boolean? number?) (-> boolean? number?))) - (λ (x y) 1) 'pos 'neg) #t #f))) - - (test-case - "lifting 1" - (check-pred (λ (x) (= x 1)) - (let ((volatile 0)) - (contract (opt/c (between/c (begin (set! volatile 1) 3) 5)) 4 'pos 'neg) - volatile))) - - (test-case - "arrow 1" - (check-pred (λ (x) (= x 1)) - ((contract (opt/c (-> boolean? number?)) (λ (x) 1) 'pos 'neg) #t))) - - (test-case - "arrow 2" - (check-pred2 (λ (x y) (and (= x 1) (= y 2))) - (λ () - ((contract (opt/c (-> boolean? (values number? number?))) - (λ (x) (values 1 2)) 'pos 'neg) #t)))) - - (test-case - "arrow 3" - (check-pred2 (λ (x y) (and (= x 1) (= y 2))) - (λ () - ((contract (opt/c (-> boolean? any)) (λ (x) (values 1 2)) 'pos 'neg) #t)))) - - (test-case - "arrow 4" - (check-pred (λ (x) (= x 1)) - ((contract (opt/c (-> boolean? any)) (λ (x) 1) 'pos 'neg) #t))) - - (test-exn - "arrow 5" - (blame-to 'neg) - (λ () - ((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) 1))) - - (test-exn - "arrow 6" - (blame-to 'pos) - (λ () - ((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) #t))) - - (test-case - "flat-contract 1" - (check-pred (λ (x) (= x 1)) - (contract (opt/c (flat-contract (λ (x) (= x 1)))) 1 'pos 'neg))) - - (test-exn - "flat-contract 2" - (match-msg "expected: flat-contract?") - (λ () - (contract (opt/c (flat-contract (λ (x y) #f))) 1 'pos 'neg))) - - (test-case - "cons/c 1" - (check-pred (λ (x) (and (= (car x) 1) (= (cdr x) 2))) - (contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2))))) - (cons 1 2) 'pos 'neg))) - - (test-case - "cons/c 1" - (check-pred (λ (x) (and (= (car x) 1) (= (cdr x) 2))) - (contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2))))) - (cons 1 2) 'pos 'neg))) - - (test-case - "cons/c 2" - (check-pred (λ (x) (and (= (car x) 1) (= ((cdr x) 1) 2))) - (contract (opt/c (cons/c number? (-> number? any))) - (cons 1 (λ (x) 2)) 'pos 'neg))) - - (test-case - "between/c 1" - (check-pred (λ (x) (= x 1)) - (contract (opt/c (between/c 1 2)) 1 'pos 'neg))) - - (test-case - "between/c 2" - (blame-to 'pos) - (λ () - (contract (opt/c (between/c 1 2)) 3 'pos 'neg))) - - (test-exn - "between/c 2" - (match-msg "expected: real?" "argument position: 1st") - (λ () - (contract (opt/c (between/c 'x 'b)) 1 'pos 'neg))) - - (test-exn - "between/c 3" - (match-msg "expected: real?" "argument position: 2nd") - (λ () - (contract (opt/c (between/c 1 'b)) 1 'pos 'neg))) - - ;; - ;; name tests - ;; - - (test-case - "integer? name" - (check-name 'integer? (opt/c (flat-contract integer?)))) - - (test-case - "boolean? name" - (check-name 'boolean? (opt/c (flat-contract boolean?)))) - - (test-case - "char? name" - (check-name 'char? (opt/c (flat-contract char?)))) - - (test-case - "any/c name" - (check-name 'any/c (opt/c any/c))) - - (test-case - "-> name 1" - (check-name '(-> integer? integer?) (opt/c (-> integer? integer?)))) - - (test-case - "-> name 2" - (check-name '(-> integer? any) (opt/c (-> integer? any)))) - - (test-case - "-> name 3" - (check-name '(-> integer? (values boolean? char?)) (opt/c (-> integer? (values boolean? char?))))) - - (test-case - "or/c name 1" - (check-name '(or/c) (opt/c (or/c)))) - - (test-case - "or/c name 2" - (check-name '(or/c integer? gt0?) (opt/c (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))))) - - (test-case - "or/c name 3" - (check-name '(or/c integer? boolean?) - (opt/c (or/c (flat-contract integer?) - (flat-contract boolean?))))) - - (test-case - "or/c name 4" - (check-name '(or/c integer? boolean?) - (opt/c (or/c integer? boolean?)))) - - (test-case - "or/c name 5" - (check-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?) - (opt/c (or/c (-> (>=/c 5) (>=/c 5)) boolean?)))) - - (test-case - "or/c name 6" - (check-name '(or/c boolean? (-> (>=/c 5) (>=/c 5))) - (opt/c (or/c boolean? (-> (>=/c 5) (>=/c 5)))))) - - (test-case - "or/c name 7" - (check-name '(or/c (-> (>=/c 5) (>=/c 5)) - (-> (<=/c 5) (<=/c 5) (<=/c 5))) - (opt/c (or/c (-> (>=/c 5) (>=/c 5)) - (-> (<=/c 5) (<=/c 5) (<=/c 5)))))) - - (test-case - "or/c name 8" - (check-name '(or/c boolean? - (-> (>=/c 5) (>=/c 5)) - (-> (<=/c 5) (<=/c 5) (<=/c 5))) - (opt/c (or/c boolean? - (-> (>=/c 5) (>=/c 5)) - (-> (<=/c 5) (<=/c 5) (<=/c 5)))))) - - (test-case - "=/c name 1" - (check-name '(=/c 5) (opt/c (=/c 5)))) - - (test-case - ">=/c name 1" - (check-name '(>=/c 5) (opt/c (>=/c 5)))) - - (test-case - "<=/c name 1" - (check-name '(<=/c 5) (opt/c (<=/c 5)))) - - (test-case - "/c name 1" - (check-name '(>/c 5) (opt/c (>/c 5)))) - - (test-case - "between/c name 1" - (check-name '(between/c 5 6) (opt/c (between/c 5 6)))) - - (test-case - "cons/c name 1" - (check-name '(cons/c boolean? integer?) - (opt/c (cons/c boolean? (flat-contract integer?))))) - - (test-case - "cons/c name 2" - (check-name '(cons/c boolean? integer?) - (opt/c (cons/c boolean? (flat-contract integer?))))) - - (test-case - "cons/c name 1" - (check-name '(cons/c boolean? integer?) - (opt/c (cons/c boolean? (flat-contract integer?))))) - - (test-case - "cons/c name 2" - (check-name '(cons/c boolean? integer?) - (opt/c (cons/c boolean? (flat-contract integer?))))) - - (test-case - "cons/c name 3" - (check-name '(cons/c boolean? integer?) - (opt/c (cons/c boolean? (flat-contract integer?))))) - - (test-case - "cons/c name 4" - (check-name '(cons/c (-> boolean? boolean?) integer?) - (opt/c (cons/c (-> boolean? boolean?) integer?)))))) - -(unless (zero? (run-tests opt-tests)) - (error 'contract-opt-tests.rkt "tests failed")) diff --git a/pkgs/racket-test/tests/racket/contract/all.rkt b/pkgs/racket-test/tests/racket/contract/all.rkt index c6ec0e8aa5..818c02999d 100644 --- a/pkgs/racket-test/tests/racket/contract/all.rkt +++ b/pkgs/racket-test/tests/racket/contract/all.rkt @@ -98,7 +98,7 @@ #:when (and (regexp-match #rx"[.]rkt$" (path->string file)) (not (member (path->string file) - '("test-util.rkt" "all.rkt"))))) + '("info.rkt" "test-util.rkt" "all.rkt"))))) file)) (define (find-deps file) @@ -117,26 +117,33 @@ (cond [(and (list? exp) (pair? exp) - (eq? (car exp) 'make-basic-contract-namespace)) - (when deps + (or (equal? (car exp) 'make-basic-contract-namespace) + (equal? (car exp) 'make-full-contract-namespace))) + (when deps (error 'find-deps "found two calls to make-basic-contract-namespace in ~a" file)) - (set! deps (map remove-quote (cdr exp)))] + (set! deps (append (if (equal? (car exp) 'make-full-contract-namespace) + full-contract-namespace-initial-set + '()) + (map remove-quote (cdr exp))))] [(list? exp) (for-each loop exp)] [else (void)])) deps) (define (depi ([x integer?]) ([y integer?]) any)) @@ -1397,4 +1397,31 @@ 1)) ;; this used to cause a runtime error in the code that parses ->i - (test/no-error '(->i ([x () any/c] [y (x) any/c]) any))) + (test/no-error '(->i ([x () any/c] [y (x) any/c]) any)) + + (test/spec-passed/result + 'really-chaperones.1 + '(let ([f (λ () 1)]) + (chaperone-of? + (contract (->i #:chaperone () any) f 'pos 'neg) + f)) + #t) + + (test/spec-passed/result + 'really-chaperones.2 + '(let ([f (λ () 1)]) + (chaperone-of? + (contract (->i () [_ (new-∀/c)]) f 'pos 'neg) + f)) + #f) + + (test/spec-passed/result + 'really-chaperones.3 + '(with-handlers ([exn:fail? + (λ (x) + (regexp-match? #rx"^->i:.*chaperone" (exn-message x)))]) + ((contract (->i #:chaperone ([x integer?] [y (x) (new-∀/c)]) any) + (λ (x y) x) + 'pos 'neg) 1 2) + "didn't raise an error") + #t)) diff --git a/pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt b/pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt index e9583fa296..261edd75d1 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt @@ -243,6 +243,22 @@ 'neg #:database "db" #:password "password" #:user "user") (list "user" "db" "password" #f)) + (test/spec-passed/result + '->*neg-party18b + '((neg-party-fn + (->* (#:user string?) + (#:database (or/c string? #f) + #:password (first-or/c string? (list/c 'hash string?) #f) + #:port (first-or/c exact-positive-integer? #f)) + any/c) + (λ (#:user user + #:database [db #f] + #:password [password #f] + #:port [port #f]) + (list user db password port))) + 'neg #:database "db" #:password "password" #:user "user") + (list "user" "db" "password" #f)) + (test/pos-blame '->*neg-party19 '((neg-party-fn diff --git a/pkgs/racket-test/tests/racket/contract/arrow-star.rkt b/pkgs/racket-test/tests/racket/contract/arrow-star.rkt index 04507c1668..a4b5383b96 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow-star.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow-star.rkt @@ -543,6 +543,23 @@ 'pos 'neg) #:database "db" #:password "password" #:user "user") (list "user" "db" "password" #f)) + + (test/spec-passed/result + 'contract-arrow-star-optional25b + '((contract + (->* (#:user string?) + (#:database (first-or/c string? #f) + #:password (first-or/c string? (list/c 'hash string?) #f) + #:port (first-or/c exact-positive-integer? #f)) + any/c) + (λ (#:user user + #:database [db #f] + #:password [password #f] + #:port [port #f]) + (list user db password port)) + 'pos 'neg) + #:database "db" #:password "password" #:user "user") + (list "user" "db" "password" #f)) (test/spec-passed 'contract-arrow-star-keyword-ordering diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index 7d822464b7..c5ecff1614 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -318,6 +318,23 @@ (test/pos-blame 'contract-any/c-arrow4 '(contract (-> any/c any) (λ (x #:y y) x) 'pos 'neg)) + + (test/neg-blame + 'contract-any/c-arrow5 + '((contract (-> any/c any) (λ (x [y 1]) x) 'pos 'neg) 1 2)) + + (test/spec-passed/result + 'contract-any/c-arrow6 + '(let ([f (λ (x) x)]) + (eq? f (contract (-> any/c any) f 'pos 'neg))) + #t) + + (test/spec-passed/result + 'contract-any/c-arrow7 + '(let ([f (λ (x [y 1]) x)]) + (eq? f (contract (-> any/c any) f 'pos 'neg))) + #f) + (test/spec-passed 'contract-arrow-all-kwds2 @@ -340,6 +357,21 @@ ;; pass; this is fixed in a separate branch that can't (regexp-match #rx"expected:? keyword argument #:the-missing-keyword-arg-b" (exn-message x))))) + + ;; need to preserve the inner contract here + ;; (not the outer one) + ;; when dropping redundant tail contracts + (test/pos-blame + 'tail-wrapping-preserves-blame + '(let ([c (-> number? number?)]) + ((contract + c + (contract + c + (λ (x) #f) + 'pos 'neg) + 'something-else 'yet-another-thing) + 1))) (test/pos-blame 'predicate/c1 @@ -386,6 +418,13 @@ (test/pos-blame 'predicate/c13 '(contract (-> any/c boolean?) (λ (x #:y y) #t) 'pos 'neg)) + (test/pos-blame + 'predicate/c14 + '(contract (-> any/c boolean?) + (let () + (struct s ()) + ((impersonate-procedure s? (λ (x) (values (λ (r) "") x))) 11)) + 'pos 'neg)) ;; this test ensures that no contract wrappers ;; are created for struct predicates diff --git a/pkgs/racket-test/tests/racket/contract/async-channel.rkt b/pkgs/racket-test/tests/racket/contract/async-channel.rkt index 322317630d..2627c27612 100644 --- a/pkgs/racket-test/tests/racket/contract/async-channel.rkt +++ b/pkgs/racket-test/tests/racket/contract/async-channel.rkt @@ -30,4 +30,11 @@ '(let ([ac (contract (or/c (async-channel/c integer?) (integer? . -> . integer?)) (make-async-channel) 'pos 'neg)]) (async-channel-put ac 1) + (async-channel-get ac))) + + (test/spec-passed + 'async-channel/c-with-higher-order2 + '(let ([ac (contract (first-or/c (async-channel/c integer?) (integer? . -> . integer?)) + (make-async-channel) 'pos 'neg)]) + (async-channel-put ac 1) (async-channel-get ac)))) diff --git a/pkgs/racket-test/tests/racket/contract/blame.rkt b/pkgs/racket-test/tests/racket/contract/blame.rkt index 5840354c41..61f70d0469 100644 --- a/pkgs/racket-test/tests/racket/contract/blame.rkt +++ b/pkgs/racket-test/tests/racket/contract/blame.rkt @@ -2,8 +2,131 @@ (require "test-util.rkt") (parameterize ([current-contract-namespace - (make-basic-contract-namespace 'racket/contract)]) - + (make-basic-contract-namespace 'racket/contract + 'racket/contract/private/blame)]) + + (test/spec-passed/result + 'blame-selector.1 + '(blame-positive (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos 'neg #t)) + 'pos) + (test/spec-passed/result + 'blame-selector.2 + '(blame-negative (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos 'neg #t)) + 'neg) + (test/spec-passed/result + 'blame-selector.3 + '(blame-positive + (blame-swap + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos 'neg #t))) + 'neg) + (test/spec-passed/result + 'blame-selector.4 + '(blame-original? + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos 'neg #t)) + #t) + (test/spec-passed/result + 'blame-selector.5 + '(blame-original? + (blame-swap + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos 'neg #t))) + #f) + (test/spec-passed/result + 'blame-selector.6 + '(blame-negative + (blame-replace-negative + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos 'neg #t) + 'neg2)) + 'neg2) + (test/spec-passed/result + 'blame-selector.7 + '(blame-positive + (blame-swap + (blame-replace-negative + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos 'neg #t) + 'neg2))) + 'neg2) + (test/spec-passed/result + 'blame-selector.8 + '(blame-positive + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos #f #t)) + 'pos) + (test/spec-passed/result + 'blame-selector.9 + '(blame-positive + (blame-add-missing-party + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos #f #t) + 'neg)) + 'pos) + (test/spec-passed/result + 'blame-selector.10 + '(blame-negative + (blame-add-missing-party + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos #f #t) + 'neg)) + 'neg) + (test/spec-passed/result + 'blame-selector.11 + '(blame-negative + (blame-add-missing-party + (blame-swap + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos #f #t)) + 'pos)) + 'pos) + (test/spec-passed/result + 'blame-selector.12 + '(blame-positive + (blame-add-missing-party + (blame-swap + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos #f #t)) + 'neg)) + 'neg) + (test/spec-passed/result + 'blame-selector.13 + '(blame-negative + (blame-add-missing-party + (blame-replace-negative + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos #f #t) + 'neg2) + 'neg)) + 'neg2) + (test/spec-passed/result + 'blame-selector.14 + '(blame-positive + (blame-add-missing-party + (blame-swap + (blame-replace-negative + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos #f #t) + 'neg2)) + 'neg)) + 'neg2) + (test/spec-passed/result + 'blame-selector.15 + '(with-handlers ([exn:fail? + (λ (x) (regexp-match? #rx"^blame-add-missing-party:" + (exn-message x)))]) + (blame-add-missing-party + (blame-add-missing-party + (make-blame (srcloc "src.rkt" #f #f #f #f) + 'whatever (λ () 'the-name) 'pos #f #t) + 'neg) + 'neg2) + 'no-exn-raised) + #t) + (contract-eval #:test-case-name "blame.rkt setup.1" '(module blame-ok/c racket/base @@ -158,4 +281,6 @@ (test/no-error '(let () (define-struct/contract thing ([stuff flat-blame-ok/c])) - (thing-stuff (thing 5)))))) + (thing-stuff (thing 5))))) + + ) diff --git a/pkgs/racket-test/tests/racket/contract/context.rkt b/pkgs/racket-test/tests/racket/contract/context.rkt index df1ba7712c..2f2c788705 100644 --- a/pkgs/racket-test/tests/racket/contract/context.rkt +++ b/pkgs/racket-test/tests/racket/contract/context.rkt @@ -94,8 +94,8 @@ 'neg)) 1)) - (context-test '("a part of the or/c of") - '(contract (or/c 1 (-> number? number?)) + (context-test '() + '(contract (or/c 1 2) 3 'pos 'neg)) @@ -106,6 +106,19 @@ 'pos 'neg) 1)) + + (context-test '() + '(contract (first-or/c 1 (-> number? number?)) + 3 + 'pos + 'neg)) + + (context-test '("the range of" "a part of the first-or/c of") + '((contract (first-or/c 1 (-> number? number?) (-> number? boolean? number?)) + (λ (x) #f) + 'pos + 'neg) + 1)) (context-test '("the 2nd conjunct of") '(contract (and/c procedure? (-> integer? integer?)) diff --git a/pkgs/racket-test/tests/racket/contract/contract-out.rkt b/pkgs/racket-test/tests/racket/contract/contract-out.rkt index d995ad3f13..19d0382670 100644 --- a/pkgs/racket-test/tests/racket/contract/contract-out.rkt +++ b/pkgs/racket-test/tests/racket/contract/contract-out.rkt @@ -996,6 +996,78 @@ (provide a))) (eval '(dynamic-require ''provide/contract51-m2 'a))) '(1 2 3 4)) + + (test/spec-passed/result + 'provide/contract52 + '(let () + (eval '(module provide/contract52-m1 racket/base + (require racket/contract/base) + (provide (contract-out + [f (->* (integer?) (boolean? char? any/c) any)])) + (define (f x [y #f] [z #\a] [w 0]) (list x y z w)))) + (eval '(module provide/contract52-m2 racket/base + (require 'provide/contract52-m1) + (provide a) + (define a + (let ([f f]) + (list (f 1 #t #\x) + (f 1)))))) + (eval '(dynamic-require ''provide/contract52-m2 'a))) + '((1 #t #\x 0) (1 #f #\a 0))) + + (test/spec-passed/result + 'provide/contract53 + '(let () + (eval '(module provide/contract53-m1 racket/base + (require racket/contract/base) + (provide (contract-out + [f (->* (integer?) (boolean? char? any/c) #:rest any/c any)])) + (define (f x [y #f] [z #\a] [w 0] . rest) (list* x y z w rest)))) + (eval '(module provide/contract53-m2 racket/base + (require 'provide/contract53-m1) + (provide a) + (define a + (let ([f f]) + (list (f 1 #t #\x 11 22 33 44 55 66) + (f 1)))))) + (eval '(dynamic-require ''provide/contract53-m2 'a))) + '((1 #t #\x 11 22 33 44 55 66) (1 #f #\a 0))) + + (test/spec-passed/result + 'provide/contract54 + '(let () + (eval '(module provide/contract54-m1 racket/base + (require racket/contract/base) + (provide (contract-out + [f (->* (#:x integer?) (#:y boolean? #:z char? #:w any/c) any)])) + (define (f #:x x #:y [y #f] #:z [z #\a] #:w [w 0]) (list x y z w)))) + (eval '(module provide/contract54-m2 racket/base + (require 'provide/contract54-m1) + (provide a) + (define a + (let ([f f]) + (list (f #:x 1 #:y #t #:z #\x) + (f #:x 1)))))) + (eval '(dynamic-require ''provide/contract54-m2 'a))) + '((1 #t #\x 0) (1 #f #\a 0))) + + (test/spec-passed/result + 'provide/contract55 + '(let () + (eval '(module provide/contract55-m1 racket/base + (require racket/contract/base) + (provide + (contract-out + [an-s s?] + [s-x (-> s? integer?)])) + (struct s (x)) + (define an-s (s 5)))) + (eval '(module provide/contract55-m2 racket/base + (require 'provide/contract55-m1) + (provide a) + (define a (s-x (chaperone-struct an-s s-x (λ (s x) x)))))) + (eval '(dynamic-require ''provide/contract55-m2 'a))) + '5) (contract-error-test 'contract-error-test8 diff --git a/pkgs/racket-test/tests/racket/contract/first-order.rkt b/pkgs/racket-test/tests/racket/contract/first-order.rkt index b5cd734b12..e80a37b640 100644 --- a/pkgs/racket-test/tests/racket/contract/first-order.rkt +++ b/pkgs/racket-test/tests/racket/contract/first-order.rkt @@ -130,6 +130,27 @@ (-> integer? integer?)) 1) + (ctest #t contract-first-order-passes? (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?) #t) + (ctest #t contract-first-order-passes? (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?) (λ (x) x)) + (ctest #f contract-first-order-passes? (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?) 'x) + + (ctest #t contract-first-order-passes? + (first-or/c (-> integer? integer? integer?) + (-> integer? integer?)) + (λ (x) x)) + (ctest #t contract-first-order-passes? + (first-or/c (-> integer? integer? integer?) + (-> integer? integer?)) + (λ (x y) x)) + (ctest #f contract-first-order-passes? + (first-or/c (-> integer? integer? integer?) + (-> integer? integer?)) + (λ () x)) + (ctest #f contract-first-order-passes? + (first-or/c (-> integer? integer? integer?) + (-> integer? integer?)) + 1) + (ctest #t contract-first-order-passes? (hash/c any/c any/c) (make-hash)) (ctest #f contract-first-order-passes? (hash/c any/c any/c) #f) (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)]) @@ -175,6 +196,12 @@ (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") "yx") (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") 'y) + (ctest #t contract-first-order-passes? (first-or/c 'x "x" #rx"x") 'x) + (ctest #t contract-first-order-passes? (first-or/c 'x "x" #rx"x") "x") + (ctest #t contract-first-order-passes? (first-or/c 'x "x" #rx"x.") "xy") + (ctest #f contract-first-order-passes? (first-or/c 'x "x" #rx"x.") "yx") + (ctest #f contract-first-order-passes? (first-or/c 'x "x" #rx"x.") 'y) + (ctest #f contract-first-order-passes? (->m integer? integer?) (λ (x) 1)) (ctest #t contract-first-order-passes? (->m integer? integer?) (λ (this x) 1)) diff --git a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt index 178a91c6ea..3c538b504d 100644 --- a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt +++ b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt @@ -71,6 +71,9 @@ (test-flat-contract #rx#".x." "axq" "x") (test-flat-contract ''() '() #f) + (test-flat-contract '(if/c integer? even? list?) 2 3) + (test-flat-contract '(if/c integer? even? list?) '() #f) + (test/spec-passed 'any/c '(contract any/c 1 'pos 'neg)) (test-flat-contract 'printable/c (vector (cons 1 (box #f))) (lambda (x) x)) (let () @@ -109,6 +112,12 @@ (contract-eval `(new (class* object% (flat-is-a-test<%>) (super-new)))) (contract-eval '(new object%))) (test-flat-contract `(or/c #f (is-a?/c flat-is-a-test%)) + (contract-eval `(new flat-is-a-test%)) + (contract-eval '(new object%))) + (test-flat-contract `(first-or/c #f (is-a?/c flat-is-a-test<%>)) + (contract-eval `(new (class* object% (flat-is-a-test<%>) (super-new)))) + (contract-eval '(new object%))) + (test-flat-contract `(first-or/c #f (is-a?/c flat-is-a-test%)) (contract-eval `(new flat-is-a-test%)) (contract-eval '(new object%)))) @@ -162,6 +171,11 @@ even1) '(1 2 3 4) '(1 2 3)) + (test-flat-contract '(flat-murec-contract ([even1 (first-or/c null? (cons/c number? even2))] + [even2 (cons/c number? even1)]) + even1) + '(1 2 3 4) + '(1 2 3)) (test-flat-contract '(hash/c symbol? boolean? #:flat? #t) (make-hash) 1) (test-flat-contract '(hash/c symbol? boolean? #:flat? #t) @@ -200,6 +214,9 @@ (test-flat-contract '(or/c (flat-contract integer?) char?) #\a #t) (test-flat-contract '(or/c (flat-contract integer?) char?) 1 #t) + (test-flat-contract '(first-or/c (flat-contract integer?) char?) #\a #t) + (test-flat-contract '(first-or/c (flat-contract integer?) char?) 1 #t) + ;; test flat-contract-predicate (test #t (flat-contract-predicate integer?) 1) diff --git a/pkgs/racket-test/tests/racket/contract-helpers.rkt b/pkgs/racket-test/tests/racket/contract/helpers.rkt similarity index 100% rename from pkgs/racket-test/tests/racket/contract-helpers.rkt rename to pkgs/racket-test/tests/racket/contract/helpers.rkt diff --git a/pkgs/racket-test/tests/racket/contract/ifc.rkt b/pkgs/racket-test/tests/racket/contract/ifc.rkt new file mode 100644 index 0000000000..69fa592650 --- /dev/null +++ b/pkgs/racket-test/tests/racket/contract/ifc.rkt @@ -0,0 +1,85 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + + (test/spec-passed/result + 'if/c1 + '(contract (if/c integer? even? (listof number?)) + 2 + 'pos 'neg) + 2) + + (test/spec-passed/result + 'if/c2 + '(contract (if/c integer? even? (listof number?)) + '() + 'pos 'neg) + '()) + + (test/pos-blame + 'if/c3 + '(contract (if/c integer? even? (listof number?)) + 3 + 'pos 'neg)) + + (test/pos-blame + 'if/c4 + '(contract (if/c integer? even? (listof number?)) + '(#f) + 'pos 'neg)) + + (test/pos-blame + 'if/c5 + '(contract (if/c integer? even? (listof number?)) + #f + 'pos 'neg)) + + (test/pos-blame + 'if/c6 + '(contract (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1))) + (-> integer? integer?) + number?) + #f + 'pos 'neg)) + + (test/neg-blame + 'if/c7 + '((contract (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1))) + (-> integer? integer?) + number?) + (λ (x) x) + 'pos 'neg) + #f)) + + (test/spec-passed/result + 'if/c8 + '(contract (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1))) + (-> integer? integer?) + number?) + 1 + 'pos 'neg) + 1) + + (test/spec-passed/result + 'if/c9 + '(let ([f (λ (x) x)]) + (chaperone-of? + (contract (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1))) + (-> integer? integer?) + number?) + f + 'pos 'neg) + f)) + #t) + + (test/spec-passed/result + 'if/c10 + '(chaperone-contract? + (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1))) + (-> integer? integer?) + number?)) + #t)) + + diff --git a/pkgs/racket-test/tests/racket/contract/instanceof.rkt b/pkgs/racket-test/tests/racket/contract/instanceof.rkt index 52c891a2f9..4845fe31b6 100644 --- a/pkgs/racket-test/tests/racket/contract/instanceof.rkt +++ b/pkgs/racket-test/tests/racket/contract/instanceof.rkt @@ -55,6 +55,27 @@ [c%/c (class/c [m (->m number? number?)])] [d%/c (class/c [n (->m number? number?)])]) (contract (instanceof/c (or/c c%/c d%/c)) (new e%) 'pos 'neg))) + + (test/spec-passed + 'instanceof/c-first-order-9 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])]) + (contract (instanceof/c (first-or/c c%/c d%/c)) (new c%) 'pos 'neg))) + + (test/spec-passed + 'instanceof/c-first-order-10 + '(let* ([d% (class object% (super-new) (define/public (n x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])]) + (contract (instanceof/c (first-or/c c%/c d%/c)) (new d%) 'pos 'neg))) + + (test/pos-blame + 'instanceof/c-first-order-11 + '(let* ([e% (class object% (super-new) (define/public (p x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])]) + (contract (instanceof/c (first-or/c c%/c d%/c)) (new e%) 'pos 'neg))) (test/spec-passed/result 'instanceof/c-higher-order-1 @@ -87,7 +108,7 @@ (send o m 3))) (test/pos-blame - 'instanceof/c-higher-order-4 + 'instanceof/c-higher-order-5 '(let* ([c% (class object% (super-new) (define/public (m x) #t))] [c%/c (class/c [m (->m number? number?)])] [d%/c (class/c [n (->m number? number?)])] @@ -95,9 +116,33 @@ (send o m 3))) (test/neg-blame - 'instanceof/c-higher-order-4 + 'instanceof/c-higher-order-6 '(let* ([c% (class object% (super-new) (define/public (m x) x))] [c%/c (class/c [m (->m number? number?)])] [d%/c (class/c [n (->m number? number?)])] [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)]) + (send o m #t))) + + (test/spec-passed + 'instanceof/c-higher-order-7 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])] + [o (contract (instanceof/c (first-or/c c%/c d%/c)) (new c%) 'pos 'neg)]) + (send o m 3))) + + (test/pos-blame + 'instanceof/c-higher-order-8 + '(let* ([c% (class object% (super-new) (define/public (m x) #t))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])] + [o (contract (instanceof/c (first-or/c c%/c d%/c)) (new c%) 'pos 'neg)]) + (send o m 3))) + + (test/neg-blame + 'instanceof/c-higher-order-9 + '(let* ([c% (class object% (super-new) (define/public (m x) x))] + [c%/c (class/c [m (->m number? number?)])] + [d%/c (class/c [n (->m number? number?)])] + [o (contract (instanceof/c (first-or/c c%/c d%/c)) (new c%) 'pos 'neg)]) (send o m #t)))) \ No newline at end of file diff --git a/pkgs/racket-test/tests/racket/contract/list-contract.rkt b/pkgs/racket-test/tests/racket/contract/list-contract.rkt index e8e890e573..b82ee6e1ef 100644 --- a/pkgs/racket-test/tests/racket/contract/list-contract.rkt +++ b/pkgs/racket-test/tests/racket/contract/list-contract.rkt @@ -115,5 +115,45 @@ 'pos 'neg) (λ (x) (and (exn:fail? x) - (regexp-match #rx"list-contract[?]" (exn-message x)))))) + (regexp-match #rx"list-contract[?]" (exn-message x))))) + + (test/spec-passed/result + 'list-contract-20 + '(list-contract? (first-or/c (cons/c 1 empty?) empty?)) + #t) + + (test/spec-passed/result + 'list-contract-21 + '(list-contract? (first-or/c (cons/c (-> integer? integer?) empty?) + empty?)) + #t) + + (test/spec-passed/result + 'list-contract-22 + '(list-contract? (first-or/c (cons/c (-> integer? integer?) empty?) + (cons/c (-> integer? integer? integer?) empty?) + empty?)) + #t) + + (test/spec-passed/result + 'list-contract-23 + '(list-contract? + (letrec ([c (recursive-contract (first-or/c (cons/c 1 c) empty?))]) + c)) + #f) + + (test/spec-passed/result + 'list-contract-24 + '(list-contract? + (letrec ([c (recursive-contract (first-or/c (cons/c 1 c) empty?) #:list-contract?)]) + c)) + #t) + + (test/pos-blame + 'test-contract-25 + '(contract (letrec ([c (recursive-contract (first-or/c (cons/c any/c c) empty?) + #:list-contract?)]) + c) + (read (open-input-string "#1=(1 . #1#)")) + 'pos 'neg))) diff --git a/pkgs/racket-test/tests/racket/contract/make-contract.rkt b/pkgs/racket-test/tests/racket/contract/make-contract.rkt index 8f7ff01bf2..04bb43c3d1 100644 --- a/pkgs/racket-test/tests/racket/contract/make-contract.rkt +++ b/pkgs/racket-test/tests/racket/contract/make-contract.rkt @@ -134,6 +134,52 @@ '(contract proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) exn:fail?) + (contract-eval + '(define val-first-proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (make-chaperone-contract + #:name 'bad-prime-box-list/c + #:first-order (λ (v) (and (list? v) (andmap box? v))) + #:val-first-projection + (λ (blame) + (λ (v) + (λ (neg-party) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v + #:missing-party neg-party + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v)))))))) + + (contract-error-test + 'contract-error-test6 + '(contract val-first-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) + + (contract-eval + '(define late-neg-proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (make-chaperone-contract + #:name 'bad-prime-box-list/c + #:first-order (λ (v) (and (list? v) (andmap box? v))) + #:late-neg-projection + (λ (blame) + (λ (v neg-party) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v))))))) + + (contract-error-test + 'contract-error-test7 + '(contract late-neg-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) + (test/pos-blame 'build-chaperone-contract-property1 '(let () @@ -156,6 +202,88 @@ (((contract-projection (val-first-none)) (make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t)) 5))) + + (contract-eval + '(define prop:late-neg-proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (struct ctc () + #:property + prop:chaperone-contract + (build-chaperone-contract-property + #:name (λ (c) 'bad-prime-box-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap box? v)))) + #:late-neg-projection + (λ (c) + (λ (blame) + (λ (v neg-party) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v #:missing-party neg-party + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v)))))) + (ctc)))) + + (contract-error-test + 'contract-error-test8 + '(contract prop:late-neg-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) + + (contract-eval + '(define prop:val-first-proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (struct ctc () + #:property + prop:chaperone-contract + (build-chaperone-contract-property + #:name (λ (c) 'bad-prime-box-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap box? v)))) + #:val-first-projection + (λ (c) + (λ (blame) + (λ (v) + (λ (neg-party) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v #:missing-party neg-party + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v))))))) + (ctc)))) + + (contract-error-test + 'contract-error-test9 + '(contract prop:val-first-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) + + (contract-eval + '(define prop:proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (struct ctc () + #:property + prop:chaperone-contract + (build-chaperone-contract-property + #:name (λ (c) 'bad-prime-box-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap box? v)))) + #:projection + (λ (c) + (λ (blame) + (λ (v) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v)))))) + (ctc)))) + + (contract-error-test + 'contract-error-test10 + '(contract prop:proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -226,4 +354,228 @@ (test/spec-passed/result 'make-flat-contract-bad-6 '(chaperone-contract? proj:prime-list/c) - #t)) \ No newline at end of file + #t) + + (contract-eval + '(define val-first-proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (make-flat-contract + #:name 'prime-list/c + #:first-order (λ (v) (and (list? v) (andmap prime? v))) + #:val-first-projection + (λ (b) + (λ (v) + (λ (neg-party) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v #:missing-party neg-party + "expected prime list, got ~v" v)) + (map values v)))))))) + + + + +(test/spec-passed/result + 'make-flat-contract-bad-7 + '(contract val-first-proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-8 + '(contract val-first-proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-9 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract val-first-proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? val-first-proj:prime-list/c) +(ctest #t flat-contract? val-first-proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-10 + '(chaperone-contract? val-first-proj:prime-list/c) + #t) + + + (contract-eval + '(define late-neg-proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (make-flat-contract + #:name 'prime-list/c + #:first-order (λ (v) (and (list? v) (andmap prime? v))) + #:late-neg-projection + (λ (b) + (λ (v neg-party) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v #:missing-party neg-party "expected prime list, got ~v" v)) + (map values v))))))) + + + + +(test/spec-passed/result + 'make-flat-contract-bad-11 + '(contract late-neg-proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-12 + '(contract late-neg-proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-13 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract late-neg-proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? late-neg-proj:prime-list/c) +(ctest #t flat-contract? late-neg-proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-14 + '(chaperone-contract? late-neg-proj:prime-list/c) + #t) + + +(contract-eval + '(define prop:proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (struct ctc () + #:property + prop:flat-contract + (build-flat-contract-property + #:name (λ (c) 'prime-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap prime? v)))) + #:projection + (λ (c) + (λ (b) + (λ (v) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v "expected prime list, got ~v" v)) + (map values v)))))) + + (ctc)))) + +(test/spec-passed/result + 'make-flat-contract-bad-15 + '(contract prop:proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-16 + '(contract prop:proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-17 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract prop:proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? prop:proj:prime-list/c) +(ctest #t flat-contract? prop:proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-18 + '(chaperone-contract? prop:proj:prime-list/c) + #t) + + +(contract-eval + '(define prop:val-first-proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (struct ctc () + #:property + prop:flat-contract + (build-flat-contract-property + #:name (λ (c) 'prime-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap prime? v)))) + #:val-first-projection + (λ (c) + (λ (b) + (λ (v) + (λ (neg-party) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v + #:missing-party neg-party + "expected prime list, got ~v" v)) + (map values v))))))) + + (ctc)))) + +(test/spec-passed/result + 'make-flat-contract-bad-19 + '(contract prop:val-first-proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-20 + '(contract prop:val-first-proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-21 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract prop:val-first-proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? prop:val-first-proj:prime-list/c) +(ctest #t flat-contract? prop:val-first-proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-22 + '(chaperone-contract? prop:val-first-proj:prime-list/c) + #t) + + (contract-eval + '(define prop:late-neg-proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (struct ctc () + #:property + prop:flat-contract + (build-flat-contract-property + #:name (λ (c) 'prime-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap prime? v)))) + #:late-neg-projection + (λ (c) + (λ (b) + (λ (v neg-party) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v + #:missing-party neg-party + "expected prime list, got ~v" v)) + (map values v)))))) + + (ctc)))) + +(test/spec-passed/result + 'make-flat-contract-bad-23 + '(contract prop:late-neg-proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-24 + '(contract prop:late-neg-proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-25 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract prop:late-neg-proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? prop:late-neg-proj:prime-list/c) +(ctest #t flat-contract? prop:late-neg-proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-26 + '(chaperone-contract? prop:late-neg-proj:prime-list/c) + #t)) diff --git a/pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-test/tests/racket/contract/name.rkt index 4c93ca5860..a035a9d0cb 100644 --- a/pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-test/tests/racket/contract/name.rkt @@ -32,6 +32,21 @@ (or/c (-> (>=/c 5) (>=/c 5)) boolean?)) (test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5))) (or/c boolean? (-> (>=/c 5) (>=/c 5)))) + + (test-name '(if/c integer? odd? (-> integer? integer?)) + (if/c integer? odd? (-> integer? integer?))) + (test-name '(if/c integer? odd? boolean?) + (if/c integer? odd? boolean?)) + + (test-name '(first-or/c) (first-or/c)) + (test-name '(first-or/c integer? gt0?) (first-or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))) + (test-name '(first-or/c integer? boolean?) + (first-or/c (flat-contract integer?) + (flat-contract boolean?))) + (test-name '(first-or/c (-> (>=/c 5) (>=/c 5)) boolean?) + (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?)) + (test-name '(first-or/c boolean? (-> (>=/c 5) (>=/c 5))) + (first-or/c boolean? (-> (>=/c 5) (>=/c 5)))) (test-name 'mumble (let ([frotz/c integer?] [bazzle/c boolean?]) @@ -167,6 +182,29 @@ (-> (>=/c 5) (>=/c 5)) (-> (<=/c 5) (<=/c 5) (<=/c 5)))) + (test-name '(first-or/c) (first-or/c)) + (test-name 'integer? (first-or/c integer?)) + (test-name '(first-or/c integer? gt0?) (first-or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))) + (test-name '(first-or/c integer? boolean?) + (first-or/c (flat-contract integer?) + (flat-contract boolean?))) + (test-name '(first-or/c integer? boolean?) + (first-or/c integer? boolean?)) + (test-name '(first-or/c (-> (>=/c 5) (>=/c 5)) boolean?) + (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?)) + (test-name '(first-or/c boolean? (-> (>=/c 5) (>=/c 5))) + (first-or/c boolean? (-> (>=/c 5) (>=/c 5)))) + (test-name '(first-or/c (-> (>=/c 5) (>=/c 5)) + (-> (<=/c 5) (<=/c 5) (<=/c 5))) + (first-or/c (-> (>=/c 5) (>=/c 5)) + (-> (<=/c 5) (<=/c 5) (<=/c 5)))) + (test-name '(first-or/c boolean? + (-> (>=/c 5) (>=/c 5)) + (-> (<=/c 5) (<=/c 5) (<=/c 5))) + (first-or/c boolean? + (-> (>=/c 5) (>=/c 5)) + (-> (<=/c 5) (<=/c 5) (<=/c 5)))) + (test-name 'any/c (and/c)) (test-name '(and/c any/c) (and/c any/c)) (test-name '(and/c any/c any/c) (and/c any/c any/c)) @@ -355,7 +393,8 @@ (test-name '(set/c char? #:cmp 'eq) (set/c char? #:cmp 'eq)) (test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv)) (test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal)) - + (test-name '(set/c (-> integer? boolean?)) (set/c (-> integer? boolean?))) + (test-name 'α (let ([α (new-∀/c)]) α)) (test-name 'α (let ([α (new-∀/c #f)]) α)) (test-name 'β (let ([α (new-∀/c 'β)]) α)) diff --git a/pkgs/racket-test/tests/racket/contract/obligations.rkt b/pkgs/racket-test/tests/racket/contract/obligations.rkt index 979dbfd86f..4b11f7e406 100644 --- a/pkgs/racket-test/tests/racket/contract/obligations.rkt +++ b/pkgs/racket-test/tests/racket/contract/obligations.rkt @@ -94,4 +94,12 @@ '((racket/contract:contract (vector-immutable/c) ()) (racket/contract:positive-position a) (racket/contract:positive-position b) - (racket/contract:positive-position c)))) + (racket/contract:positive-position c))) + (test-obligations '(or/c a b) + '((racket/contract:contract (or/c) ()) + (racket/contract:positive-position a) + (racket/contract:positive-position b))) + (test-obligations '(first-or/c a b) + '((racket/contract:contract (first-or/c) ()) + (racket/contract:positive-position a) + (racket/contract:positive-position b)))) diff --git a/pkgs/racket-test/tests/racket/contract/opt-c.rkt b/pkgs/racket-test/tests/racket/contract/opt-c.rkt index ae1ababe5e..b7cd9225b9 100644 --- a/pkgs/racket-test/tests/racket/contract/opt-c.rkt +++ b/pkgs/racket-test/tests/racket/contract/opt-c.rkt @@ -172,10 +172,137 @@ so that propagation occurs. |# + (test/spec-passed/result + "or 1" + '(contract (opt/c (or/c number? boolean?)) 1 'pos 'neg) + 1) + + (test/spec-passed/result + "or 2" + '(contract (opt/c (or/c number? boolean?)) #t 'pos 'neg) + #t) + + (test/pos-blame + "or 3" + '(contract (opt/c (or/c number? boolean?)) "string" 'pos 'neg)) + + (test/spec-passed/result + "or 4" + '((contract (opt/c (or/c number? (-> boolean? number?))) + (λ (x) 1) 'pos 'neg) #t) + 1) + + (test/spec-passed/result + "or 5" + '((contract (opt/c (or/c (-> boolean? boolean? number?) (-> boolean? number?))) + (λ (x y) 1) 'pos 'neg) #t #f) + 1) + + (test/spec-passed/result + "lifting 1" + '(let ((volatile 0)) + (contract (opt/c (between/c (begin (set! volatile 1) 3) 5)) 4 'pos 'neg) + volatile) + 1) + + (test/spec-passed/result + "arrow 1" + '((contract (opt/c (-> boolean? number?)) (λ (x) 1) 'pos 'neg) #t) + 1) + + (test/spec-passed/result + "arrow 2" + '(call-with-values + (λ () ((contract (opt/c (-> boolean? (values number? number?))) + (λ (x) (values 1 2)) 'pos 'neg) #t)) + list) + '(1 2)) + + (test/spec-passed/result + "arrow 3" + '(call-with-values + (λ () ((contract (opt/c (-> boolean? any)) (λ (x) (values 1 2)) 'pos 'neg) #t)) + list) + '(1 2)) + + (test/spec-passed/result + "arrow 4" + '((contract (opt/c (-> boolean? any)) (λ (x) 1) 'pos 'neg) #t) + 1) + + (test/neg-blame + "arrow 5" + '((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) 1)) + + (test/pos-blame + "arrow 6" + '((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) #t)) + + (test/spec-passed/result + "flat-contract 1" + '(contract (opt/c (flat-contract (λ (x) (= x 1)))) 1 'pos 'neg) + 1) + + (test/spec-passed/result + "flat-contract 2" + '(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"expected: flat-contract[?]" + (exn-message x)))]) + (contract (opt/c (flat-contract (λ (x y) #f))) 1 'pos 'neg) + 'no-exn) + #t) + + (test/spec-passed/result + "cons/c 1" + '(contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2))))) + (cons 1 2) 'pos 'neg) + '(1 . 2)) + + (test/spec-passed/result + "cons/c 1b" + '(contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2))))) + (cons 1 2) 'pos 'neg) + '(1 . 2)) + + (test/spec-passed/result + "cons/c 2" + '(let ([x (contract (opt/c (cons/c number? (-> number? any))) + (cons 1 (λ (x) 2)) 'pos 'neg)]) + (and (= (car x) 1) (= ((cdr x) 1) 2))) + #t) + + (test/spec-passed/result + "between/c 1" + '(contract (opt/c (between/c 1 2)) 1 'pos 'neg) + 1) + + (test/pos-blame + "between/c 2" + '(contract (opt/c (between/c 1 2)) 3 'pos 'neg)) + + (test/spec-passed/result + "between/c 2" + '(with-handlers ([exn:fail? (λ (x) + (regexp-match? + #rx"expected: real[?].*argument position: 1st" + (exn-message x)))]) + (contract (opt/c (between/c 'x 'b)) 1 'pos 'neg) + 'no-exn) + #t) + + (test/spec-passed/result + "between/c 3" + '(with-handlers ([exn:fail? (λ (x) + (regexp-match? + #rx"expected: real[?].*argument position: 2nd" + (exn-message x)))]) + (contract (opt/c (between/c 1 'b)) 1 'pos 'neg)) + #t) + + ;; test the predicate (ctest #t couple? (contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg)) (ctest #t couple? (make-couple 1 2)) (ctest #t couple? (contract (couple/dc [hd any/c] [tl (hd) any/c]) (make-couple 1 2) 'pos 'neg)) (ctest #f couple? 1) - (ctest #f couple? #f)) \ No newline at end of file + (ctest #f couple? #f)) diff --git a/pkgs/racket-test/tests/racket/contract/or-and.rkt b/pkgs/racket-test/tests/racket/contract/or-and.rkt index 7b41b4cc65..6c94591d7b 100644 --- a/pkgs/racket-test/tests/racket/contract/or-and.rkt +++ b/pkgs/racket-test/tests/racket/contract/or-and.rkt @@ -86,6 +86,14 @@ 1) 1) + (contract-error-test + 'contract-error-test4 + #'(contract (or/c (-> integer? integer?) (-> boolean? boolean?)) + (λ (x) x) + 'pos + 'neg) + exn:fail?) + (test/spec-passed/result 'or/c-ordering '(let ([x '()]) @@ -223,21 +231,154 @@ 'pos 'neg) (lambda (x y z) 1))) - (test/spec-passed/result + (test/neg-blame 'ho-or/c-val-first2 - '((contract (or/c (-> integer? integer?) (-> boolean? boolean?)) + '((contract (-> (or/c (-> number? number?) + (-> number? number?)) + number?) + (λ (x) 1) + 'pos 'neg) + (lambda (x) 1))) + + (test/pos-blame + 'first-or/c1 + '(contract (first-or/c false/c) #t 'pos 'neg)) + + (test/spec-passed + 'first-or/c2 + '(contract (first-or/c false/c) #f 'pos 'neg)) + + (test/spec-passed + 'first-or/c3 + '((contract (first-or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1)) + + (test/neg-blame + 'first-or/c4 + '((contract (first-or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f)) + + (test/pos-blame + 'first-or/c5 + '((contract (first-or/c (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1)) + + (test/spec-passed + 'first-or/c6 + '(contract (first-or/c false/c (-> integer? integer?)) #f 'pos 'neg)) + + (test/spec-passed + 'first-or/c7 + '((contract (first-or/c false/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1)) + + (test/spec-passed/result + 'first-or/c8 + '((contract ((first-or/c false/c (-> string?)) . -> . any) + (λ (y) y) + 'pos + 'neg) + #f) + #f) + + (test/spec-passed/result + 'first-or/c9 + '((contract (first-or/c (-> string?) (-> integer? integer?)) + (λ () "x") + 'pos + 'neg)) + "x") + + (test/spec-passed/result + 'first-or/c10 + '((contract (first-or/c (-> string?) (-> integer? integer?)) (λ (x) x) 'pos 'neg) 1) 1) + (test/pos-blame + 'first-or/c11 + '(contract (first-or/c (-> string?) (-> integer? integer?)) + 1 + 'pos + 'neg)) + + (test/pos-blame + 'first-or/c12 + '((contract (first-or/c (-> string?) (-> integer? integer?)) + 1 + 'pos + 'neg) + 'x)) + + (test/pos-blame + 'first-or/c13 + '(contract (first-or/c not) #t 'pos 'neg)) + + (test/spec-passed + 'first-or/c14 + '(contract (first-or/c not) #f 'pos 'neg)) + (test/spec-passed/result - 'ho-or/c-val-first3 - '((contract (-> (or/c (-> number? number?) + 'first-or/c-not-error-early + '(begin (first-or/c (-> integer? integer?) (-> boolean? boolean?)) + 1) + 1) + + (test/spec-passed/result + 'contract-not-an-error-test4-ior + '((contract (first-or/c (-> integer? integer?) (-> boolean? boolean?)) + (λ (x) x) + 'pos + 'neg) 1) + 1) + + (test/spec-passed/result + 'first-or/c-ordering + '(let ([x '()]) + (contract (first-or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t)) + 'anything + 'pos + 'neg) + x) + '(1 2)) + + (test/spec-passed/result + 'first-or/c-ordering2 + '(let ([x '()]) + (contract (first-or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t)) + 'anything + 'pos + 'neg) + x) + '(2)) + + (test/spec-passed + 'first-or/c-hmm + '(let ([funny/c (first-or/c (and/c procedure? (-> any)) (listof (-> number?)))]) + (contract (-> funny/c any) void 'pos 'neg))) + + + (test/spec-passed + 'first-or/c-opt-unknown-flat + '(let () + (define arr (-> number? number?)) + ((contract (opt/c (first-or/c not arr)) (λ (x) x) 'pos 'neg) 1))) + + + (test/neg-blame + 'ho-first-or/c-val-first1 + '((contract (-> (first-or/c (-> number?) (-> number? number?)) number?) (λ (x) 1) 'pos 'neg) - (lambda (x) 1)) - 1)) + (lambda (x y z) 1))) + + (test/spec-passed/result + 'ho-first-or/c-val-first2 + '((contract (-> (first-or/c (-> number? number?) + (-> number? number?)) + number?) + (λ (x) (x 1)) + 'pos 'neg) + (lambda (x) (+ x 1))) + 2)) diff --git a/pkgs/racket-test/tests/racket/contract/parametric.rkt b/pkgs/racket-test/tests/racket/contract/parametric.rkt index 888f71d01e..1a3b065d65 100644 --- a/pkgs/racket-test/tests/racket/contract/parametric.rkt +++ b/pkgs/racket-test/tests/racket/contract/parametric.rkt @@ -53,6 +53,14 @@ 'pos 'neg) 1 "foo") 1) + + (test/spec-passed/result + 'parametric->/c6b + '((contract (parametric->/c (A B) (-> A B (first-or/c A B))) + (λ (x y) x) + 'pos 'neg) + 1 "foo") + 1) (test/pos-blame 'parametric->/c7 @@ -62,4 +70,14 @@ (λ (x) (unless c (set! c x)) c) 'pos 'neg)]) (f 1) - (f 2)))) + (f 2))) + + (test/spec-passed/result + 'parametric->/c8 + '((contract + (parametric->/c (x) (-> #:x x x)) + (λ (#:x x) x) + 'pos 'neg) + #:x 11) + 11)) + diff --git a/pkgs/racket-test/tests/racket/contract/predicates.rkt b/pkgs/racket-test/tests/racket/contract/predicates.rkt index 535c256171..733affcb5b 100644 --- a/pkgs/racket-test/tests/racket/contract/predicates.rkt +++ b/pkgs/racket-test/tests/racket/contract/predicates.rkt @@ -10,8 +10,11 @@ (ctest #t flat-contract? (or/c (flat-contract integer?) (flat-contract boolean?))) (ctest #t flat-contract? (or/c integer? boolean?)) - (ctest #t flat-contract? (-> any/c any/c any)) - + (ctest #t flat-contract? (first-or/c)) + (ctest #t flat-contract? (first-or/c integer? (lambda (x) (> x 0)))) + (ctest #t flat-contract? (first-or/c (flat-contract integer?) (flat-contract boolean?))) + (ctest #t flat-contract? (first-or/c integer? boolean?)) + (ctest #t flat-contract? (and/c)) (ctest #t flat-contract? (and/c number? integer?)) (ctest #t flat-contract? (and/c (flat-contract number?) @@ -196,7 +199,7 @@ (cons/c (recursive-contract ctc #:flat) (recursive-contract ctc #:flat)))]) ctc)) - + (ctest #f flat-contract? (letrec ([ctc (or/c number? (box/c (recursive-contract ctc #:chaperone)))]) ctc)) @@ -204,6 +207,20 @@ (box/c (recursive-contract ctc #:chaperone)))]) ctc)) (ctest #f impersonator-contract? (letrec ([ctc (or/c number? + (box/c (recursive-contract ctc #:chaperone)))]) + ctc)) + (ctest #t flat-contract? (letrec ([ctc (first-or/c number? + (cons/c (recursive-contract ctc #:flat) + (recursive-contract ctc #:flat)))]) + ctc)) + + (ctest #f flat-contract? (letrec ([ctc (first-or/c number? + (box/c (recursive-contract ctc #:chaperone)))]) + ctc)) + (ctest #t chaperone-contract? (letrec ([ctc (first-or/c number? + (box/c (recursive-contract ctc #:chaperone)))]) + ctc)) + (ctest #f impersonator-contract? (letrec ([ctc (first-or/c number? (box/c (recursive-contract ctc #:chaperone)))]) ctc)) diff --git a/pkgs/racket-test/tests/racket/contract/prof.rkt b/pkgs/racket-test/tests/racket/contract/prof.rkt index c6ff702575..7e19329674 100644 --- a/pkgs/racket-test/tests/racket/contract/prof.rkt +++ b/pkgs/racket-test/tests/racket/contract/prof.rkt @@ -12,18 +12,27 @@ (only-in racket/contract/private/blame blame-positive blame-negative - blame?)) + blame?) + (only-in racket/contract/combinator + blame-missing-party?)) (provide pos-blame? neg-blame? named-blame?) (define (named-blame? who) (define mark-info (continuation-mark-set-first (current-continuation-marks) contract-continuation-mark-key)) + (define complete-blame + (or (not mark-info) + (pair? mark-info) ; missing party is provided + (not (blame-missing-party? mark-info)))) ; no missing party (define (get-party selector) (and mark-info - (or (selector (car mark-info)) - (cdr mark-info)))) + (if (pair? mark-info) + (or (selector (car mark-info)) + (cdr mark-info)) + (selector mark-info)))) (and mark-info + complete-blame (let ([pos (get-party blame-positive)] [neg (get-party blame-negative)]) (or (equal? pos who) @@ -99,4 +108,106 @@ [f (-> #:x (λ _ (named-blame? 'prof3)) any/c)])))) (eval '(require 'prof3)) (eval '(f #:x 11))) - 11)) + 11) + + (test/spec-passed + 'provide/contract11 + '(let () + (struct posn (x y)) + ((contract (-> (struct/dc posn [x neg-blame?]) any/c) (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract12 + '(let () + (struct posn (x y)) + ((contract (-> any/c (struct/dc posn [x pos-blame?])) (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract13 + '(let () + (struct posn (x y)) + ((contract (-> any/c (struct/dc posn [x pos-blame?] #:inv (x) pos-blame?)) + (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract14 + '(let () + (struct posn (x y) #:mutable) + ((contract (-> any/c (struct/dc posn [x pos-blame?])) + (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract15 + '(let () + (struct posn (x y)) + ((contract (-> any/c (struct/dc posn [x #:lazy pos-blame?])) + (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract16 + '(let () + (struct posn (x y)) + ((contract (-> any/c (struct/dc posn + [x pos-blame?] + [y (x) pos-blame?])) + (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract17 + '(let () + (struct posn (x y)) + ((contract (-> any/c (struct/dc posn + [x pos-blame?] + [y (x) #:lazy pos-blame?])) + (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract18 + '(let () + (struct posn (x y) #:mutable) + ((contract (-> any/c (struct/dc posn + [x pos-blame?] + [y (x) pos-blame?])) + (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract19 + '(let () + (struct posn (x y)) + ((contract (-> any/c (struct/dc posn + [x pos-blame?] + [y (x) #:depends-on-state pos-blame?])) + (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract20 + '(let () + (struct posn (x y) #:mutable) + ((contract (-> any/c (struct/dc posn + [x pos-blame?] + [y (x) #:depends-on-state pos-blame?])) + (λ (x) x) 'pos 'neg) + (posn 1 2)))) + + (test/spec-passed + 'provide/contract21 + '(let () + ((contract (case-> (-> any/c any/c pos-blame?)) + (λ (x y) x) 'pos 'neg) + 1 2))) + + (test/spec-passed + 'provide/contract22 + '(let () + ((contract (case-> (-> neg-blame? any/c)) + (λ (x) x) 'pos 'neg) + 1)))) diff --git a/pkgs/racket-test/tests/racket/contract-rand-test.rkt b/pkgs/racket-test/tests/racket/contract/random-generate.rkt similarity index 80% rename from pkgs/racket-test/tests/racket/contract-rand-test.rkt rename to pkgs/racket-test/tests/racket/contract/random-generate.rkt index 099decc9a0..785aa14f06 100644 --- a/pkgs/racket-test/tests/racket/contract-rand-test.rkt +++ b/pkgs/racket-test/tests/racket/contract/random-generate.rkt @@ -58,6 +58,7 @@ (check-not-exn (λ () (test-contract-generation (=/c 0)))) (check-not-exn (λ () (test-contract-generation (=/c 0.0)))) (check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?)))) +(check-not-exn (λ () (test-contract-generation (first-or/c boolean? boolean?)))) (check-not-exn (λ () (test-contract-generation (cons/c integer? boolean?)))) (check-not-exn (λ () (test-contract-generation (cons/dc [hd integer?] [tl (hd) (<=/c hd)])))) (check-not-exn (λ () (test-contract-generation (cons/dc [hd (tl) (<=/c tl)] [tl integer?])))) @@ -69,6 +70,7 @@ (check-not-exn (λ () (test-contract-generation (and/c procedure? (-> integer? integer?))))) (check-not-exn (λ () (test-contract-generation (and/c integer? even?)))) (check-not-exn (λ () (test-contract-generation (or/c (and/c real? positive? ( char? integer?)) 0))) (check-not-exn (λ () ((test-contract-generation (-> integer? integer?)) 1))) @@ -131,6 +157,7 @@ (λ () ((test-contract-generation (-> some-crazy-predicate? some-crazy-predicate?)) 11))) (check-not-exn (λ () (((test-contract-generation (-> (-> (>/c 10) (>/c 10))))) 11))) +(check-not-exn (λ () ((test-contract-generation (-> any/c any)) 1))) (check-not-exn (λ () @@ -149,6 +176,7 @@ (check-not-exn (lambda () (test-contract-generation (or/c #f number?)))) +(check-not-exn (lambda () (test-contract-generation (first-or/c #f number?)))) (check-not-exn (lambda () (test-contract-generation (or/c some-crazy-predicate? some-crazy-predicate? some-crazy-predicate? @@ -160,9 +188,23 @@ some-crazy-predicate? some-crazy-predicate? #f)))) +(check-not-exn (lambda () (test-contract-generation (first-or/c some-crazy-predicate? + some-crazy-predicate? + some-crazy-predicate? + some-crazy-predicate? + some-crazy-predicate? + some-crazy-predicate? + some-crazy-predicate? + some-crazy-predicate? + some-crazy-predicate? + some-crazy-predicate? + #f)))) (check-exn cannot-generate-exn? (λ () (test-contract-generation (or/c some-crazy-predicate? some-crazy-predicate?)))) +(check-exn cannot-generate-exn? (λ () (test-contract-generation + (first-or/c some-crazy-predicate? + some-crazy-predicate?)))) ;; testing a bunch of impossible and/c's inside some or/c doesn't crash (check-not-exn (λ () (test-contract-generation @@ -171,6 +213,12 @@ (and/c (-> number? number?) any/c number?))))) +(check-not-exn (λ () (test-contract-generation + (first-or/c (first-or/c (and/c integer? boolean?) + (and/c (listof integer?) string?)) + (and/c (-> number? number?) + any/c + number?))))) ;; in this test, the and/c shoudl generate a dynamic ;; failure, which should trigger the 'cons/c' failing @@ -285,6 +333,13 @@ (λ (x) (if x 'fail 11)) 'pos 'neg)) +(check-exercise + 10000 + pos-exn? + (contract (-> (first-or/c #f some-crazy-predicate?) some-crazy-predicate?) + (λ (x) (if x 'fail 11)) + 'pos + 'neg)) (check-exercise 10000 @@ -293,3 +348,10 @@ (λ (x) (if x 'fail 11)) 'pos 'neg)) +(check-exercise + 10000 + pos-exn? + (contract (-> (first-or/c #f some-crazy-predicate?) (first-or/c #f some-crazy-predicate?)) + (λ (x) (if x 'fail 11)) + 'pos + 'neg)) diff --git a/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt b/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt index 523c688ee2..e22827a101 100644 --- a/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt +++ b/pkgs/racket-test/tests/racket/contract/recursive-contract.rkt @@ -72,4 +72,23 @@ '(let () (struct doll (contents)) (letrec ([doll-ctc2 (or/c 'center (struct/c doll (recursive-contract doll-ctc2 #:flat)))]) - (contract doll-ctc2 (doll 4) 'pos 'neg))))) + (contract doll-ctc2 (doll 4) 'pos 'neg)))) + + + (test/spec-passed/result + 'recursive-contract-not-too-slow + '(let () + (define c + (recursive-contract + (or/c null? + (cons/c (-> integer? integer? integer?) c) + (cons/c (-> integer? integer?) (cons/c (-> integer? integer?) c))))) + + (define l (build-list 10000 (λ (x) (λ (x) x)))) + (define-values (_ cpu real gc) + (time-apply (λ () (contract c l 'pos 'neg)) '())) + ;; should be substantially less than 5 seconds. + ;; with the old implementation it is more like 20 seconds + ;; on my laptop and about .3 seconds with the new one + (< (- cpu gc) 5000)) + #t)) diff --git a/pkgs/racket-test/tests/racket/contract/rename.rkt b/pkgs/racket-test/tests/racket/contract/rename.rkt new file mode 100644 index 0000000000..2c6488a8d0 --- /dev/null +++ b/pkgs/racket-test/tests/racket/contract/rename.rkt @@ -0,0 +1,70 @@ +#lang racket/base +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace + 'racket/contract/parametric)]) + + (test/spec-passed/result + 'rename1 + '(contract-name + (rename-contract (-> integer? integer?) + 'another-name)) + 'another-name) + + (test/spec-passed/result + 'rename2 + '(chaperone-contract? + (rename-contract (-> integer? integer?) + 'another-name)) + #t) + + (test/spec-passed/result + 'rename3 + '(contract-name + (rename-contract integer? 'another-name)) + 'another-name) + + (test/spec-passed/result + 'rename4 + '(flat-contract? + (rename-contract integer? 'another-name)) + #t) + + (test/spec-passed/result + 'rename5 + '(contract-name + (rename-contract integer? 'another-name)) + 'another-name) + + (test/spec-passed/result + 'rename6 + '(flat-contract? + (rename-contract (new-∀/c 'alpha) 'α)) + #f) + + (test/spec-passed/result + 'rename7 + '(chaperone-contract? + (rename-contract (new-∀/c 'alpha) 'α)) + #f) + + (test/spec-passed/result + 'rename8 + '(contract? + (rename-contract (new-∀/c 'alpha) 'α)) + #t) + + (test/pos-blame + 'rename9 + '((contract (rename-contract (-> integer? integer?) 'whatever) + (λ (x) #f) + 'pos 'neg) + 1)) + + (test/neg-blame + 'rename10 + '((contract (rename-contract (-> integer? integer?) 'whatever) + (λ (x) x) + 'pos 'neg) + #f))) diff --git a/pkgs/racket-test/tests/racket/contract/set.rkt b/pkgs/racket-test/tests/racket/contract/set.rkt index c64b97e3df..31aed187b9 100644 --- a/pkgs/racket-test/tests/racket/contract/set.rkt +++ b/pkgs/racket-test/tests/racket/contract/set.rkt @@ -3,6 +3,59 @@ (parameterize ([current-contract-namespace (make-basic-contract-namespace 'racket/set)]) + + (test/spec-passed/result + 'set/c.0.1 + '(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))]) + (set/c '(not a contract))) + #t) + (test/spec-passed/result + 'set/c.0.2 + '(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))]) + (set/c any/c #:cmp 'not-a-comparison)) + #t) + (test/spec-passed/result + 'set/c.0.3 + '(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))]) + (set/c any/c #:kind 'not-a-kind-of-set)) + #t) + (test/spec-passed/result + 'set/c.0.4 + '(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))]) + (set/c (-> integer? string?) #:cmp 'eq)) + #t) + (test/spec-passed/result + 'set/c.0.5 + '(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"^set/c:" (exn-message x)))]) + (set/c (-> integer? string?) #:cmp 'eqv)) + #t) + + ;; check dont-care defaults + (test/spec-passed/result + 'set/c.0.6 + '(set? (contract (set/c any/c) (set) 'pos 'neg)) + #t) + (test/spec-passed/result + 'set/c.0.7 + '(set? (contract (set/c any/c) (seteq) 'pos 'neg)) + #t) + + (test/pos-blame 'set/c.0.8 + '(contract (set/c any/c) (mutable-set) 'pos 'neg)) ; check immutable default + (test/pos-blame 'set/c.0.9 + '(contract (set/c any/c #:cmp 'eq) (set) 'pos 'neg)) + (test/pos-blame 'set/c.0.10 + '(contract (set/c any/c #:kind 'mutable) (set) 'pos 'neg)) + (test/pos-blame 'set/c.0.11 + '(contract (set/c string? #:kind 'immutable) (set 1) 'pos 'neg)) + (test/pos-blame 'set/c.0.12 + '(contract (set/c string?) (set 1) 'pos 'neg)) + (test/pos-blame 'set/c.0.13 + '(set-first (contract (set/c string?) (set 1) 'pos 'neg))) + (test/neg-blame 'set/c.0.14 + '(set-add! (contract (set/c string? #:kind 'mutable) (mutable-set) 'pos 'neg) + 1)) + (test/spec-passed/result 'set/c1 @@ -109,4 +162,160 @@ '(contract (set/c integer? #:kind 'mutable) (mutable-set 0) 'pos 'neg) - (contract-eval '(mutable-set 0)))) + (contract-eval '(mutable-set 0))) + + + (test/pos-blame + 'set/c17 + '(let () + (struct binary-set [integer] + #:transparent + #:methods gen:set + [(define (set-member? st i) + (bitwise-bit-set? (binary-set-integer st) i)) + (define (set-add st i) + (binary-set (bitwise-ior (binary-set-integer st) + (arithmetic-shift 1 i)))) + (define (set-remove st i) + (binary-set (bitwise-and (binary-set-integer st) + (bitwise-not (arithmetic-shift 1 i)))))]) + (contract (set/c integer?) + (binary-set 5) + 'pos 'neg))) + + (test/spec-passed + 'set/c19 + '(let () + (struct binary-set [integer] + #:transparent + #:methods gen:set + [(define (set-member? st i) + (bitwise-bit-set? (binary-set-integer st) i)) + (define (set-add st i) + (binary-set (bitwise-ior (binary-set-integer st) + (arithmetic-shift 1 i)))) + (define (set-remove st i) + (binary-set (bitwise-and (binary-set-integer st) + (bitwise-not (arithmetic-shift 1 i)))))]) + (contract (set/c integer? #:kind 'dont-care) + (binary-set 5) + 'pos 'neg))) + + (test/spec-passed + 'set/c20 + '(let () + (struct binary-set [integer] + #:transparent + #:methods gen:set + [(define (set-member? st i) + (bitwise-bit-set? (binary-set-integer st) i)) + (define (set-add st i) + (binary-set (bitwise-ior (binary-set-integer st) + (arithmetic-shift 1 i)))) + (define (set-remove st i) + (binary-set (bitwise-and (binary-set-integer st) + (bitwise-not (arithmetic-shift 1 i)))))]) + (contract (set/c boolean? #:kind 'dont-care #:lazy? #t) + (binary-set 5) + 'pos 'neg))) + + (test/spec-passed/result + 'set/c21 + '(let* ([c (set/c (-> integer? integer?))] + [s (contract c (set (λ (x) x)) 'pos 'neg)]) + (and (has-contract? s) + (equal? (value-contract s) c))) + #t) + + (test/spec-passed/result + 'set/c2b + '(let* ([c (set/c (-> integer? integer?))] + [s (contract c (set (λ (x) x)) 'pos 'neg)]) + (has-blame? s)) + #t) + + (test/spec-passed + 'set/c22 + '(contract (set/c (-> integer? integer?) #:lazy? #t) + (set #f) 'pos 'neg)) + + (test/pos-blame + 'set/c23 + '(set-first + (contract (set/c (-> integer? integer?) #:lazy? #t) + (set #f) 'pos 'neg))) + + (test/pos-blame + 'set/c24 + '(contract (set/c (-> integer? integer?) #:lazy? #f) + (set #f) 'pos 'neg)) + + (test/spec-passed + 'set/c25 + '(contract (set/c integer? #:lazy? #t) + (set #f) 'pos 'neg)) + + (test/pos-blame + 'set/c26 + '(set-first + (contract (set/c integer? #:lazy? #t) + (set #f) 'pos 'neg))) + + (test/pos-blame + 'set/c27 + '(contract (set/c integer? #:lazy? #f) + (set #f) 'pos 'neg)) + + (test/neg-blame + 'set/c28 + '(let ([s (contract (set/c integer? #:lazy? #t #:kind 'dont-care) + (mutable-set #f) 'pos 'neg)]) + (set-add! s "x"))) + + (test/neg-blame + 'set/c29 + '(let ([s (contract (set/c integer? #:lazy? #f #:kind 'mutable) + (mutable-set 0) 'pos 'neg)]) + (set-add! s "x"))) + + (test/spec-passed + 'set/c30 + '(let () + (define-custom-set-types set2 equal?) + (set-add + (contract (set/c (-> integer? integer?)) + (make-immutable-set2) + 'pos 'neg) + add1))) + + (test/spec-passed + 'set/c31 + '(let () + (define-custom-set-types set2 equal?) + (set-add + (contract (set/c (-> integer? integer?)) + (make-immutable-set2) + 'pos 'neg) + add1))) + + (test/pos-blame + 'set/c32 + '(let () + (define-custom-set-types set2 equal? (λ (p) (p #f) 0)) + (set-add (contract (set/c (-> integer? boolean?) + #:equal-key/c (-> integer? boolean?)) + (make-immutable-set2) + 'pos 'neg) + (λ (x) (zero? (+ x 1)))))) + + (test/spec-passed + 'set/c33 + '(let () + (define-custom-set-types set2 equal? (λ (p) (p 0) 0)) + (set-add (contract (set/c (-> integer? boolean?) + #:equal-key/c (-> integer? boolean?)) + (make-immutable-set2) + 'pos 'neg) + (λ (x) (zero? (+ x 1)))))) + + ) diff --git a/pkgs/racket-test/tests/racket/contract/stream.rkt b/pkgs/racket-test/tests/racket/contract/stream.rkt index 81c15f22e5..50ea9373d1 100644 --- a/pkgs/racket-test/tests/racket/contract/stream.rkt +++ b/pkgs/racket-test/tests/racket/contract/stream.rkt @@ -31,4 +31,14 @@ (test/pos-blame 'stream/c7 '(stream-first (stream-rest (contract (stream/c (and/c integer? (or/c 0 positive?))) + (stream 0 -1) 'pos 'neg)))) + + (test/spec-passed + 'stream/c8 + '(stream-first (stream-rest (contract (stream/c (and/c integer? (first-or/c 0 positive?))) + (in-naturals) 'pos 'neg)))) + + (test/pos-blame + 'stream/c9 + '(stream-first (stream-rest (contract (stream/c (and/c integer? (first-or/c 0 positive?))) (stream 0 -1) 'pos 'neg))))) diff --git a/pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-test/tests/racket/contract/stronger.rkt index 1a159ab71a..53069f2bbb 100644 --- a/pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -10,6 +10,7 @@ (contract-eval '(define-contract-struct triple (a b c))) (ctest #t contract-stronger? any/c any/c) + (ctest #t contract-stronger? integer? any/c) (ctest #t contract-stronger? (integer-in 0 4) (integer-in 0 4)) (ctest #t contract-stronger? (integer-in 1 3) (integer-in 0 4)) (ctest #f contract-stronger? (integer-in 0 4) (integer-in 1 3)) @@ -72,7 +73,11 @@ (-> integer? #:x integer? integer?) (-> integer? #:x integer? integer?)) (ctest #t contract-stronger? (-> #:x (>=/c 3) (>=/c 3)) (-> #:x (>=/c 3) (>=/c 2))) - + (ctest #t contract-stronger? (-> any/c any/c any) (-> any/c any/c any)) + (ctest #f contract-stronger? (-> any/c any/c any/c any) (-> any/c any/c any)) + (ctest #t contract-stronger? (-> (-> any/c) integer?) (-> (-> any/c) any/c)) + (ctest #f contract-stronger? (-> (-> any/c) any/c) (-> (-> any/c) integer?)) + (let ([c (contract-eval '(->* () () any))]) (test #t (contract-eval 'contract-stronger?) c c)) (let ([c (contract-eval '(->d () () any))]) @@ -87,8 +92,8 @@ (->* () integer? #:post (zero? (random 10))) (->* () integer? #:post (zero? (random 10)))) - (ctest #t contract-stronger? (or/c null? any/c) (or/c null? any/c)) - (ctest #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c)) + (ctest #t contract-stronger? (or/c null? #f) (or/c null? #f)) + (ctest #f contract-stronger? (or/c null? #f) (or/c boolean? #f)) (ctest #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?)) (ctest #t contract-stronger? (or/c null? boolean?) (or/c boolean? null?)) (ctest #t contract-stronger? @@ -108,6 +113,38 @@ (ctest #t contract-stronger? (-> (or/c #f number?) any/c) (-> number? any/c)) (ctest #f contract-stronger? (-> (or/c #f number?)) (-> number?)) (ctest #f contract-stronger? (-> number? any/c) (-> (or/c #f number?) any/c)) + + (ctest #t contract-stronger? (first-or/c null? #f) (first-or/c null? #f)) + (ctest #f contract-stronger? (first-or/c null? #f) (first-or/c boolean? #f)) + (ctest #t contract-stronger? (first-or/c null? boolean?) (first-or/c null? boolean?)) + (ctest #t contract-stronger? (first-or/c null? boolean?) (first-or/c boolean? null?)) + (ctest #t contract-stronger? + (first-or/c null? (-> integer? integer?)) + (first-or/c null? (-> integer? integer?))) + (ctest #f contract-stronger? + (first-or/c null? (-> boolean? boolean?)) + (first-or/c null? (-> integer? integer?))) + (ctest #f contract-stronger? (first-or/c number? #f) number?) + (ctest #t contract-stronger? number? (first-or/c number? #f)) + (ctest #f contract-stronger? (first-or/c (-> number? number?) #f) (-> number? number?)) + (ctest #t contract-stronger? (-> number? number?) (first-or/c (-> number? number?) #f)) + (ctest #f contract-stronger? (first-or/c (-> number? number?) (-> number? number? number?) #f) #f) + (ctest #t contract-stronger? #f (first-or/c (-> number? number?) (-> number? number? number?) #f)) + (ctest #t contract-stronger? (first-or/c real?) (first-or/c integer? real?)) + (ctest #t contract-stronger? (-> number?) (-> (first-or/c #f number?))) + (ctest #t contract-stronger? (-> (first-or/c #f number?) any/c) (-> number? any/c)) + (ctest #f contract-stronger? (-> (first-or/c #f number?)) (-> number?)) + (ctest #f contract-stronger? (-> number? any/c) (-> (first-or/c #f number?) any/c)) + + (ctest #t contract-stronger? (first-or/c null? #f) (or/c null? #f)) + (ctest #f contract-stronger? (first-or/c null? #f) (or/c boolean? #f)) + (ctest #t contract-stronger? (first-or/c null? boolean?) (or/c null? boolean?)) + (ctest #t contract-stronger? (first-or/c null? boolean?) (or/c boolean? null?)) + + (ctest #t contract-stronger? (or/c null? #f) (first-or/c null? #f)) + (ctest #f contract-stronger? (or/c null? #f) (first-or/c boolean? #f)) + (ctest #t contract-stronger? (or/c null? boolean?) (first-or/c null? boolean?)) + (ctest #t contract-stronger? (or/c null? boolean?) (first-or/c boolean? null?)) (ctest #t contract-stronger? number? number?) (ctest #f contract-stronger? boolean? number?) @@ -142,7 +179,7 @@ (or/c (-> string?) (-> integer? integer?)) (or/c (-> string?) (-> any/c integer?))) (ctest #f contract-stronger? - (or/c (-> string?) (-> any/c integer?)) + (or/c (-> string?) (-> #f integer?)) (or/c (-> string?) (-> integer? integer?))) (ctest #t contract-stronger? (or/c (-> string?) (-> integer? integer?) integer? boolean?) @@ -226,6 +263,10 @@ `(let () (define x (flat-rec-contract x (or/c (cons/c x '()) '()))) (,test #t contract-stronger? x (or/c (cons/c x '()) '())))) + (contract-eval + `(let () + (define x (flat-rec-contract x (first-or/c (cons/c x '()) '()))) + (,test #t contract-stronger? x (first-or/c (cons/c x '()) '())))) (ctest #t contract-stronger? "x" string?) (ctest #f contract-stronger? string? "x") @@ -263,10 +304,13 @@ (ctest #f contract-stronger? (syntax/c (<=/c 4)) (syntax/c (<=/c 3))) (ctest #t contract-stronger? (parametric->/c (x) (-> x x)) (parametric->/c (x) (-> x (or/c x #f)))) + (ctest #t contract-stronger? (parametric->/c (x) (-> x x)) (parametric->/c (x) (-> x (first-or/c x #f)))) (ctest #f contract-stronger? (parametric->/c (x y) (-> x y)) (parametric->/c (x y) (-> x x y))) (contract-eval `(define α (new-∀/c))) (ctest #t contract-stronger? (-> α α) (-> α (or/c #f α))) (ctest #f contract-stronger? (-> α (or/c #f α)) (-> α α)) + (ctest #t contract-stronger? (-> α α) (-> α (first-or/c #f α))) + (ctest #f contract-stronger? (-> α (first-or/c #f α)) (-> α α)) (ctest #t contract-stronger? (class/c (m (-> any/c (<=/c 3)))) @@ -400,6 +444,9 @@ (ctest #f contract-stronger? (implementation?/c one-interface<%>) (implementation?/c another-interface<%>)) + + (ctest #t contract-stronger? (evt/c integer?) (evt/c integer?)) + (ctest #f contract-stronger? (evt/c integer?) (evt/c boolean?)) ;; chances are, this predicate will accept "x", but ;; we don't want to consider it stronger, since it @@ -464,6 +511,64 @@ [c (a b) (or/c #f (mk-c a))]))]) (,test #t contract-stronger? (mk-c 1) (mk-c 2))))) + (contract-eval + `(let () + (define (non-zero? x) (not (zero? x))) + (define list-of-numbers + (first-or/c null? + (couple/c number? + (recursive-contract list-of-numbers)))) + (define (short-list/less-than n) + (first-or/c null? + (couple/c (<=/c n) + (first-or/c null? + (couple/c (<=/c n) + any/c))))) + (define (short-sorted-list/less-than n) + (first-or/c null? + (couple/dc + [hd (<=/c n)] + [tl (hd) (first-or/c null? + (couple/c (<=/c hd) + any/c))]))) + + (define (sorted-list/less-than n) + (first-or/c null? + (couple/dc + [hd (<=/c n)] + [tl (hd) (sorted-list/less-than hd)]))) + + ;; for some reason, the `n' makes it harder to optimize. + ;; without it, this test isn't as good a test + (define (closure-comparison-test n) + (couple/dc + [hd any/c] + [tl (hd) any/c])) + + (,test #t contract-stronger? (couple/c any/c any/c) (couple/c any/c any/c)) + (,test #f contract-stronger? (couple/c (>=/c 2) (>=/c 3)) (couple/c (>=/c 4) (>=/c 5))) + (,test #t contract-stronger? (couple/c (>=/c 4) (>=/c 5)) (couple/c (>=/c 2) (>=/c 3))) + (,test #f contract-stronger? (couple/c (>=/c 1) (>=/c 5)) (couple/c (>=/c 5) (>=/c 1))) + (let ([ctc (couple/dc [hd any/c] [tl (hd) any/c])]) + (,test #t contract-stronger? ctc ctc)) + (let ([ctc (couple/dc [hd any/c] [tl (hd) (<=/c hd)])]) + (,test #t contract-stronger? ctc ctc)) + (,test #t contract-stronger? list-of-numbers list-of-numbers) + (,test #t contract-stronger? (short-list/less-than 4) (short-list/less-than 5)) + (,test #f contract-stronger? (short-list/less-than 5) (short-list/less-than 4)) + (,test #t contract-stronger? (short-sorted-list/less-than 4) (short-sorted-list/less-than 5)) + (,test #f contract-stronger? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4)) + (,test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5)) + (,test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4)) + (,test #t contract-stronger? (closure-comparison-test 4) (closure-comparison-test 5)) + + (letrec ([mk-c + (λ (x) + (triple/dc [a (<=/c x)] + [b any/c] + [c (a b) (or/c #f (mk-c a))]))]) + (,test #t contract-stronger? (mk-c 1) (mk-c 2))))) + (contract-eval `(let () diff --git a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt index 5da41f8604..bc510a082e 100644 --- a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt +++ b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt @@ -416,6 +416,22 @@ 'pos 'neg)))) 2) + + (test/spec-passed/result + 'struct/dc-12b + '(let () + (struct kons (hd tl) #:transparent) + (define (unknown-function a) (=/c a)) + (define-opt/c (f a b) + (first-or/c not + (struct/dc kons + [hd (unknown-function a)] + [tl () #:lazy (first-or/c #f (f b a))]))) + (kons-hd (kons-tl (contract (f 1 2) + (kons 1 (kons 2 #f)) + 'pos + 'neg)))) + 2) (test/spec-passed 'struct/dc-13 diff --git a/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt b/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt new file mode 100644 index 0000000000..45d8023be1 --- /dev/null +++ b/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt @@ -0,0 +1,77 @@ +#lang racket/base + +(require "test-util.rkt") + +(parameterize ([current-contract-namespace + (make-basic-contract-namespace)]) + (test/spec-passed + 'struct-type-prop.1 + '(let () + (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop)) + (define app-prop (contract (-> prop? integer? boolean?) + (λ (x v) (((prop-ref x) x) v)) + 'pos1 'neg1)) + (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?))) + _prop + 'pos2 'neg2)) + (struct s (f) #:property prop (λ (x) (s-f x))) + (define s1 (s even?)) + (app-prop s1 5))) + + (test/neg-blame + 'struct-type-prop.2 + '(let () + (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop)) + (define app-prop (contract (-> prop? integer? boolean?) + (λ (x v) (((prop-ref x) x) v)) + 'pos1 'neg1)) + (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?))) + _prop + 'pos2 'neg2)) + (struct s (f) #:property prop (λ (x) (s-f x))) + (define s1 (s even?)) + (app-prop s1 'apple))) + + (test/neg-blame + 'struct-type-prop.3 + '(let () + (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop)) + (define app-prop (contract (-> prop? integer? boolean?) + (λ (x v) (((prop-ref x) x) v)) + 'pos1 'neg1)) + (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?))) + _prop + 'pos 'neg)) + (struct s (f) #:property prop (λ (x) (s-f x))) + (define s2 (s "not a fun")) + (app-prop s2 5))) + + (test/neg-blame + 'struct-type-prop.4 + '(let () + (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop)) + (define app-prop (contract (-> prop? integer? boolean?) + (λ (x v) (((prop-ref x) x) v)) + 'pos1 'neg1)) + (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?))) + _prop + 'pos 'neg)) + (struct s (f) #:property prop (λ (x) (s-f x))) + (define s3 (s list)) + (app-prop s3 5))) + + (test/pos-blame + 'struct-type-prop.5 + '(let () + (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop)) + (define app-prop (contract (-> prop? integer? boolean?) + (λ (x v) (((prop-ref x) x) v)) + 'pos1 'neg1)) + (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?))) + _prop + 'pos2 'neg2)) + (struct s (f) #:property prop (λ (x) (s-f x))) + (define s3 (s list?)) + ((prop-ref s3) 'apple))) + + ) diff --git a/pkgs/racket-test/tests/racket/contract/tail.rkt b/pkgs/racket-test/tests/racket/contract/tail.rkt index 708b376ce0..024f0fe544 100644 --- a/pkgs/racket-test/tests/racket/contract/tail.rkt +++ b/pkgs/racket-test/tests/racket/contract/tail.rkt @@ -85,6 +85,29 @@ (c))) (ctest/rewrite '(1) + mut-rec-with-any + (let () + (define f + (contract (-> number? any) + (lambda (x) + (if (zero? x) + (continuation-mark-set->list (current-continuation-marks) + 'tail-test) + (with-continuation-mark 'tail-test x + (g (- x 1))))) + 'something-that-is-not-pos + 'neg)) + + (define g + (contract (-> number? any) + (lambda (x) + (f x)) + 'also-this-is-not-pos + 'neg)) + + (f 3))) + + (ctest/rewrite '(1 2 3) mut-rec-with-any/c (let () (define f diff --git a/pkgs/racket-test/tests/racket/contract/test-util.rkt b/pkgs/racket-test/tests/racket/contract/test-util.rkt index d802643daf..e8856fd2a5 100644 --- a/pkgs/racket-test/tests/racket/contract/test-util.rkt +++ b/pkgs/racket-test/tests/racket/contract/test-util.rkt @@ -13,6 +13,7 @@ current-contract-namespace make-basic-contract-namespace make-full-contract-namespace + full-contract-namespace-initial-set contract-syntax-error-test contract-error-test @@ -104,10 +105,10 @@ (define (make-full-contract-namespace . addons) (apply make-basic-contract-namespace - 'racket/contract - 'racket/class - 'racket/set - addons)) + (append full-contract-namespace-initial-set addons))) +(define full-contract-namespace-initial-set + '(racket/contract racket/class racket/set)) + (define (contract-eval x #:test-case-name [test-case #f]) (with-handlers ((exn:fail? (λ (x) @@ -163,7 +164,7 @@ name (contract-eval #:test-case-name name `(with-handlers ((exn:fail:syntax? - (lambda (x) (and (regexp-match ,reg (exn-message x)) #t)))) + (lambda (x) (regexp-match? ,reg (exn-message x))))) (eval ',exp))))) ;; test/spec-passed : symbol sexp -> void @@ -176,7 +177,9 @@ #:test-case-name ',name 'no-exn-raised eval - '(with-handlers ([exn:fail? exn-message]) + '(with-handlers ([exn:fail? (λ (x) (cons (exn-message x) + (continuation-mark-set->context + (exn-continuation-marks x))))]) ,expression 'no-exn-raised))) (let ([new-expression (rewrite-out expression)]) @@ -279,7 +282,7 @@ (define (good-thing? l) (for/or ([x (in-list l)]) (and (symbol? x) - (regexp-match #rx"contract" (symbol->string x))))) + (regexp-match? #rx"contract" (symbol->string x))))) (cond [(and (pair? body) (eq? (car body) 'require) diff --git a/pkgs/racket-test/tests/racket/contract/value-contract.rkt b/pkgs/racket-test/tests/racket/contract/value-contract.rkt index e69625b28c..12bbec4637 100644 --- a/pkgs/racket-test/tests/racket/contract/value-contract.rkt +++ b/pkgs/racket-test/tests/racket/contract/value-contract.rkt @@ -2,7 +2,8 @@ (require "test-util.rkt") (parameterize ([current-contract-namespace - (make-basic-contract-namespace 'racket/unit 'racket/class 'racket/contract)]) + (make-basic-contract-namespace 'racket/unit 'racket/class + 'racket/contract 'racket/set)]) (ctest #f value-contract #f) (ctest #f value-contract (λ (x) x)) @@ -50,7 +51,7 @@ '(let () (define c (-> integer? integer?)) (define f (contract c (λ (x) x) 'pos 'neg)) - ;; opt/c version doesn't yet have blame, so + ;; opt/c version doesn't yet have blame, so ;; we require only that when there is blame, that the blame is right. (or (and (has-contract? f) (equal? c (value-contract f))) @@ -58,13 +59,49 @@ #t) (test/spec-passed/result - 'value-blame + 'value-blame.1 '(let () (define f (contract (-> integer? integer?) (λ (x) x) 'pos 'neg)) - ;; opt/c version doesn't yet have blame, so + ;; opt/c version doesn't yet have blame, so ;; we require only that when there is blame, that the blame is right. (or (and (has-blame? f) (blame-positive (value-blame f))) 'pos)) - 'pos)) \ No newline at end of file + 'pos) + + (test/spec-passed/result + 'value-blame.2 + '(let () + (define f + (contract (-> integer? integer?) (λ (x) x) 'pos 'neg)) + ;; opt/c version doesn't yet have blame, so + ;; we require only that when there is blame, that the blame is right. + (or (and (has-blame? f) + (blame-negative (value-blame f))) + 'neg)) + 'neg) + + (test/spec-passed/result + 'value-blame.3 + '(let () + (define f + (contract (set/c (-> integer? integer?) #:kind 'mutable) (mutable-set) 'pos 'neg)) + ;; opt/c version doesn't yet have blame, so + ;; we require only that when there is blame, that the blame is right. + (or (and (has-blame? f) + (blame-positive (value-blame f))) + 'pos)) + 'pos) + + (test/spec-passed/result + 'value-blame.4 + '(let () + (define f + (contract (set/c (-> integer? integer?) #:kind 'mutable) (mutable-set) 'pos 'neg)) + ;; opt/c version doesn't yet have blame, so + ;; we require only that when there is blame, that the blame is right. + (or (and (has-blame? f) + (blame-negative (value-blame f))) + 'neg)) + 'neg)) diff --git a/pkgs/racket-test/tests/racket/contract/vector.rkt b/pkgs/racket-test/tests/racket/contract/vector.rkt index b1971d94c2..5d169532fe 100644 --- a/pkgs/racket-test/tests/racket/contract/vector.rkt +++ b/pkgs/racket-test/tests/racket/contract/vector.rkt @@ -1,7 +1,8 @@ #lang racket/base (require "test-util.rkt") (parameterize ([current-contract-namespace - (make-basic-contract-namespace)]) + (make-basic-contract-namespace + 'racket/contract/combinator)]) (test/spec-passed 'vectorof1 @@ -127,7 +128,24 @@ 0 #f))) (test/pos-blame - 'vector/c6 + 'vector/c7 '(contract (vector/c integer? #:immutable #t) (vector-immutable #f) - 'pos 'neg))) + 'pos 'neg)) + + (test/spec-passed/result + 'vector/immutable-flat + '(let ([x (vector-immutable 1 2 3)]) + (eq? (contract (vectorof integer?) x 'pos 'neg) + x)) + '#true) + + (test/spec-passed/result + 'vector/c-impersonator + '(vector-ref (contract (vectorof (make-contract #:late-neg-projection (λ (b) (λ (x n) (+ x 1))))) + (vector 0) + 'pos 'neg) + 0) + 1) + + ) diff --git a/pkgs/racket-test/tests/setup/path-to-relative.rkt b/pkgs/racket-test/tests/setup/path-to-relative.rkt index 453eb17fef..98695247df 100644 --- a/pkgs/racket-test/tests/setup/path-to-relative.rkt +++ b/pkgs/racket-test/tests/setup/path-to-relative.rkt @@ -10,3 +10,5 @@ (path->relative-string/library (path-only (collection-file-path "base.rkt" "racket")))) (check-equal? "/racket/base.rkt" (path->relative-string/library (collection-file-path "base.rkt" "racket"))) +(check-equal? "/racket/base.rkt" + (path->relative-string/library (normal-case-path (collection-file-path "base.rkt" "racket")))) diff --git a/pkgs/racket-test/tests/syntax/free-vars.rkt b/pkgs/racket-test/tests/syntax/free-vars.rkt index 233f4a5643..50850c10ca 100644 --- a/pkgs/racket-test/tests/syntax/free-vars.rkt +++ b/pkgs/racket-test/tests/syntax/free-vars.rkt @@ -1,5 +1,6 @@ #lang racket -(require syntax/free-vars) +(require syntax/free-vars + rackunit) (parameterize ([current-namespace (make-base-namespace)]) (define (check stx) @@ -40,3 +41,9 @@ '(x) (let ([y 3]) (list x y))))) + +(check-equal? (free-vars (expand #'(+ 1 2))) + '()) +(check-pred (lambda (x) (free-identifier=? x #'+)) + (first (free-vars (expand #'(+ 1 2)) + #:module-bound? #t))) diff --git a/pkgs/racket-test/tests/zo-path.rkt b/pkgs/racket-test/tests/zo-path.rkt index 3cd85db16f..4c62b3ae75 100644 --- a/pkgs/racket-test/tests/zo-path.rkt +++ b/pkgs/racket-test/tests/zo-path.rkt @@ -1,6 +1,8 @@ #lang racket (require setup/dirs) +(provide check-one) + ;; Paths from the build location shouldn't show up in bytecode files ;; or documentation. Check ".zo", ".dep", and ".html" files in the ;; build on the assumption that the first three elements of the @@ -11,22 +13,36 @@ (regexp-quote (path->bytes (apply build-path - (take (explode-path (find-collects-dir)) + (take (explode-path (find-collects-dir)) 3)))))) -(define (check-content rx:name) - (lambda (name kind v) - (when (regexp-match? rx:name name) - (call-with-input-file* name - (lambda (in) - (when (regexp-match? rx:dir in) - (eprintf "Found ~s in ~s\n" rx:dir name))))))) +(define (check-one file) + (call-with-input-file* + file + (lambda (in) + (when (regexp-match? rx:dir in) + (eprintf "Found ~s in ~s\n" rx:dir file))))) -(fold-files (check-content #rx"[.](?:zo|dep)$") - (void) - (find-collects-dir)) +(define ((check-content rx:name) name kind v) + (when (regexp-match? rx:name name) + (check-one name))) -;; Check rendered docs, too: -(fold-files (check-content #rx"[.](?:html)$") - (void) - (find-doc-dir)) +(module+ main + (require pkg/lib) + + (define zo/dep-content (check-content #rx"[.](?:zo|dep)$")) + + (fold-files zo/dep-content + (void) + (find-collects-dir)) + + (define cache (make-hash)) + (for ([pkg (in-list (installed-pkg-names #:scope 'installation))]) + (fold-files zo/dep-content + (void) + (pkg-directory pkg #:cache cache))) + + ;; Check rendered docs, too: + (fold-files (check-content #rx"[.](?:html)$") + (void) + (find-doc-dir))) diff --git a/racket/collects/compiler/distribute.rkt b/racket/collects/compiler/distribute.rkt index c235a144d4..e026d8023a 100644 --- a/racket/collects/compiler/distribute.rkt +++ b/racket/collects/compiler/distribute.rkt @@ -11,7 +11,8 @@ "private/macfw.rkt" "private/windlldir.rkt" "private/elf.rkt" - "private/collects-path.rkt") + "private/collects-path.rkt" + "private/write-perm.rkt") (provide assemble-distribution) @@ -59,6 +60,10 @@ orig-binaries sub-dirs types)] + [old-permss (and executables? + (eq? (system-type) 'unix) + (for/list ([b (in-list binaries)]) + (ensure-writable b)))] [single-mac-app? (and executables? (eq? 'macosx (cross-system-type)) (= 1 (length types)) @@ -105,8 +110,7 @@ (make-directory* collects-dir) (make-directory* exts-dir) ;; Copy libs into place - (when executables? - (install-libs lib-dir types)) + (install-libs lib-dir types (not executables?)) ;; Copy collections into place (for-each (lambda (dir) (for-each (lambda (f) @@ -151,10 +155,13 @@ exts-dir relative-exts-dir relative->binary-relative) + ;; Restore executable permissions: + (when old-permss + (map done-writable binaries old-permss)) ;; Done! (void)))))) - (define (install-libs lib-dir types) + (define (install-libs lib-dir types extras-only?) (case (cross-system-type) [(windows) (let ([copy-dll (lambda (name) @@ -169,52 +176,55 @@ (map copy-dll (list "libiconv-2.dll" "longdouble.dll")) - (when (or (memq 'racketcgc types) - (memq 'gracketcgc types)) - (map copy-dll - (list - (versionize "libracket~a.dll") - (versionize "libmzgc~a.dll")))) - (when (or (memq 'racket3m types) - (memq 'gracket3m types)) - (map copy-dll - (list - (versionize "libracket3m~a.dll")))))] + (unless extras-only? + (when (or (memq 'racketcgc types) + (memq 'gracketcgc types)) + (map copy-dll + (list + (versionize "libracket~a.dll") + (versionize "libmzgc~a.dll")))) + (when (or (memq 'racket3m types) + (memq 'gracket3m types)) + (map copy-dll + (list + (versionize "libracket3m~a.dll"))))))] [(macosx) - (when (or (memq 'racketcgc types) - (memq 'gracketcgc types)) - (copy-framework "Racket" #f lib-dir)) - (when (or (memq 'racket3m types) - (memq 'gracket3m types)) - (copy-framework "Racket" #t lib-dir))] + (unless extras-only? + (when (or (memq 'racketcgc types) + (memq 'gracketcgc types)) + (copy-framework "Racket" #f lib-dir)) + (when (or (memq 'racket3m types) + (memq 'gracket3m types)) + (copy-framework "Racket" #t lib-dir)))] [(unix) - (let ([lib-plt-dir (build-path lib-dir "plt")]) - (unless (directory-exists? lib-plt-dir) - (make-directory lib-plt-dir)) - (let ([copy-bin - (lambda (name variant gr?) - (copy-file* (build-path (if gr? - (find-lib-dir) - (find-console-bin-dir)) - (format "~a~a" name (variant-suffix variant #f))) - (build-path lib-plt-dir - (format "~a~a-~a" name variant (version)))))]) - (when (memq 'racketcgc types) - (copy-bin "racket" 'cgc #f)) - (when (memq 'racket3m types) - (copy-bin "racket" '3m #f)) - (when (memq 'gracketcgc types) - (copy-bin "gracket" 'cgc #t)) - (when (memq 'gracket3m types) - (copy-bin "gracket" '3m #t))) - (when (shared-libraries?) - (when (or (memq 'racketcgc types) - (memq 'gracketcgc types)) - (copy-shared-lib "racket" lib-dir) - (copy-shared-lib "mzgc" lib-dir)) - (when (or (memq 'racket3m types) - (memq 'gracket3m types)) - (copy-shared-lib "racket3m" lib-dir))))])) + (unless extras-only? + (let ([lib-plt-dir (build-path lib-dir "plt")]) + (unless (directory-exists? lib-plt-dir) + (make-directory lib-plt-dir)) + (let ([copy-bin + (lambda (name variant gr?) + (copy-file* (build-path (if gr? + (find-lib-dir) + (find-console-bin-dir)) + (format "~a~a" name (variant-suffix variant #f))) + (build-path lib-plt-dir + (format "~a~a-~a" name variant (version)))))]) + (when (memq 'racketcgc types) + (copy-bin "racket" 'cgc #f)) + (when (memq 'racket3m types) + (copy-bin "racket" '3m #f)) + (when (memq 'gracketcgc types) + (copy-bin "gracket" 'cgc #t)) + (when (memq 'gracket3m types) + (copy-bin "gracket" '3m #t))) + (when (shared-libraries?) + (when (or (memq 'racketcgc types) + (memq 'gracketcgc types)) + (copy-shared-lib "racket" lib-dir) + (copy-shared-lib "mzgc" lib-dir)) + (when (or (memq 'racket3m types) + (memq 'gracket3m types)) + (copy-shared-lib "racket3m" lib-dir)))))])) (define (search-dll dll-dir dll) (if dll-dir @@ -502,7 +512,7 @@ ;; construct-dest: (lambda (src) (when src - (set! paths (cons src paths))) + (set! paths (cons (normal-case-path src) paths))) "dummy") ;; transform-entry (lambda (new-path ext) ext) @@ -511,7 +521,10 @@ exts-dir relative-exts-dir relative->binary-relative) (unless (null? paths) - ;; Determine the shared path prefix among paths within a package: + ;; Determine the shared path prefix among paths within a package, + ;; "collects" directory, or other root. That way, relative path references + ;; can work, but we don't keep excessive path information from the + ;; build machine. (let* ([root-table (make-hash)] [root->path-element (lambda (root) (hash-ref root-table @@ -520,42 +533,73 @@ (let ([v (format "r~a" (hash-count root-table))]) (hash-set! root-table root v) v))))] + [alt-paths (map explode-path + (map normal-case-path + (list* (find-system-path 'addon-dir) + (find-share-dir) + (append (get-lib-search-dirs) + (get-include-search-dirs)))))] [explode (lambda (src) + ;; Sort the path into a root, and keep the root plus + ;; the part of the path relative to that root: (define-values (pkg subpath) (path->pkg+subpath src #:cache pkg-path-cache)) (define main (and (not pkg) (path->main-collects-relative src))) + (define other (and (not pkg) + (not (pair? main)) + (let ([e (explode-path src)]) + (for/or ([d (in-list alt-paths)] + [i (in-naturals)]) + (define len (length d)) + (and ((length e) . > . len) + (equal? d (take e len)) + (cons i len)))))) (reverse (let loop ([src (cond [pkg subpath] [(pair? main) (apply build-path (map bytes->path-element (cdr main)))] + [other (apply build-path + (list-tail (explode-path src) (cdr other)))] [else src])]) (let-values ([(base name dir?) (split-path src)]) (cond [(path? base) (cons name (loop base))] + [(or pkg + (and (pair? main) + 'collects) + (and other (car other))) + => (lambda (r) + (list name (root->path-element r)))] [else - (list (root->path-element (or pkg - (and (pair? main) - 'collects) - name)))])))))] + (list (root->path-element name))])))))] ;; In reverse order, so we can pick off the paths ;; in the second pass: - [exploded (reverse (map explode paths))] - [max-len (apply max 0 (map length exploded))] - [common-len (let loop ([cnt 0]) - (cond - [((add1 cnt) . = . max-len) cnt] - [(andmap (let ([i (list-ref (car exploded) cnt)]) - (lambda (e) - (equal? (list-ref e cnt) i))) - exploded) - (loop (add1 cnt))] - [else cnt]))]) - + [exploded (reverse (let ([exploded (map explode paths)]) + ;; For paths that share the same root, + ;; drop any common "prefix" after the root. + (define roots-common + (for/fold ([ht (hash)]) ([e (in-list exploded)]) + (define l (hash-ref ht (car e) #f)) + (hash-set ht (car e) + (if (not l) + (cdr e) + (let loop ([l l] [l2 (cdr e)]) + (cond + [(or (null? l) (null? l2)) null] + [(or (null? l) (null? l2)) null] + [(equal? (car l) (car l2)) + (cons (car l) (loop (cdr l) (cdr l2)))] + [else null])))))) + ;; Drop common parts out, but deefinitely keep the last + ;; element: + (for/list ([e (in-list exploded)]) + (define l (hash-ref roots-common (car e) null)) + (cons (car e) (list-tail (cdr e) (max 0 (sub1 (length l))))))))]) ;; Pass 2: change all the paths (copy-and-patch-binaries #t #rx#"rUnTiMe-paths[)]" @@ -567,7 +611,7 @@ (lambda (src) (and src (begin0 - (apply build-path (list-tail (car exploded) common-len)) + (apply build-path (car exploded)) (set! exploded (cdr exploded))))) ;; transform-entry (lambda (new-path ext) diff --git a/racket/collects/compiler/embed.rkt b/racket/collects/compiler/embed.rkt index f95d115feb..9c58d28b80 100644 --- a/racket/collects/compiler/embed.rkt +++ b/racket/collects/compiler/embed.rkt @@ -21,6 +21,7 @@ "private/pe-rsrc.rkt" "private/collects-path.rkt" "private/configdir.rkt" + "private/write-perm.rkt" "find-exe.rkt") @@ -571,8 +572,9 @@ (if (or (null? use-submods) use-source?) null - (for/list ([m l] - #:when (member (cadr (module-compiled-name m)) use-submods)) + (for/list ([m (in-list l)] + #:when (or (member (last (module-compiled-name m)) use-submods) + (declares-always-preserved? m))) m)))] [pre-submods (extract-submods (module-compiled-submodules renamed-code #t))] [post-submods (extract-submods (module-compiled-submodules renamed-code #f))] @@ -756,6 +758,12 @@ (apply append (map accum-from-mod (module-compiled-submodules mod #f)))))) +(define (declares-always-preserved? m) + (for/or ([s (in-list + (append (module-compiled-submodules m #t) + (module-compiled-submodules m #f)))]) + (eq? (last (module-compiled-name s)) 'declare-preserve-for-embedding))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (compile-using-kernel e) @@ -825,7 +833,7 @@ (namespace-module-registry (current-namespace)) (vector mapping-table library-table)) (letrec-values ([(lookup) - (lambda (name rel-to stx load? orig) + (lambda (name rel-to stx load? for-submod? orig) (if (not (module-path? name)) ;; Bad input (orig name rel-to stx load?) @@ -1018,8 +1026,17 @@ (if a3 ;; Have it: (make-resolved-module-path (cdr a3)) - ;; Let default handler try: - (orig name rel-to stx load?)))))))))))] + (if (if for-submod? + (if (pair? name) + (if (eq? (car name) 'quote) + (assq (cadr name) mapping-table) + #f) + #f) + #f) + ;; Report that we have mappings relative to `name`: + (make-resolved-module-path (cadr name)) + ;; Let default handler try: + (orig name rel-to stx load?))))))))))))] [(embedded-resolver) (case-lambda [(name from-namespace) @@ -1055,20 +1072,26 @@ (void)) (orig name from-namespace)] [(name rel-to stx load?) - (lookup name rel-to stx load? + (lookup name rel-to stx load? #f (lambda (name rel-to stx load?) ;; For a submodule, if we have a mapping for the base name, ;; then don't try the original handler. (let-values ([(base) (if (pair? name) (if (eq? (car name) 'submod) - (lookup (cadr name) rel-to stx load? (lambda (n r s l?) #f)) + ;; Pass #t for `for-submod?`, which causes a + ;; resolved module name to be returned for a quoted + ;; module name if we have any relative mappings for it: + (lookup (cadr name) rel-to stx load? #t (lambda (n r s l?) #f)) #f) #f)]) (if base - ;; don't chain to `orig': - (make-resolved-module-path - (list* 'submod (resolved-module-path-name base) (cddr name))) + ;; don't chain to `orig'; try `lookup` again with `(submod "." ...)`, + ;; and if that still fails, just construct a submodule path: + (lookup (cons 'submod (cons "." (cddr name))) base stx load? #f + (lambda (name rel-to stx load?) + (make-resolved-module-path + (cons (resolved-module-path-name base) (cddr name))))) ;; chain to `orig': (orig name rel-to stx load?)))))])]) (current-module-name-resolver embedded-resolver)))))) @@ -1782,20 +1805,3 @@ [(list? p) (map mac-mred-collects-path-adjust p)] [(relative-path? p) (build-path 'up 'up 'up p)] [else p])) - -;; Returns #f (no change needed) or old permissions -(define (ensure-writable dest-exe) - (cond - [(member 'write (file-or-directory-permissions dest-exe)) - ;; No change needed - #f] - [else - (define old-perms - (file-or-directory-permissions dest-exe 'bits)) - (file-or-directory-permissions dest-exe (bitwise-ior old-perms #o200)) - old-perms])) - -;; Restores old permissions (if not #f) -(define (done-writable dest-exe old-perms) - (when old-perms - (file-or-directory-permissions dest-exe old-perms))) diff --git a/racket/collects/compiler/module-suffix.rkt b/racket/collects/compiler/module-suffix.rkt index f600ef7967..c89edcb07d 100644 --- a/racket/collects/compiler/module-suffix.rkt +++ b/racket/collects/compiler/module-suffix.rkt @@ -44,7 +44,14 @@ (cond [(bytes? suffix) (hash-set ht suffix #t)] [else ht]))])))) - (sort (hash-keys ht) bytesbytes (system-library-subpath #f)) #"x86_64-macosx") + (if (equal? (path->bytes (cross-system-library-subpath #f)) #"x86_64-macosx") #xFeedFacf #xFeedFace)) diff --git a/racket/collects/compiler/private/write-perm.rkt b/racket/collects/compiler/private/write-perm.rkt new file mode 100644 index 0000000000..56fdb17885 --- /dev/null +++ b/racket/collects/compiler/private/write-perm.rkt @@ -0,0 +1,21 @@ +#lang racket/base + +(provide ensure-writable + done-writable) + +;; Returns #f (no change needed) or old permissions +(define (ensure-writable dest-exe) + (cond + [(member 'write (file-or-directory-permissions dest-exe)) + ;; No change needed + #f] + [else + (define old-perms + (file-or-directory-permissions dest-exe 'bits)) + (file-or-directory-permissions dest-exe (bitwise-ior old-perms #o200)) + old-perms])) + +;; Restores old permissions (if not #f) +(define (done-writable dest-exe old-perms) + (when old-perms + (file-or-directory-permissions dest-exe old-perms))) diff --git a/racket/collects/compiler/private/xform.rkt b/racket/collects/compiler/private/xform.rkt index 38052342fe..ce0b2d9559 100644 --- a/racket/collects/compiler/private/xform.rkt +++ b/racket/collects/compiler/private/xform.rkt @@ -903,7 +903,7 @@ _isnan __isfinited __isnanl __isnan __isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinf __inline_isnanl __inline_isnan - __builtin_popcount + __builtin_popcount __builtin_clz _Generic __inline_isinff __inline_isinfl __inline_isinfd __inline_isnanf __inline_isnand __inline_isinf floor floorl ceil ceill round roundl fmod fmodl modf modfl fabs fabsl __maskrune _errno __errno diff --git a/racket/collects/db/private/sqlite3/ffi.rkt b/racket/collects/db/private/sqlite3/ffi.rkt index 2dde57c10e..d560fd16a2 100644 --- a/racket/collects/db/private/sqlite3/ffi.rkt +++ b/racket/collects/db/private/sqlite3/ffi.rkt @@ -1,15 +1,18 @@ #lang racket/base -(require (for-syntax racket/base) +(require (for-syntax racket/base + setup/cross-system) racket/runtime-path ffi/unsafe - ffi/unsafe/define) + ffi/unsafe/define + setup/cross-system) (require "ffi-constants.rkt") (provide (all-from-out "ffi-constants.rkt") (protect-out (all-defined-out))) ;; raco distribute should include Racket's sqlite3 if present (define-runtime-path sqlite-so - (case (system-type) + #:runtime?-id runtime? + (case (if runtime? (system-type) (cross-system-type)) [(windows) '(so "sqlite3")] [else '(so "libsqlite3" ("0" #f))])) diff --git a/racket/collects/ffi/com.rkt b/racket/collects/ffi/com.rkt index be1f5a42c1..71b8ac10cf 100644 --- a/racket/collects/ffi/com.rkt +++ b/racket/collects/ffi/com.rkt @@ -14,7 +14,7 @@ com-release com-object-type com-type? com-type=? - com-methods com-method-type com-invoke com-omit + com-methods com-method-type com-invoke com-omit com-omit? com-get-properties com-get-property-type com-get-property com-get-property* com-set-properties com-set-property-type com-set-property! diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index 12ad43c6d6..58dc55fd7d 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -2,7 +2,7 @@ ;; Foreign Racket interface (require '#%foreign setup/dirs racket/unsafe/ops racket/private/for - (for-syntax racket/base racket/list syntax/stx + (for-syntax racket/base racket/list syntax/stx racket/syntax racket/struct-info)) (provide ctype-sizeof ctype-alignof compiler-sizeof @@ -1334,9 +1334,12 @@ (provide define-cpointer-type) (define-syntax (define-cpointer-type stx) (syntax-case stx () - [(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)] - [(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)] - [(_ _TYPE ptr-type scheme->c c->scheme) + [(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f #:tag #f)] + [(_ _TYPE #:tag the-tag) #'(define-cpointer-type _TYPE #f #f #f #:tag the-tag)] + [(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f #:tag #f)] + [(_ _TYPE ptr-type #:tag the-tag) #'(define-cpointer-type _TYPE ptr-type #f #f #:tag the-tag)] + [(_ _TYPE ptr-type scheme->c c->scheme) #'(define-cpointer-type _TYPE ptr-type #f #f #:tag #f)] + [(_ _TYPE ptr-type scheme->c c->scheme #:tag the-tag) (and (identifier? #'_TYPE) (regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE)))) (let ([name (cadr (regexp-match #rx"^_(.+)$" @@ -1348,15 +1351,15 @@ [TYPE? (id name "?")] [TYPE-tag (id name "-tag")] [_TYPE/null (id "_" name "/null")]) - #'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag) - (let ([TYPE-tag 'TYPE]) - ;; Make the predicate function have the right inferred name - (define (TYPE? x) - (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))) - (values (_cpointer TYPE-tag ptr-type scheme->c c->scheme) - (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme) - TYPE? - TYPE-tag)))))])) + #'(begin + (define TYPE-tag (or the-tag 'TYPE)) + (define _TYPE + (_cpointer TYPE-tag ptr-type scheme->c c->scheme)) + (define _TYPE/null + (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme)) + ;; Make the predicate function have the right inferred name + (define (TYPE? x) + (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))))))])) ;; ---------------------------------------------------------------------------- ;; Struct wrappers @@ -1423,9 +1426,14 @@ ;; type. (provide define-cstruct) (define-syntax (define-cstruct stx) - (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx slot-offsets-stx - alignment-stx malloc-mode-stx property-stxes property-binding-stxes - no-equal?) + (define (make-syntax + _TYPE-stx has-super? slot-names-stx slot-types-stx slot-offsets-stx + alignment-stx malloc-mode-stx property-stxes property-binding-stxes + no-equal? define-unsafe?) + (define change-unsafe-ids + (if define-unsafe? + (λ (x) x) + generate-temporaries)) (define name (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) (define slot-names (map (lambda (x) (symbol->string (syntax-e x))) @@ -1472,10 +1480,14 @@ [TYPE->list* (id name"->list*")] [TYPE-tag (id name"-tag")] [(stype ...) (ids (lambda (s) `(,name"-",s"-type")))] + [(unsafe-TYPE-SLOT ...) + (change-unsafe-ids (ids (lambda (s) `("unsafe-",name"-",s))))] + [(unsafe-set-TYPE-SLOT! ...) + (change-unsafe-ids (ids (lambda (s) `("unsafe-set-",name"-",s"!"))))] [(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))] [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))] - [(offset ...) (generate-temporaries - (ids (lambda (s) `(,s"-offset"))))] + [(offset ...) + (change-unsafe-ids (ids (lambda (s) `(,name"-",s"-offset"))))] [alignment alignment-stx] [malloc-mode (or malloc-mode-stx #'(quote atomic))]) (with-syntax ([get-super-info @@ -1491,42 +1503,39 @@ [add-equality-property (if no-equal? #'values #'add-equality-property)]) - #'(define-values (make-wrap-TYPE struct:cpointer:TYPE) - (let () - (define-values (struct:cpointer:TYPE - cpointer:TYPE - ? - ref - set) - (make-struct-type 'cpointer:TYPE - struct:cpointer:super - (if struct:cpointer:super - 0 - 1) - 0 #f - (add-equality-property - (append - (if struct:cpointer:super - null - (list - (cons prop:cpointer 0))) - (list prop ...))) - (current-inspector) - #f - (if struct:cpointer:super - null - '(0)))) - (values cpointer:TYPE struct:cpointer:TYPE)))))] + #'(define-values (struct:cpointer:TYPE + make-wrap-TYPE + _? + _ref + _set) + (make-struct-type 'cpointer:TYPE + struct:cpointer:super + (if struct:cpointer:super + 0 + 1) + 0 #f + (add-equality-property + (append + (if struct:cpointer:super + null + (list + (cons prop:cpointer 0))) + (list prop ...))) + (current-inspector) + #f + (if struct:cpointer:super + null + '(0))))))] [define-wrap-type (if (null? property-stxes) - #'(define (wrap-TYPE-type t) - (super-wrap-type-type t)) + #'(define wrap-TYPE-type + (procedure-rename super-wrap-type-type 'wrap-TYPE-type)) #'(define (wrap-TYPE-type t) (make-ctype t - values + (λ (x) x) (lambda (p) (and p (make-wrap-TYPE p))))))] - [(property-binding ...) property-binding-stxes] + [([(property-binding-ids ...) . property-binding-form] ...) property-binding-stxes] [(maybe-struct:TYPE ...) (if (null? property-stxes) null (list #'struct:cpointer:TYPE))]) @@ -1540,118 +1549,119 @@ (reverse (list (quote-syntax TYPE-SLOT) ...)) (reverse (list (quote-syntax set-TYPE-SLOT!) ...)) #t)))) - (define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag - make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... - list->TYPE list*->TYPE TYPE->list TYPE->list* - maybe-struct:TYPE ...) - (let-values ([(super-pointer super-tags super-types super-offsets - super->list* list*->super - struct:cpointer:super super-wrap-type-type) - get-super-info] - property-binding ...) - (define-cpointer-type _TYPE super-pointer) - define-wrap-type - ;; these make it possible to use recursive pointer definitions - (define _TYPE-pointer (wrap-TYPE-type _TYPE)) - (define _TYPE-pointer/null (wrap-TYPE-type _TYPE/null)) - (define-values (stype ...) (values slot-type ...)) - (define types (list stype ...)) - (define alignment-v alignment) - (define offsets (compute-offsets types alignment-v (list slot-offset ...))) - (define-values (offset ...) (apply values offsets)) - (define all-tags (cons TYPE-tag super-tags)) - (define _TYPE* - ;; c->scheme adjusts all tags - (let* ([cst (make-cstruct-type types #f alignment-v)] - [t (_cpointer TYPE-tag cst)] - [c->s (ctype-c->scheme t)]) - (wrap-TYPE-type - (make-ctype cst (ctype-scheme->c t) - ;; hack: modify & reuse the procedure made by _cpointer - (lambda (p) - (if p (set-cpointer-tag! p all-tags) (c->s p)) - p))))) - (define-values (all-types all-offsets) - (if (and has-super? super-types super-offsets) - (values (append super-types (cdr types)) - (append super-offsets (cdr offsets))) - (values types offsets))) - (define (TYPE-SLOT x) - (unless (TYPE? x) - (raise-argument-error 'TYPE-SLOT struct-string x)) - (ptr-ref x stype 'abs offset)) - ... - (define (set-TYPE-SLOT! x slot) - (unless (TYPE? x) - (raise-argument-error 'set-TYPE-SLOT! struct-string 0 x slot)) - (ptr-set! x stype 'abs offset slot)) - ... - (define make-TYPE - (if (and has-super? super-types super-offsets) - ;; init using all slots - (lambda vals - (if (= (length vals) (length all-types)) - (let ([block (make-wrap-TYPE (malloc _TYPE* malloc-mode))]) - (set-cpointer-tag! block all-tags) - (for-each (lambda (type ofs value) - (ptr-set! block type 'abs ofs value)) - all-types all-offsets vals) - block) - (error '_TYPE "expecting ~s values, got ~s: ~e" - (length all-types) (length vals) vals))) - ;; normal initializer - (lambda (slot ...) - (let ([block (make-wrap-TYPE (malloc _TYPE* malloc-mode))]) + (define-values (super-pointer super-tags super-types super-offsets + super->list* list*->super + struct:cpointer:super super-wrap-type-type) + get-super-info) + (define-values (property-binding-ids ...) . property-binding-form) ... + (define-cpointer-type _^TYPE super-pointer #:tag 'TYPE) + define-wrap-type + ;; these make it possible to use recursive pointer definitions + (define _TYPE-pointer (wrap-TYPE-type _^TYPE)) + (define _TYPE-pointer/null (wrap-TYPE-type _^TYPE/null)) + (define-values (stype ...) (values slot-type ...)) + (define types (list stype ...)) + (define alignment-v alignment) + (define offsets (compute-offsets types alignment-v (list slot-offset ...))) + (define-values (offset ...) (apply values offsets)) + (define all-tags (cons ^TYPE-tag super-tags)) + (define _TYPE + ;; c->scheme adjusts all tags + (let* ([cst (make-cstruct-type types #f alignment-v)] + [t (_cpointer ^TYPE-tag cst)] + [c->s (ctype-c->scheme t)]) + (wrap-TYPE-type + (make-ctype cst (ctype-scheme->c t) + ;; hack: modify & reuse the procedure made by _cpointer + (lambda (p) + (if p (set-cpointer-tag! p all-tags) (c->s p)) + p))))) + (define-values (all-types all-offsets) + (if (and has-super? super-types super-offsets) + (values (append super-types (cdr types)) + (append super-offsets (cdr offsets))) + (values types offsets))) + + (begin + (define (unsafe-TYPE-SLOT x) + (ptr-ref x stype 'abs offset)) + (define (TYPE-SLOT x) + (unless (^TYPE? x) + (raise-argument-error 'TYPE-SLOT struct-string x)) + (unsafe-TYPE-SLOT x))) + ... + (begin + (define (unsafe-set-TYPE-SLOT! x slot) + (ptr-set! x stype 'abs offset slot)) + (define (set-TYPE-SLOT! x slot) + (unless (^TYPE? x) + (raise-argument-error 'set-TYPE-SLOT! struct-string 0 x slot)) + (unsafe-set-TYPE-SLOT! x slot))) + ... + (define make-TYPE + (if (and has-super? super-types super-offsets) + ;; init using all slots + (lambda vals + (if (= (length vals) (length all-types)) + (let ([block (make-wrap-TYPE (malloc _TYPE malloc-mode))]) (set-cpointer-tag! block all-tags) - (ptr-set! block stype 'abs offset slot) - ... - block)))) - define-wrapper-struct - (define (list->TYPE vals) (apply make-TYPE vals)) - (define (list*->TYPE vals) - (cond - [(TYPE? vals) vals] - [(= (length vals) (length all-types)) - (let ([block (malloc _TYPE* malloc-mode)]) + (for-each (lambda (type ofs value) + (ptr-set! block type 'abs ofs value)) + all-types all-offsets vals) + block) + (error '_TYPE "expecting ~s values, got ~s: ~e" + (length all-types) (length vals) vals))) + ;; normal initializer + (lambda (slot ...) + (let ([block (make-wrap-TYPE (malloc _TYPE malloc-mode))]) (set-cpointer-tag! block all-tags) - (for-each - (lambda (type ofs value) - (let-values - ([(ptr tags types offsets T->list* list*->T struct:T wrap) - (cstruct-info - type - (lambda () (values #f '() #f #f #f #f #f values)))]) - (ptr-set! block type 'abs ofs - (if list*->T (list*->T value) value)))) - all-types all-offsets vals) - block)] - [else (error '_TYPE "expecting ~s values, got ~s: ~e" - (length all-types) (length vals) vals)])) - (define (TYPE->list x) - (unless (TYPE? x) - (raise-argument-error 'TYPE-list struct-string x)) - (map (lambda (type ofs) (ptr-ref x type 'abs ofs)) - all-types all-offsets)) - (define (TYPE->list* x) - (unless (TYPE? x) - (raise-argument-error 'TYPE-list struct-string x)) - (map (lambda (type ofs) - (let-values - ([(v) (ptr-ref x type 'abs ofs)] - [(ptr tags types offsets T->list* list*->T struct:T wrap) - (cstruct-info - type - (lambda () (values #f '() #f #f #f #f #f values)))]) - (if T->list* (T->list* v) v))) - all-types all-offsets)) - (cstruct-info - _TYPE* 'set! - _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE - struct:cpointer:TYPE wrap-TYPE-type) - (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag - make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... - list->TYPE list*->TYPE TYPE->list TYPE->list* - maybe-struct:TYPE ...))))))) + (ptr-set! block stype 'abs offset slot) + ... + block)))) + define-wrapper-struct + (define (list->TYPE vals) (apply make-TYPE vals)) + (define (list*->TYPE vals) + (cond + [(^TYPE? vals) vals] + [(= (length vals) (length all-types)) + (let ([block (malloc _TYPE malloc-mode)]) + (set-cpointer-tag! block all-tags) + (for-each + (lambda (type ofs value) + (let-values + ([(ptr tags types offsets T->list* list*->T struct:T wrap) + (cstruct-info + type + (lambda () (values #f '() #f #f #f #f #f values)))]) + (ptr-set! block type 'abs ofs + (if list*->T (list*->T value) value)))) + all-types all-offsets vals) + block)] + [else (error '_TYPE "expecting ~s values, got ~s: ~e" + (length all-types) (length vals) vals)])) + (define (TYPE->list x) + (unless (^TYPE? x) + (raise-argument-error 'TYPE-list struct-string x)) + (map (lambda (type ofs) (ptr-ref x type 'abs ofs)) + all-types all-offsets)) + (define (TYPE->list* x) + (unless (^TYPE? x) + (raise-argument-error 'TYPE-list struct-string x)) + (map (lambda (type ofs) + (let-values + ([(v) (ptr-ref x type 'abs ofs)] + [(ptr tags types offsets T->list* list*->T struct:T wrap) + (cstruct-info + type + (lambda () (values #f '() #f #f #f #f #f values)))]) + (if T->list* (T->list* v) v))) + all-types all-offsets)) + (cstruct-info + _TYPE 'set! + _^TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE + struct:cpointer:TYPE wrap-TYPE-type) + (define TYPE? ^TYPE? #;(procedure-rename 'TYPE?)) + (define TYPE-tag ^TYPE-tag))))) (define (err what . xs) (apply raise-syntax-error #f (if (list? what) (apply string-append what) what) @@ -1664,53 +1674,76 @@ (syntax-case #'type () [(t s) (values #'t #'s)] [_ (values #'type #f)])] - [(alignment malloc-mode properties property-bindings no-equal?) + [(alignment malloc-mode + properties property-bindings + no-equal? define-unsafe?) (let loop ([more #'more] [alignment #f] [malloc-mode #f] [properties null] [property-bindings null] - [no-equal? #f]) + [no-equal? #f] + [define-unsafe? #f]) (define (head) (syntax-case more () [(x . _) #'x])) (syntax-case more () [() (values alignment malloc-mode (reverse properties) (reverse property-bindings) - no-equal?)] + no-equal? + define-unsafe?)] [(#:alignment) (err "missing expression for #:alignment" (head))] [(#:alignment a . rest) (not alignment) - (loop #'rest #'a malloc-mode properties property-bindings no-equal?)] + (loop #'rest + #'a malloc-mode + properties property-bindings + no-equal? define-unsafe?)] [(#:alignment a . rest) (err "multiple specifications of #:alignment" (head))] - [(#:malloc-mode) (err "missing expression for #:malloc-mode" (head))] + [(#:malloc-mode) + (err "missing expression for #:malloc-mode" (head))] [(#:malloc-mode m . rest) (not malloc-mode) - (loop #'rest alignment #'m properties property-bindings no-equal?)] + (loop #'rest + alignment #'m + properties property-bindings + no-equal? define-unsafe?)] [(#:malloc-mode m . rest) (err "multiple specifications of #:malloc-mode" (head))] - [(#:property) (err "missing property expression for #:property" (head))] - [(#:property prop) (err "missing value expression for #:property" (head))] + [(#:property) + (err "missing property expression for #:property" (head))] + [(#:property prop) + (err "missing value expression for #:property" (head))] [(#:property prop val . rest) (let () (define prop-id (car (generate-temporaries '(prop)))) (define val-id (car (generate-temporaries '(prop-val)))) (loop #'rest - alignment - malloc-mode + alignment malloc-mode (list* #`(cons #,prop-id #,val-id) properties) (list* (list (list val-id) #'val) (list (list prop-id) #'(check-is-property prop)) property-bindings) - no-equal?))] + no-equal? define-unsafe?))] [(#:no-equal . rest) (if no-equal? (err "multiple specifications of #:no-equal" (head)) - (loop #'rest alignment malloc-mode properties property-bindings #t))] - [(x . _) (err (if (keyword? (syntax-e #'x)) - "unknown keyword" "unexpected form") - #'x)] + (loop #'rest + alignment malloc-mode + properties property-bindings + #t define-unsafe?))] + [(#:define-unsafe . rest) + (if define-unsafe? + (err "multiple specifications of #:define-unsafe" (head)) + (loop #'rest + alignment malloc-mode + properties property-bindings + no-equal? #t))] + [(x . _) + (err (if (keyword? (syntax-e #'x)) + "unknown keyword" "unexpected form") + #'x)] [else (err "bad syntax")]))]) (unless (identifier? _TYPE) (err "expecting a `_name' identifier or `(_name _super-name)'" @@ -1733,13 +1766,13 @@ #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) #`(#,_SUPER slot-type ...) #'(0 slot-offset ...) - alignment - malloc-mode - properties - property-bindings - no-equal?) + alignment malloc-mode + properties property-bindings + no-equal? define-unsafe?) (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) #`(slot-offset ...) - alignment malloc-mode properties property-bindings no-equal?))))] + alignment malloc-mode + properties property-bindings + no-equal? define-unsafe?))))] [(_ type () . more) (identifier? #'type) (err "must have either a supertype or at least one field")] diff --git a/racket/collects/ffi/unsafe/com.rkt b/racket/collects/ffi/unsafe/com.rkt index b5b18e1e92..dc2691b8dc 100644 --- a/racket/collects/ffi/unsafe/com.rkt +++ b/racket/collects/ffi/unsafe/com.rkt @@ -54,7 +54,7 @@ com-release com-object-type com-type? com-type=? - com-methods com-method-type com-invoke com-omit + com-methods com-method-type com-invoke com-omit com-omit? com-get-properties com-get-property-type com-get-property com-get-property* com-set-properties com-set-property-type com-set-property! @@ -1407,10 +1407,10 @@ (define-oleaut VariantInit (_wfun _VARIANT-pointer -> _void)) -(define com-omit +(define-values (com-omit com-omit?) (let () (struct com-omit ()) - (com-omit))) + (values (com-omit) com-omit?))) (define CY-factor 10000) @@ -1732,13 +1732,14 @@ (let loop ([dims dims] [level 1] [index null]) (define lb (SafeArrayGetLBound sa level)) (for/vector ([i (in-range (car dims))]) - (if (null? (cdr dims)) - (let ([var (make-a-VARIANT)]) - (set-VARIANT-vt! var vt) - (SafeArrayGetElement sa (reverse (cons i index)) - (extract-variant-pointer var #t)) - (variant-to-scheme var #:mode mode)) - (loop (cdr dims) (add1 level) (cons i index)))))))) + (let ([i (+ i lb)]) + (if (null? (cdr dims)) + (let ([var (make-a-VARIANT)]) + (set-VARIANT-vt! var vt) + (SafeArrayGetElement sa (reverse (cons i index)) + (extract-variant-pointer var #t)) + (variant-to-scheme var #:mode mode)) + (loop (cdr dims) (add1 level) (cons i index))))))))) (define (_IUnknown-pointer-or-com-object mode) (make-ctype diff --git a/racket/collects/file/tar.rkt b/racket/collects/file/tar.rkt index 14b9c7e79b..43a5dee977 100644 --- a/racket/collects/file/tar.rkt +++ b/racket/collects/file/tar.rkt @@ -43,8 +43,8 @@ (define 0-byte (char->integer #\0)) -(define ((tar-one-entry buf prefix get-timestamp) path) - (let* ([link? (link-exists? path)] +(define ((tar-one-entry buf prefix get-timestamp follow-links?) path) + (let* ([link? (and (not follow-links?) (link-exists? path))] [dir? (and (not link?) (directory-exists? path))] [size (if (or dir? link?) 0 (file-size path))] [p 0] ; write pointer @@ -139,9 +139,10 @@ (provide tar->output) (define (tar->output files [out (current-output-port)] #:get-timestamp [get-timestamp file-or-directory-modify-seconds] - #:path-prefix [prefix #f]) + #:path-prefix [prefix #f] + #:follow-links? [follow-links? #f]) (parameterize ([current-output-port out]) - (let* ([buf (new-block)] [entry (tar-one-entry buf prefix get-timestamp)]) + (let* ([buf (new-block)] [entry (tar-one-entry buf prefix get-timestamp follow-links?)]) (for-each entry files) ;; two null blocks end-marker (write-bytes buf) (write-bytes buf)))) @@ -151,20 +152,27 @@ (define (tar tar-file #:exists-ok? [exists-ok? #f] #:path-prefix [prefix #f] + #:path-filter [path-filter #f] + #:follow-links? [follow-links? #f] #:get-timestamp [get-timestamp file-or-directory-modify-seconds] . paths) (when (null? paths) (error 'tar "no paths specified")) (with-output-to-file tar-file #:exists (if exists-ok? 'truncate/replace 'error) - (lambda () (tar->output (pathlist-closure paths #:follow-links? #f) - #:get-timestamp get-timestamp - #:path-prefix prefix)))) + (lambda () (tar->output (pathlist-closure paths + #:follow-links? follow-links? + #:path-filter path-filter) + #:get-timestamp get-timestamp + #:path-prefix prefix + #:follow-links? follow-links?)))) ;; tar-gzip : output-file paths -> (provide tar-gzip) (define (tar-gzip tgz-file #:exists-ok? [exists-ok? #f] #:path-prefix [prefix #f] + #:path-filter [path-filter #f] + #:follow-links? [follow-links? #f] #:get-timestamp [get-timestamp file-or-directory-modify-seconds] . paths) (when (null? paths) (error 'tar-gzip "no paths specified")) @@ -173,8 +181,12 @@ (lambda () (let-values ([(i o) (make-pipe (* 1024 1024 32))]) (thread (lambda () - (tar->output (pathlist-closure paths #:follow-links? #f) o + (tar->output (pathlist-closure paths + #:follow-links? follow-links? + #:path-filter path-filter) + o #:path-prefix prefix + #:follow-links? follow-links? #:get-timestamp get-timestamp) (close-output-port o))) (gzip-through-ports diff --git a/racket/collects/net/git-checkout.rkt b/racket/collects/net/git-checkout.rkt index f41bb366f8..6ebc1caa75 100644 --- a/racket/collects/net/git-checkout.rkt +++ b/racket/collects/net/git-checkout.rkt @@ -7,7 +7,6 @@ file/gunzip file/private/check-path openssl/sha1 - openssl net/url net/head net/http-client @@ -282,11 +281,10 @@ (define (ssl-context verify?) (cond [(or (not verify?) - (getenv "GIT_SSL_NO_VERIFY") - (not ssl-available?)) + (getenv "GIT_SSL_NO_VERIFY")) (current-https-protocol)] [else - (ssl-secure-client-context)])) + 'secure])) ;; ---------------------------------------- diff --git a/racket/collects/net/head.rkt b/racket/collects/net/head.rkt index 8365326c82..e229816aa4 100644 --- a/racket/collects/net/head.rkt +++ b/racket/collects/net/head.rkt @@ -81,29 +81,35 @@ (define (extract-field field header) (if (bytes? header) - (let ([m (regexp-match-positions (make-field-start-regexp/bytes field) - header)]) - (and m - (let ([s (subbytes header - (cdaddr m) - (bytes-length header))]) - (let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]) - (if m - (subbytes s 0 (caar m)) - ;; Rest of header is this field, but strip trailing CRLFCRLF: - (regexp-replace #rx#"\r\n\r\n$" s "")))))) + (cond + [(bytes? field) + (let ([m (regexp-match-positions (make-field-start-regexp/bytes field) + header)]) + (and m + (let ([s (subbytes header + (cdaddr m) + (bytes-length header))]) + (let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]) + (if m + (subbytes s 0 (caar m)) + ;; Rest of header is this field, but strip trailing CRLFCRLF: + (regexp-replace #rx#"\r\n\r\n$" s ""))))))] + [else (raise-argument-error 'extract-field "bytes field for bytes header" 0 field header)]) ;; otherwise header & field should be strings: - (let ([m (regexp-match-positions (make-field-start-regexp field) - header)]) - (and m - (let ([s (substring header - (cdaddr m) - (string-length header))]) - (let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]) - (if m - (substring s 0 (caar m)) - ;; Rest of header is this field, but strip trailing CRLFCRLF: - (regexp-replace #rx"\r\n\r\n$" s "")))))))) + (cond + [(string? field) + (let ([m (regexp-match-positions (make-field-start-regexp field) + header)]) + (and m + (let ([s (substring header + (cdaddr m) + (string-length header))]) + (let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]) + (if m + (substring s 0 (caar m)) + ;; Rest of header is this field, but strip trailing CRLFCRLF: + (regexp-replace #rx"\r\n\r\n$" s ""))))))] + [else (raise-argument-error 'extract-field "string field for string header" 0 field header)]))) (define (replace-field field data header) (if (bytes? header) diff --git a/racket/collects/net/http-client.rkt b/racket/collects/net/http-client.rkt index f74553bb11..381e4bb913 100644 --- a/racket/collects/net/http-client.rkt +++ b/racket/collects/net/http-client.rkt @@ -9,6 +9,7 @@ [tcp-abandon-port plain-tcp-abandon-port]) openssl "win32-ssl.rkt" + "osx-ssl.rkt" file/gunzip) (define tolerant? #t) @@ -65,8 +66,13 @@ (cond [ssl? (set-http-conn-port-usual?! hc (= 443 port)) (cond + [(osx-old-openssl?) + ;; OpenSSL is either not available or too old; use + ;; native OS X tools + (set-http-conn-abandon-p! hc osx-ssl-abandon-port) + (osx-ssl-connect host port ssl-version)] [(or ssl-available? (not win32-ssl-available?)) - (set-http-conn-abandon-p! hc ssl-abandon-port) + (set-http-conn-abandon-p! hc ssl-abandon-port) (ssl-connect host port ssl-version)] [else (set-http-conn-abandon-p! hc win32-ssl-abandon-port) @@ -184,27 +190,32 @@ (define (http-conn-response-port/chunked! hc #:close? [close? #f]) (define (http-pipe-chunk ip op) + (define (done) (void)) (define crlf-bytes (make-bytes 2)) (let loop ([last-bytes #f]) - (define size-str (string-trim (read-line ip eol-type))) - (define chunk-size (string->number size-str 16)) - (unless chunk-size - (error 'http-conn-response/chunked - "Could not parse ~S as hexadecimal number" - size-str)) - (define use-last-bytes? - (and last-bytes (<= chunk-size (bytes-length last-bytes)))) - (if (zero? chunk-size) - (begin (flush-output op) - (close-output-port op)) - (let* ([bs (if use-last-bytes? - (begin - (read-bytes! last-bytes ip 0 chunk-size) - last-bytes) - (read-bytes chunk-size ip))] - [crlf (read-bytes! crlf-bytes ip 0 2)]) - (write-bytes bs op 0 chunk-size) - (loop bs))))) + (define in-v (read-line ip eol-type)) + (cond + [(eof-object? in-v) + (done)] + [else + (define size-str (string-trim in-v)) + (define chunk-size (string->number size-str 16)) + (unless chunk-size + (error 'http-conn-response/chunked + "Could not parse ~S as hexadecimal number" + size-str)) + (define use-last-bytes? + (and last-bytes (<= chunk-size (bytes-length last-bytes)))) + (if (zero? chunk-size) + (done) + (let* ([bs (if use-last-bytes? + (begin + (read-bytes! last-bytes ip 0 chunk-size) + last-bytes) + (read-bytes chunk-size ip))] + [crlf (read-bytes! crlf-bytes ip 0 2)]) + (write-bytes bs op 0 chunk-size) + (loop bs)))]))) (define-values (in out) (make-pipe PIPE-SIZE)) (define chunk-t @@ -241,11 +252,12 @@ (or (equal? method-bss #"HEAD") (equal? method-bss "HEAD") (equal? method-bss 'HEAD))) - (define raw-response-port + (define-values (raw-response-port wait-for-close?) (cond - [head? (open-input-bytes #"")] + [head? (values (open-input-bytes #"") #f)] [(regexp-member #rx#"^(?i:Transfer-Encoding: +chunked)$" headers) - (http-conn-response-port/chunked! hc #:close? #t)] + (values (http-conn-response-port/chunked! hc #:close? #t) + #t)] [(ormap (λ (h) (match (regexp-match #rx#"^(?i:Content-Length:) +(.+)$" h) [#f #f] @@ -255,9 +267,10 @@ headers) => (λ (count) - (http-conn-response-port/length! hc count #:close? close?))] + (values (http-conn-response-port/length! hc count #:close? close?) + close?))] [else - (http-conn-response-port/rest! hc)])) + (values (http-conn-response-port/rest! hc) #t)])) (define decoded-response-port (cond [head? raw-response-port] @@ -269,9 +282,13 @@ (thread (λ () (gunzip-through-ports raw-response-port out)))) - (thread + (thread (λ () (thread-wait gunzip-t) + (when wait-for-close? + ;; Wait for an EOF from the raw port before we + ;; send an output on the decoding pipe: + (copy-port raw-response-port (open-output-nowhere))) (close-output-port out))) in] [else diff --git a/racket/collects/net/osx-ssl.rkt b/racket/collects/net/osx-ssl.rkt new file mode 100644 index 0000000000..2698554ff8 --- /dev/null +++ b/racket/collects/net/osx-ssl.rkt @@ -0,0 +1,467 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/nsstring + ffi/unsafe/alloc + ffi/unsafe/atomic + ffi/unsafe/custodian + racket/port + racket/format + openssl) + +(provide osx-ssl-connect + osx-ssl-abandon-port + osx-ssl-output-port? + osx-old-openssl?) + +(define (osx-old-openssl?) + (and (eq? 'macosx (system-type)) + (or (not ssl-available?) + (not (memq 'tls12 (supported-client-protocols)))))) + +(define cf-lib + (and (eq? 'macosx (system-type)) + (ffi-lib "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) +(define net-lib + (and (eq? 'macosx (system-type)) + (ffi-lib + "/System/Library/Frameworks/CFNetwork.framework/CFNetwork" + #:fail (lambda () + ;; Path inside "CoreServices.framework" needed for OS X 10.5 + (ffi-lib "/System/Library/Frameworks/CoreServices.framework/Versions/A/Frameworks/CFNetwork.framework/CFNetwork"))))) + +(define-ffi-definer define-cf cf-lib + #:default-make-fail make-not-available) +(define-ffi-definer define-net net-lib + #:default-make-fail make-not-available) +(define-ffi-definer define-racket #f + #:default-make-fail make-not-available) + +(define _CFReadStreamRef (_cpointer/null 'CFReadStreamRef)) +(define _CFWriteStreamRef (_cpointer/null 'CFWriteStreamRef)) + +(define _CFRunLoopRef (_cpointer/null 'CFRunLoopRef)) + +(define _CFDictionaryRef (_cpointer/null 'CFDictionaryRef)) + +(define _Boolean _bool) +(define _CFIndex _long) + +(define-cf CFRelease (_fun _pointer -> _void) + #:wrap (deallocator)) + +(define retain + ((allocator CFRelease) (lambda (p) p))) + +;; Call in atomic mode to ensure `retain` calls: +(define-cf CFStreamCreatePairWithSocketToHost + (_fun (_pointer = #f) + _NSString + _int32 + (in : (_ptr o _CFReadStreamRef)) + (out : (_ptr o _CFWriteStreamRef)) + -> _void + -> (values (and in (retain in)) (and out (retain out))))) + +(define-cf CFReadStreamScheduleWithRunLoop (_fun _CFReadStreamRef _CFRunLoopRef _pointer -> _void)) +(define-cf CFWriteStreamScheduleWithRunLoop (_fun _CFWriteStreamRef _CFRunLoopRef _pointer -> _void)) + +(define-cf CFReadStreamOpen (_fun _CFReadStreamRef -> _Boolean)) +(define-cf CFWriteStreamOpen (_fun _CFWriteStreamRef -> _Boolean)) + +(define-cf CFReadStreamClose (_fun _CFReadStreamRef -> _void)) +(define-cf CFWriteStreamClose (_fun _CFWriteStreamRef -> _void)) + +(define-cf CFReadStreamHasBytesAvailable (_fun _CFReadStreamRef -> _Boolean)) +(define-cf CFReadStreamRead (_fun _CFReadStreamRef _pointer _CFIndex -> _CFIndex)) + +(define-cf CFWriteStreamCanAcceptBytes (_fun _CFWriteStreamRef -> _Boolean)) +(define-cf CFWriteStreamWrite (_fun _CFWriteStreamRef _pointer _CFIndex -> _CFIndex)) + +(define-cf kCFRunLoopDefaultMode _pointer) + +(define-cf CFRunLoopStop (_fun _CFRunLoopRef -> _void)) + +(define-cstruct _CFStreamError ([domain _int] + [error _int32])) + +(define-cf CFReadStreamGetError (_fun _CFReadStreamRef -> _CFStreamError)) +(define-cf CFWriteStreamGetError (_fun _CFWriteStreamRef -> _CFStreamError)) + +(define-cf NSStreamSocketSecurityLevelNegotiatedSSL _pointer) +(define-cf NSStreamSocketSecurityLevelKey _pointer) + +(define-net kCFStreamPropertySSLSettings _pointer) +(define-net kCFStreamSSLValidatesCertificateChain _pointer) +(define-net kCFStreamSSLLevel _pointer) + +(define-cf kCFBooleanFalse _pointer) +(define-cf kCFBooleanTrue _pointer) + +(define-net kCFStreamSocketSecurityLevelSSLv2 _pointer) +(define-net kCFStreamSocketSecurityLevelSSLv3 _pointer) +(define-net kCFStreamSocketSecurityLevelTLSv1 _pointer) +(define-net kCFStreamSocketSecurityLevelNegotiatedSSL _pointer) + +(define-cf CFReadStreamSetProperty (_fun _CFReadStreamRef _pointer _pointer -> _Boolean)) +(define-cf CFWriteStreamSetProperty (_fun _CFWriteStreamRef _pointer _pointer -> _Boolean)) + +(define-cstruct _CFStreamClientContext ([version _CFIndex] + [info _pointer] + [retain _pointer] + [release _pointer] + [copy _pointer])) + +(define-cf CFReadStreamSetClient (_fun _CFReadStreamRef + _int + (_fun #:atomic? #t + #:async-apply (lambda (f) (f)) + _CFReadStreamRef _int _pointer -> _void) + _CFStreamClientContext-pointer + -> _Boolean)) +(define-cf CFWriteStreamSetClient (_fun _CFWriteStreamRef + _int + (_fun #:atomic? #t + #:async-apply (lambda (f) (f)) + _CFWriteStreamRef _int _pointer -> _void) + _CFStreamClientContext-pointer + -> _Boolean)) + +(define kCFStreamEventNone 0) +(define kCFStreamEventOpenCompleted 1) +(define kCFStreamEventHasBytesAvailable 2) +(define kCFStreamEventCanAcceptBytes 4) +(define kCFStreamEventErrorOccurred 8) +(define kCFStreamEventEndEncountered 16) + +(define all-evts (bitwise-ior + kCFStreamEventOpenCompleted + kCFStreamEventHasBytesAvailable + kCFStreamEventCanAcceptBytes + kCFStreamEventErrorOccurred + kCFStreamEventEndEncountered)) + +(define _CFStreamStatus + (_enum '(kCFStreamStatusNotOpen + kCFStreamStatusOpening + kCFStreamStatusOpen + kCFStreamStatusReading + kCFStreamStatusWriting + kCFStreamStatusAtEnd + kCFStreamStatusClosed + kCFStreamStatusError))) + +(define-cf CFReadStreamGetStatus + (_fun _CFReadStreamRef -> _CFStreamStatus)) +(define-cf CFWriteStreamGetStatus + (_fun _CFWriteStreamRef -> _CFStreamStatus)) + + +(define-cf CFDictionaryCreate + (_fun (_pointer = #f) + (keys : (_list i _pointer)) + (vals : (_list i _pointer)) + (_CFIndex = (length keys)) + (_pointer = #f) + (_pointer = #f) + -> _CFDictionaryRef) + #:wrap (allocator CFRelease)) + +;; ---------------------------------------- + +(define-cstruct _Scheme_Proc_Sequence ([num_procs _racket] + [data _pointer] + [proc1 _pointer] + [proc2 (_fun #:atomic? #t #:async-apply (lambda (f) (f)) _pointer -> _pointer)] + [proc3 _pointer] + [proc4 (_fun #:atomic? #t #:async-apply (lambda (f) (f)) -> _pointer)]) + #:malloc-mode 'nonatomic) + +(define-racket scheme_signal_received (_fun -> _void)) + +(define _pthread (_cpointer/null 'pthread)) + +(define-racket pthread_create + (_fun (p : (_ptr o _pthread)) _pointer _pointer _pointer + -> (r : _int) + -> (and (zero? r) + p))) +(define-racket pthread_detach + (_fun _pointer -> _int)) + +(define-racket scheme_call_sequence_of_procedures-ptr _fpointer + #:c-id scheme_call_sequence_of_procedures) + +(define-cf CFRunLoopRun-ptr _fpointer + #:c-id CFRunLoopRun) +(define-cf CFRunLoopGetCurrent-ptr _fpointer + #:c-id CFRunLoopGetCurrent) + +(define stop-and-release + ((deallocator) + (lambda (run-loop) + (CFRunLoopStop run-loop) + (CFReleaseRunLoop run-loop)))) + +(define-cf CFRetainRunLoop (_fun _CFRunLoopRef -> _CFRunLoopRef) + #:c-id CFRetain + #:wrap (allocator stop-and-release)) +(define-cf CFReleaseRunLoop (_fun _pointer -> _void) + #:c-id CFRelease) + +(define (launch-run-loop-in-pthread init-reg more-retain) + (define run-loop #f) + (define done (make-semaphore)) + (define (setup r) + ;; Called in atomic mode in arbitrary Racket thread: + (set! run-loop (CFRetainRunLoop (cast r _pointer _CFRunLoopRef))) + (init-reg run-loop) + (semaphore-post done) + (scheme_signal_received) + #f) + (define (finished) + (free-immobile-cell retainer) + #f) + ;; Retains callbacks until the thread is done: + (define retainer (malloc-immobile-cell + (vector setup finished more-retain))) + (define seq (make-Scheme_Proc_Sequence 4 + #f + CFRunLoopGetCurrent-ptr + ;; `#:aync-apply` moves the following + ;; back to the main thread (in atomic mode): + setup + CFRunLoopRun-ptr + ;; `#:async-apply` here, too: + finished)) + (define pth (pthread_create #f scheme_call_sequence_of_procedures-ptr seq)) + (unless pth (error "could not start run-loop thread")) + (pthread_detach pth) + + (semaphore-wait done) + (set! done seq) ; retains `seq` until here + + run-loop) + +;; ---------------------------------------- + +(define (osx-ssl-connect host port [protocol 'auto]) + (define-syntax-rule (check-ok (op arg ...)) + (unless (op arg ...) + (error 'op "failed"))) + + (define-values (in out) + (call-as-atomic + (lambda () + (CFStreamCreatePairWithSocketToHost host port)))) + + (check-ok (CFReadStreamSetProperty in + NSStreamSocketSecurityLevelKey + NSStreamSocketSecurityLevelNegotiatedSSL)) + (check-ok (CFWriteStreamSetProperty out + NSStreamSocketSecurityLevelKey + NSStreamSocketSecurityLevelNegotiatedSSL)) + + (unless (eq? protocol 'secure) + (define d (CFDictionaryCreate + (list kCFStreamSSLValidatesCertificateChain + kCFStreamSSLLevel) + (list kCFBooleanFalse + (case protocol + [(sslv2) kCFStreamSocketSecurityLevelSSLv2] + [(sslv3) kCFStreamSocketSecurityLevelSSLv3] + [(tls tls11 tls12) kCFStreamSocketSecurityLevelTLSv1] + [else kCFStreamSocketSecurityLevelNegotiatedSSL])))) + (check-ok (CFReadStreamSetProperty in kCFStreamPropertySSLSettings d)) + (check-ok (CFWriteStreamSetProperty out kCFStreamPropertySSLSettings d)) + (CFRelease d)) + + (define in-ready (make-semaphore)) + (define out-ready (make-semaphore 1)) + + ;; These callback must be retained so that they're not GCed + ;; until the run loop is terminated: + (define in-callback (lambda (_in evt _null) + (void (semaphore-try-wait? in-ready)) + (semaphore-post in-ready) + (scheme_signal_received))) + (define out-callback (lambda (_out evt _null) + (void (semaphore-try-wait? out-ready)) + (semaphore-post out-ready) + (scheme_signal_received))) + + (define context (make-CFStreamClientContext 0 #f #f #f #f)) + (check-ok (CFReadStreamSetClient in all-evts in-callback context)) + (check-ok (CFWriteStreamSetClient out all-evts out-callback context)) + + (define run-loop + (launch-run-loop-in-pthread + ;; This function will be called as atomic within the scheduler: + (lambda (run-loop) + (CFReadStreamScheduleWithRunLoop in run-loop kCFRunLoopDefaultMode) + (CFWriteStreamScheduleWithRunLoop out run-loop kCFRunLoopDefaultMode)) + (list in-callback out-callback))) + + (check-ok (CFWriteStreamOpen out)) + (check-ok (CFReadStreamOpen in)) + + (let loop () + (when (or (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusOpening) + (eq? (CFWriteStreamGetStatus out) 'kCFStreamStatusOpening)) + (sync in-ready out-ready) + (loop))) + + (when (or (eq? (CFReadStreamGetStatus in) 'kCFStreamStatusError) + (eq? (CFWriteStreamGetStatus out) 'kCFStreamStatusError)) + (raise + (exn:fail:network + (~a "osx-ssl-connect: connection failed\n" + " address: " host "\n" + " port number: " port) + (current-continuation-marks)))) + + (define open-count 2) + (define skip-close-out? #f) + + (define in-cust-reg (register-custodian-shutdown in (lambda (v) (close!)))) + (define out-cust-reg (register-custodian-shutdown out (lambda (v) (close!)))) + + (define (close!) + (call-as-atomic + (lambda () + (set! open-count (sub1 open-count)) + (when (zero? open-count) + (unregister-custodian-shutdown in in-cust-reg) + (unregister-custodian-shutdown out out-cust-reg) + (stop-and-release run-loop) + (CFRelease in) + (CFRelease out))))) + + (define-values (in-buffer-in in-buffer-out) (make-pipe)) + (define IN-BUFFER-SIZE 4096) + (define in-buffer (make-bytes IN-BUFFER-SIZE)) + + (define lock (make-semaphore 1)) + + ;; Callbacks used below (written here so that they're allocated once): + (define (lock-unavailable/read) (wrap-evt lock (lambda () 0))) + (define (lock-unavailable/write) (wrap-evt lock (lambda () #f))) + + (define (read-in bstr) + (define n (read-bytes-avail!* bstr in-buffer-in)) + (cond + [(positive? n) n] + [(zero? n) + (void (semaphore-try-wait? in-ready)) + (cond + [(CFReadStreamHasBytesAvailable in) + (define use-bstr + (if ((bytes-length bstr) . < . IN-BUFFER-SIZE) + in-buffer + bstr)) + (define n (CFReadStreamRead in use-bstr (bytes-length use-bstr))) + (cond + [(zero? n) eof] + [(negative? n) + (raise-osx-ssl-network-error 'read-bytes + (CFReadStreamGetError in))] + [else + (cond + [(eq? use-bstr in-buffer) + (write-bytes in-buffer in-buffer-out 0 n) + ;; Try again: + 0] + [else n])])] + [(equal? (CFReadStreamGetStatus in) + 'kCFStreamStatusError) + (raise-osx-ssl-network-error 'read-bytes + (CFReadStreamGetError in))] + [else + (wrap-evt (semaphore-peek-evt in-ready) (lambda (v) 0))])])) + + (define (write-out bstr start end buffer? breakable?) + (cond + [(= start end) 0] + [else + (void (semaphore-try-wait? out-ready)) + (cond + [(CFWriteStreamCanAcceptBytes out) + (let ([n (CFWriteStreamWrite out + (if (zero? start) + bstr + (substring bstr start end)) + (- end start))]) + (cond + [(zero? n) + (wrap-evt always-evt (lambda (v) #f))] + [(negative? n) + (raise-osx-ssl-network-error 'write-bytes + (CFWriteStreamGetError out))] + [else n]))] + [(equal? (CFWriteStreamGetStatus out) + 'kCFStreamStatusError) + (raise-osx-ssl-network-error 'write-bytes + (CFWriteStreamGetError out))] + [else + (wrap-evt (semaphore-peek-evt out-ready) (lambda (v) #f))])])) + + (values (make-input-port/read-to-peek + 'osx-ssl + ;; read: + (lambda (bstr) + (call-with-semaphore + lock + read-in + lock-unavailable/read + bstr)) + ;; peek: + (lambda (bstr offset slow) + ;; Try fast peek on buffer port: + (define n (peek-bytes-avail!* bstr offset #f in-buffer-in)) + (if (zero? n) + (slow bstr offset) + n)) + (lambda () + (call-with-semaphore + lock + (lambda () + (CFReadStreamClose in) + (close!))))) + + (osx-ssl-output-port + (make-output-port + 'osx-ssl + (semaphore-peek-evt out-ready) + ;; write + (lambda (bstr start end non-block? enable-break?) + (call-with-semaphore + lock + write-out + lock-unavailable/write + bstr start end non-block? enable-break?)) + ;; close + (lambda () + (call-with-semaphore + lock + (lambda () + (unless skip-close-out? + (CFWriteStreamClose out)) + (close!))))) + ;; abandon: + (lambda (self) + (set! skip-close-out? #t) + (close-output-port self))))) + +(struct osx-ssl-output-port (port abandon) + #:property prop:output-port 0) + +(define (osx-ssl-abandon-port p) + (if (osx-ssl-output-port? p) + ((osx-ssl-output-port-abandon p) p) + (close-output-port p))) + +(define (raise-osx-ssl-network-error who err) + (raise + (exn:fail:network + (~a who ": failed " (CFStreamError->list err)) + (current-continuation-marks)))) diff --git a/racket/collects/net/url-connect.rkt b/racket/collects/net/url-connect.rkt index d644cac826..b722c48363 100644 --- a/racket/collects/net/url-connect.rkt +++ b/racket/collects/net/url-connect.rkt @@ -4,7 +4,8 @@ [tcp-connect plain-tcp-connect] [tcp-abandon-port plain-tcp-abandon-port]) openssl - "win32-ssl.rkt") + "win32-ssl.rkt" + "osx-ssl.rkt") (provide (all-defined-out)) @@ -16,14 +17,19 @@ ;; `current-connect-scheme' (define (tcp-connect host port) (cond [(equal? (current-connect-scheme) "https") - (if (or ssl-available? - (not win32-ssl-available?)) - (ssl-connect host port (current-https-protocol)) - (win32-ssl-connect host port (current-https-protocol)))] + (cond + [(osx-old-openssl?) + (osx-ssl-connect host port (current-https-protocol))] + [(or ssl-available? + (not win32-ssl-available?)) + (ssl-connect host port (current-https-protocol))] + [else + (win32-ssl-connect host port (current-https-protocol))])] [else (plain-tcp-connect host port)])) (define (tcp-abandon-port port) (cond [(ssl-port? port) (ssl-abandon-port port)] [(win32-ssl-port? port) (win32-ssl-abandon-port port)] + [(osx-ssl-output-port? port) (osx-ssl-abandon-port port)] [else (plain-tcp-abandon-port port)])) diff --git a/racket/collects/net/url.rkt b/racket/collects/net/url.rkt index 2a39e39085..2a18b5db7a 100644 --- a/racket/collects/net/url.rkt +++ b/racket/collects/net/url.rkt @@ -4,6 +4,7 @@ racket/contract/base racket/list racket/match + racket/promise (prefix-in hc: "http-client.rkt") (only-in "url-connect.rkt" current-https-protocol) "uri-codec.rkt" @@ -23,27 +24,92 @@ ;; "impure" = they have text waiting ;; "pure" = the MIME headers have been read -(define current-proxy-servers - (make-parameter null - (lambda (v) - (unless (and (list? v) - (andmap (lambda (v) - (and (list? v) - (= 3 (length v)) - (equal? (car v) "http") - (string? (car v)) - (exact-integer? (caddr v)) - (<= 1 (caddr v) 65535))) - v)) - (raise-type-error - 'current-proxy-servers - "list of list of scheme, string, and exact integer in [1,65535]" +(define proxiable-url-schemes '("http")) + +(define (env->c-p-s-entries envars) + (if (null? envars) + null + (match (getenv (car envars)) + [#f (env->c-p-s-entries (cdr envars))] + ["" null] + [(app string->url + (url (and scheme "http") #f (? string? host) (? integer? port) + _ (list) (list) #f)) + (list (list scheme host port))] + [(app string->url + (url (and scheme "http") _ (? string? host) (? integer? port) + _ _ _ _)) + (log-net/url-error "~s contains somewhat invalid proxy URL format" (car envars)) + (list (list scheme host port))] + [inv (log-net/url-error "~s contained invalid proxy URL format: ~s" + (car envars) inv) + null]))) + +(define current-proxy-servers-promise + (make-parameter (delay/sync (env->c-p-s-entries '("plt_http_proxy" "http_proxy"))))) + +(define (proxy-servers-guard v) + (unless (and (list? v) + (andmap (lambda (v) + (and (list? v) + (= 3 (length v)) + (equal? (car v) "http") + (string? (car v)) + (exact-integer? (caddr v)) + (<= 1 (caddr v) 65535))) v)) - (map (lambda (v) - (list (string->immutable-string (car v)) - (string->immutable-string (cadr v)) - (caddr v))) - v)))) + (raise-type-error + 'current-proxy-servers + "list of list of scheme, string, and exact integer in [1,65535]" + v)) + (map (lambda (v) + (list (string->immutable-string (car v)) + (string->immutable-string (cadr v)) + (caddr v))) + v)) + +(define current-proxy-servers + (make-derived-parameter current-proxy-servers-promise + proxy-servers-guard + force)) + +(define (env->n-p-s-entries envars) + (if (null? envars) + null + (match (getenv (car envars)) + [#f (env->n-p-s-entries (cdr envars))] + ["" null] + [hostnames (string-split hostnames ",")]))) + +(define current-no-proxy-servers-promise + (make-parameter (delay/sync (no-proxy-servers-guard (env->n-p-s-entries '("plt_no_proxy" "no_proxy")))))) + +(define (no-proxy-servers-guard v) + (unless (and (list? v) + (andmap (lambda (v) + (or (string? v) + (regexp? v))) + v)) + (raise-type-error 'current-no-proxy-servers + "list of string or regexp" + v)) + (map (match-lambda + [(? regexp? re) re] + [(regexp "^(\\..*)$" (list _ m)) + (regexp (string-append ".*" (regexp-quote m)))] + [(? string? s) (regexp (string-append "^"(regexp-quote s)"$"))]) + v)) + +(define current-no-proxy-servers + (make-derived-parameter current-no-proxy-servers-promise + no-proxy-servers-guard + force)) + +(define (proxy-server-for url-schm (dest-host-name #f)) + (let ((rv (assoc url-schm (current-proxy-servers)))) + (cond [(not dest-host-name) rv] + [(memf (lambda (np) (regexp-match np dest-host-name)) (current-no-proxy-servers)) #f] + [else rv]))) (define (url-error fmt . args) (raise (make-url-exception @@ -58,6 +124,7 @@ (cond [(not scheme) 80] [(string=? scheme "http") 80] [(string=? scheme "https") 443] + [(string=? scheme "git") 9418] [else (url-error "URL scheme ~s not supported" scheme)]))) ;; make-ports : url -> hc @@ -76,23 +143,24 @@ ;; -> hc (define (http://getpost-impure-port get? url post-data strings make-ports 1.1?) - (define proxy (assoc (url-scheme url) (current-proxy-servers))) + (define proxy (proxy-server-for (url-scheme url) (url-host url))) (define hc (make-ports url proxy)) (define access-string - (url->string - (if proxy - url - ;; RFCs 1945 and 2616 say: - ;; Note that the absolute path cannot be empty; if none is present in - ;; the original URI, it must be given as "/" (the server root). - (let-values ([(abs? path) - (if (null? (url-path url)) - (values #t (list (make-path/param "" '()))) - (values (url-path-absolute? url) (url-path url)))]) - (make-url #f #f #f #f abs? path (url-query url) (url-fragment url)))))) + (ensure-non-empty + (url->string + (if proxy + url + ;; RFCs 1945 and 2616 say: + ;; Note that the absolute path cannot be empty; if none is present in + ;; the original URI, it must be given as "/" (the server root). + (let-values ([(abs? path) + (if (null? (url-path url)) + (values #t (list (make-path/param "" '()))) + (values (url-path-absolute? url) (url-path url)))]) + (make-url #f #f #f #f abs? path (url-query url) (url-fragment url))))))) (hc:http-conn-send! hc access-string - #:method (if get? "GET" "POST") + #:method (if get? #"GET" #"POST") #:headers strings #:content-decode '() #:data post-data) @@ -111,16 +179,19 @@ (cond [(not scheme) (schemeless-url url)] [(or (string=? scheme "http") (string=? scheme "https")) - (define hc (http://getpost-impure-port get? url post-data strings make-ports #f)) - (http-conn-impure-port hc)] + (define hc + (http://getpost-impure-port get? url post-data strings make-ports #f)) + (http-conn-impure-port hc + #:method (if get? "GET" "POST"))] [(string=? scheme "file") (url-error "There are no impure file: ports")] [else (url-error "Scheme ~a unsupported" scheme)]))) -(define (http-conn-impure-port hc) +(define (http-conn-impure-port hc + #:method [method-bss #"GET"]) (define-values (in out) (make-pipe 4096)) (define-values (status headers response-port) - (hc:http-conn-recv! hc #:close? #t #:content-decode '())) + (hc:http-conn-recv! hc #:method method-bss #:close? #t #:content-decode '())) (fprintf out "~a\r\n" status) (for ([h (in-list headers)]) (fprintf out "~a\r\n" h)) @@ -155,7 +226,8 @@ (http://getpost-impure-port get? url post-data strings make-ports #f) - #:content-decode '() + #:method (if get? #"GET" #"POST") + #:content-decode '() #:close? #t)) response-port] [else @@ -187,7 +259,7 @@ make-ports) (and conn #t))) (define-values (status headers response-port) - (hc:http-conn-recv! hc #:close? (not conn) #:content-decode '())) + (hc:http-conn-recv! hc #:method #"GET" #:close? (not conn) #:content-decode '())) (define new-url (ormap (λ (h) @@ -321,22 +393,30 @@ [(get) "GET"] [(post) "POST"] [(head) "HEAD"] [(put) "PUT"] [(delete) "DELETE"] [(options) "OPTIONS"] [else (url-error "unsupported method: ~a" method)])] - [proxy (assoc (url-scheme url) (current-proxy-servers))] + [proxy (proxy-server-for (url-scheme url) (url-host url))] [hc (make-ports url proxy)] - [access-string (url->string - (if proxy - url - (make-url #f #f #f #f - (url-path-absolute? url) - (url-path url) - (url-query url) - (url-fragment url))))]) + [access-string + (ensure-non-empty + (url->string + (if proxy + url + (make-url #f #f #f #f + (url-path-absolute? url) + (url-path url) + (url-query url) + (url-fragment url)))))]) (hc:http-conn-send! hc access-string #:method method #:headers strings #:content-decode '() #:data data) - (http-conn-impure-port hc))) + (http-conn-impure-port hc + #:method method))) + +(define (ensure-non-empty s) + (if (string=? "" s) + "/" + s)) (provide (all-from-out "url-string.rkt")) @@ -374,7 +454,12 @@ (listof string?) any))) (current-proxy-servers - (parameter/c (or/c false/c (listof (list/c string? string? number?)))))) + (parameter/c (or/c false/c (listof (list/c string? string? number?))))) + (current-no-proxy-servers + (parameter/c (or/c false/c (listof (or/c string? regexp?))))) + (proxy-server-for (->* (string?) ((or/c false/c string?)) + (or/c false/c (list/c string? string? number?)))) + (proxiable-url-schemes (listof string?))) (define (http-sendrecv/url u #:method [method-bss #"GET"] @@ -394,12 +479,13 @@ (error 'http-sendrecv/url "Host required: ~e" u)) (hc:http-sendrecv (url-host u) - (url->string - (make-url #f #f #f #f - (url-path-absolute? u) - (url-path u) - (url-query u) - (url-fragment u))) + (ensure-non-empty + (url->string + (make-url #f #f #f #f + (url-path-absolute? u) + (url-path u) + (url-query u) + (url-fragment u)))) #:ssl? (if (equal? "https" (url-scheme u)) (current-https-protocol) diff --git a/racket/collects/net/win32-ssl.rkt b/racket/collects/net/win32-ssl.rkt index 4c0d84aa79..c65223adae 100644 --- a/racket/collects/net/win32-ssl.rkt +++ b/racket/collects/net/win32-ssl.rkt @@ -18,9 +18,9 @@ win32-ssl-port? win32-ssl-available?) -(define (win32-ssl-connect host port [protocol'sslv2-or-v3]) +(define (win32-ssl-connect host port [protocol 'auto]) (define-values (i o) (tcp-connect host port)) - (ports->win32-ssl-ports i o #:encrypt protocol)) + (ports->win32-ssl-ports i o #:encrypt protocol #:hostname host)) (define (win32-ssl-abandon-port port) ;; We don't try to implement shutdown, anyway @@ -117,6 +117,12 @@ (define SP_PROT_TLS1_SERVER #x00000040) (define SP_PROT_TLS1_CLIENT #x00000080) (define SP_PROT_TLS1 (bitwise-ior SP_PROT_TLS1_SERVER SP_PROT_TLS1_CLIENT)) +(define SP_PROT_TLS1_1_SERVER #x00000100) +(define SP_PROT_TLS1_1_CLIENT #x00000200) +(define SP_PROT_TLS1_1 (bitwise-ior SP_PROT_TLS1_1_SERVER SP_PROT_TLS1_1_CLIENT)) +(define SP_PROT_TLS1_2_SERVER #x00000400) +(define SP_PROT_TLS1_2_CLIENT #x00000800) +(define SP_PROT_TLS1_2 (bitwise-ior SP_PROT_TLS1_2_SERVER SP_PROT_TLS1_2_CLIENT)) (define SCH_CRED_MANUAL_CRED_VALIDATION #x00000008) (define SCH_CRED_NO_DEFAULT_CREDS #x00000010) (define SCHANNEL_CRED_VERSION #x00000004) @@ -126,7 +132,7 @@ (define (check-status who r) (unless (zero? r) - (error who "failed: ~x" r))) + (network-error who "failed: ~x" r))) (define-secur32 AcquireCredentialsHandleW (_fun #:abi winapi @@ -262,7 +268,7 @@ ;; Creating a context (i.e., an SSL connection) ;; Returns a context plus initial bytes for stream -(define (create-context protocol i o out-sb in-sb) +(define (create-context protocol hostname i o out-sb in-sb) ;; Pointers to particular SecBuffer records: (define out-sb0 (ptr-ref out-sb _SecBuffer 0)) (define in-sb0 (ptr-ref in-sb _SecBuffer 0)) @@ -278,26 +284,31 @@ ;; Allocate credentials. (define cred (make-cred-handle 0 0)) (AcquireCredentialsHandleW #f - "Microsoft Unified Security Protocol Provider" - SECPKG_CRED_OUTBOUND ; SECPKG_CRED_INBOUND or SECPKG_CRED_OUTBOUND - #f - (make-SCHANNEL_CRED SCHANNEL_CRED_VERSION - 0 #f - #f - 0 #f ; mappers - 0 #f ; algs - (case protocol - [(auto sslv2-or-v3) - (bitwise-ior SP_PROT_TLS1)] - [(sslv2) SP_PROT_SSL2] - [(sslv3) SP_PROT_SSL3] - [(tls) SP_PROT_TLS1]) - 0 0 0 - (bitwise-ior SCH_CRED_MANUAL_CRED_VALIDATION) - 0) - #f - #f - cred) + "Microsoft Unified Security Protocol Provider" + SECPKG_CRED_OUTBOUND + #f + (make-SCHANNEL_CRED SCHANNEL_CRED_VERSION + 0 #f + #f + 0 #f ; mappers + 0 #f ; algs + (case protocol + [(secure auto) + (bitwise-ior SP_PROT_TLS1 SP_PROT_TLS1_1 SP_PROT_TLS1_2)] + [(sslv2) SP_PROT_SSL2] + [(sslv3) SP_PROT_SSL3] + [(tls) SP_PROT_TLS1] + [(tls11) SP_PROT_TLS1_1] + [(tls12) SP_PROT_TLS1_2] + [else 0]) + 0 0 0 + (if (eq? protocol 'secure) + 0 + SCH_CRED_MANUAL_CRED_VALIDATION) + 0) + #f + #f + cred) ;; Allocate a content and take responsibility for freeing ;; credientials, but it's not a real content until the @@ -309,11 +320,15 @@ (define-values (r attr) (InitializeSecurityContextW cred (if init? #f (ctx->handle ctx)) - #f + (if (eq? protocol 'secure) + hostname + #f) (bitwise-ior ISC_REQ_REPLAY_DETECT ISC_REQ_SEQUENCE_DETECT ISC_REQ_CONFIDENTIALITY ISC_REQ_STREAM ISC_REQ_ALLOCATE_MEMORY - ISC_REQ_MANUAL_CRED_VALIDATION) + (if (eq? protocol 'secure) + 0 + ISC_REQ_MANUAL_CRED_VALIDATION)) 0 SECURITY_NATIVE_DREP (if init? @@ -348,7 +363,7 @@ (define (get-leftover-bytes) (if (equal? (SecBuffer-BufferType in-sb1) SECBUFFER_EXTRA) - ;; Same the leftover bytes: + ;; Save the leftover bytes: (let ([amt (SecBuffer-cbBuffer in-sb1)]) (log-win32-ssl-debug "init context: leftover ~a" amt) (memcpy buffer (ptr-add buffer (- data-len amt)) amt) @@ -362,12 +377,15 @@ (values ctx (let ([n (get-leftover-bytes)]) (subbytes buffer 0 n)))] - [(= r SEC_I_CONTINUE_NEEDED) + [(or (= r SEC_I_CONTINUE_NEEDED) + (= r SEC_E_INCOMPLETE_MESSAGE)) ;; Pull more data from the server - (define data-len (get-leftover-bytes)) + (define new-data-len (if (= r SEC_E_INCOMPLETE_MESSAGE) + data-len + (get-leftover-bytes))) ;; Unlikely, but maybe it's possible that we don't have room ;; to read more due to leftover bytes: - (when (= data-len buffer-size) + (when (= new-data-len buffer-size) (define new-buffer (malloc (* 2 buffer-size) 'atomic-interior)) (memcpy new-buffer buffer buffer-size) (set! buffer-size (* 2 buffer-size)) @@ -375,14 +393,16 @@ ;; Go back to non-atomic mode for a potentially blocking read: (define n (call-as-nonatomic (lambda () - (read-bytes-avail! buffer i data-len buffer-size)))) + (read-bytes-avail! buffer i new-data-len buffer-size)))) (log-win32-ssl-debug "init context: read ~a" n) - (when (eof-object? n) (error "unexpected EOF")) - (loop (+ data-len n) #f)] + (when (eof-object? n) (network-error "unexpected EOF")) + (loop (+ new-data-len n) (if (= r SEC_I_CONTINUE_NEEDED) + #f + init?))] ;; Some other things are allowed to happen without implying ;; failure, but we don't handle all of them. - [else (error 'create-context - "unexpected result: ~x" r)]))))) + [else (network-error 'create-context + "unexpected result: ~x" r)]))))) (define (decrypt ctx in-pre-r in-post-w out-sb) ;; Read encrypted byte from `in-pre-r', write decrypted bytes to @@ -420,7 +440,7 @@ (and (= SECBUFFER_DATA (SecBuffer-BufferType sb)) sb))) (unless sb - (error "expected decrypted data")) + (network-error "expected decrypted data")) (write-bytes (make-sized-byte-string (SecBuffer-pvBuffer sb) (SecBuffer-cbBuffer sb)) in-post-w) @@ -446,7 +466,7 @@ ;; Other end closed the connection. (close-output-port in-post-w)] [else - (error 'decrypt "unexpected result: ~x" r)]))) + (network-error 'decrypt "unexpected result: ~x" r)]))) (define (encrypt ctx bstr start end out-sb sizes buffer) ;; Encrypt bytes [start, end) from bstr. @@ -497,16 +517,18 @@ ;; The encrypted bytes don't fit in the unencrypted space? (divide-and-conquer)] [else - (error 'decrypt "unexpected result: ~x" r)])])) + (network-error 'decrypt "unexpected result: ~x" r)])])) ;; Wrap input and output ports to produce SSL versions of the ports: -(define (ports->win32-ssl-ports i o #:encrypt [protocol 'sslv2-or-v3]) +(define (ports->win32-ssl-ports i o + #:encrypt [protocol 'auto] + #:hostname [hostname #f]) ;; Working space for encoding, decoding, and more: (define out-sb (make-SecBuffers 4)) (define in-sb (make-SecBuffers 2)) ;; Allocate the encoding/decoding context: - (define-values (ctx init-bytes) (create-context protocol i o out-sb in-sb)) + (define-values (ctx init-bytes) (create-context protocol hostname i o out-sb in-sb)) ;; Get some sizes that we need for encoding: (define sizes (make-SecPkgContext_StreamSizes 0 0 0 0 0)) @@ -664,6 +686,18 @@ ;; Done: (values (register in) (register out))) +;; ---------------------------------------- +;; Errors + +(define network-error + (case-lambda + [(str) (network-error 'win32-ssl str)] + [(who msg . args) + (raise + (exn:fail:network + (format "~a: ~a" who (apply format msg args)) + (current-continuation-marks)))])) + ;; ---------------------------------------- ;; Recognizing win32 ports diff --git a/racket/collects/openssl/libcrypto.rkt b/racket/collects/openssl/libcrypto.rkt index 8eeefd4120..774d9611ca 100644 --- a/racket/collects/openssl/libcrypto.rkt +++ b/racket/collects/openssl/libcrypto.rkt @@ -1,7 +1,9 @@ #lang racket/base (require ffi/unsafe racket/runtime-path - (for-syntax racket/base)) + setup/cross-system + (for-syntax racket/base + setup/cross-system)) (provide libcrypto libcrypto-load-fail-reason @@ -42,8 +44,12 @@ ;; We need to declare because they might be distributed with Racket, ;; in which case they should get bundled with stand-alone executables: (define-runtime-path libcrypto-so - (case (system-type) + #:runtime?-id runtime? + (case (if runtime? (system-type) (cross-system-type)) [(windows) '(so "libeay32")] + [(macosx) + ;; Version "1.0.0" is bundled with Racket + '(so "libcrypto" ("1.0.0" #f))] [else '(so "libcrypto")])) (define libcrypto diff --git a/racket/collects/openssl/libssl.rkt b/racket/collects/openssl/libssl.rkt index 122a346fa1..66c0f882d6 100644 --- a/racket/collects/openssl/libssl.rkt +++ b/racket/collects/openssl/libssl.rkt @@ -1,7 +1,9 @@ #lang racket/base (require ffi/unsafe racket/runtime-path - (for-syntax racket/base) + setup/cross-system + (for-syntax racket/base + setup/cross-system) "libcrypto.rkt") (provide libssl @@ -12,8 +14,12 @@ ;; We need to declare because they might be distributed with PLT Scheme ;; in which case they should get bundled with stand-alone executables: (define-runtime-path libssl-so - (case (system-type) + #:runtime?-id runtime? + (case (if runtime? (system-type) (cross-system-type)) [(windows) '(so "ssleay32")] + [(macosx) + ;; Version "1.0.0" is bundled with Racket + '(so "libssl" ("1.0.0" #f))] [else '(so "libssl")])) (define libssl diff --git a/racket/collects/openssl/mzssl.rkt b/racket/collects/openssl/mzssl.rkt index 852d2cd31b..0adb35afd5 100644 --- a/racket/collects/openssl/mzssl.rkt +++ b/racket/collects/openssl/mzssl.rkt @@ -42,7 +42,7 @@ TO DO: ["private/macosx.rkt" (load-macosx-keychain)]) (define protocol-symbol/c - (or/c 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12)) + (or/c 'secure 'auto 'sslv2-or-v3 'sslv2 'sslv3 'tls 'tls11 'tls12)) (define curve-nid-alist '((sect163k1 . 721) @@ -545,7 +545,7 @@ TO DO: (define (encrypt->method who e client?) (define f (case e - [(auto sslv2-or-v3) + [(secure auto sslv2-or-v3) (if client? SSLv23_client_method SSLv23_server_method)] [(sslv2) (if client? SSLv2_client_method SSLv2_server_method)] @@ -579,7 +579,8 @@ TO DO: ;; Keep symbols in best-last order for ssl-max-{client,server}-protocol. (define (supported-client-protocols) (filter-available - (list 'auto SSLv23_client_method + (list 'secure SSLv23_client_method + 'auto SSLv23_client_method 'sslv2-or-v3 SSLv23_client_method 'sslv2 SSLv2_client_method 'sslv3 SSLv3_client_method @@ -588,7 +589,8 @@ TO DO: 'tls12 TLSv1_2_client_method))) (define (supported-server-protocols) (filter-available - (list 'auto SSLv23_server_method + (list 'secure SSLv23_server_method + 'auto SSLv23_server_method 'sslv2-or-v3 SSLv23_server_method 'sslv2 SSLv2_server_method 'sslv3 SSLv3_server_method @@ -609,17 +611,26 @@ TO DO: ((if client? make-ssl-client-context make-ssl-server-context) ctx #f #f)) (define (make-raw-context who protocol-symbol client?) - (define meth (encrypt->method who protocol-symbol client?)) - (define ctx - (atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error) - (let ([ctx (SSL_CTX_new meth)]) - (check-valid ctx who "context creation") - ctx))) - (unless (memq protocol-symbol '(sslv2 sslv3)) - (SSL_CTX_set_options ctx (bitwise-ior SSL_OP_NO_SSLv2 SSL_OP_NO_SSLv3))) - (SSL_CTX_set_mode ctx (bitwise-ior SSL_MODE_ENABLE_PARTIAL_WRITE - SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER)) - ctx) + (cond + [(and (eq? protocol-symbol 'secure) + client?) + (ssl-context-ctx (ssl-secure-client-context))] + [else + (define meth (encrypt->method who protocol-symbol client?)) + (define ctx + (atomically ;; connect SSL_CTX_new to subsequent check-valid (ERR_get_error) + (let ([ctx (SSL_CTX_new meth)]) + (check-valid ctx who "context creation") + ctx))) + (unless (memq protocol-symbol '(sslv2 sslv3)) + (SSL_CTX_set_options ctx (bitwise-ior SSL_OP_NO_SSLv2 SSL_OP_NO_SSLv3))) + (SSL_CTX_set_mode ctx (bitwise-ior SSL_MODE_ENABLE_PARTIAL_WRITE + SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER)) + ctx])) + +(define (need-ctx-free? context-or-encrypt-method) + (and (symbol? context-or-encrypt-method) + (not (eq? context-or-encrypt-method 'secure)))) (define (ssl-make-client-context [protocol-symbol default-encrypt]) (make-context 'ssl-make-client-context protocol-symbol #t)) @@ -1353,7 +1364,8 @@ TO DO: (let ([ctx (get-context who context-or-encrypt-method connect?)]) (check-valid ctx who "context creation") (with-failure - (lambda () (when (and ctx (symbol? context-or-encrypt-method)) + (lambda () (when (and ctx + (need-ctx-free? context-or-encrypt-method)) (SSL_CTX_free ctx))) (let ([r-bio (BIO_new (BIO_s_mem))] [w-bio (BIO_new (BIO_s_mem))] @@ -1365,7 +1377,7 @@ TO DO: (let ([ssl (SSL_new ctx)]) (check-valid ssl who "ssl setup") ;; ssl has a ref count on ctx, so release: - (when (symbol? context-or-encrypt-method) + (when (need-ctx-free? context-or-encrypt-method) (SSL_CTX_free ctx) (set! ctx #f)) (with-failure diff --git a/racket/collects/pkg/main.rkt b/racket/collects/pkg/main.rkt index 2541da8ea8..fa015657ac 100644 --- a/racket/collects/pkg/main.rkt +++ b/racket/collects/pkg/main.rkt @@ -692,7 +692,7 @@ ("Specify treatment of multiple clones of a repository;" "s: convert, ask (interactive default), fail (other default), or force")] [(#:sym mode [ff-only try rebase] 'ff-only) pull () - ("Specify `git pull' mode for repository clonse;" + ("Specify `git pull' mode for repository clones;" "s: ff-only (the default), try, or rebase")]) #:update-deps-flags ([#:bool update-deps () "For `search-ask' or `search-auto', also update dependencies"] diff --git a/racket/collects/pkg/private/config.rkt b/racket/collects/pkg/private/config.rkt index 73e0feb3ce..994ce8fe1a 100644 --- a/racket/collects/pkg/private/config.rkt +++ b/racket/collects/pkg/private/config.rkt @@ -45,8 +45,8 @@ (define (get-default) (match k ['catalogs - (list "http://pkgs.racket-lang.org" - "http://planet-compats.racket-lang.org")] + (list "https://pkgs.racket-lang.org" + "https://planet-compats.racket-lang.org")] ['default-scope "user"] ['installation-name (version)] ['download-cache-dir (build-path (find-system-path 'addon-dir) diff --git a/racket/collects/pkg/private/network.rkt b/racket/collects/pkg/private/network.rkt index 159e1f7283..0ed06b0473 100644 --- a/racket/collects/pkg/private/network.rkt +++ b/racket/collects/pkg/private/network.rkt @@ -1,5 +1,6 @@ #lang racket/base (require net/url + net/url-connect racket/format "print.rkt" "config.rkt") @@ -57,9 +58,12 @@ (lambda (f) (f))) (lambda () (define-values (p hs) - (get-pure-port/headers url headers - #:redirections 25 - #:status? #t)) + (parameterize ([current-https-protocol (if (getenv "PLT_PKG_SSL_NO_VERIFY") + (current-https-protocol) + 'secure)]) + (get-pure-port/headers url headers + #:redirections 25 + #:status? #t))) (define status (string->number (substring hs 9 12))) (cond [(memv status success-codes) diff --git a/racket/collects/pkg/private/new.rkt b/racket/collects/pkg/private/new.rkt index fff6f56fbe..14edbefda6 100644 --- a/racket/collects/pkg/private/new.rkt +++ b/racket/collects/pkg/private/new.rkt @@ -94,16 +94,13 @@ EOS ;; .travis.yml (with-output-to-file ".travis.yml" - (lambda () (display #<>` to install any required # packages without it getting stuck on a confirmation prompt. script: - - /usr/racket/bin/raco make main.rkt - - /usr/racket/bin/raco test -x . + - raco pkg install --deps search-auto cover + - raco test -x -p <> -# NOTE: If your repo is a Racket package with an info.rkt that -# includes some `deps`, the following is more elegant: -# -# script: -# - cd .. # Travis did a cd into the dir. Back up, for the next: -# - /usr/racket/bin/raco pkg install --deps search-auto --link <> -# - /usr/racket/bin/raco test -x -p <> - -after_script: +after_success: + - raco setup --check-deps <> + - raco pkg install --deps search-auto cover-coveralls + - raco pkg install --deps search-auto + - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . EOS ))) diff --git a/racket/collects/planet/private/resolver.rkt b/racket/collects/planet/private/resolver.rkt index 6ba17bfb28..32a096e1ac 100644 --- a/racket/collects/planet/private/resolver.rkt +++ b/racket/collects/planet/private/resolver.rkt @@ -782,11 +782,13 @@ See the scribble documentation on the planet/resolver module. (let ([maj/str (extract-field "Package-Major-Version" head)] [min/str (extract-field "Package-Minor-Version" head)] [content-length/str (extract-field "Content-Length" head)]) - (unless (and maj/str min/str content-length/str + (unless (and maj/str min/str (nat? (string->number maj/str)) - (nat? (string->number min/str)) - (nat? (string->number content-length/str))) + (nat? (string->number min/str))) (abort "Server did not include valid major and minor version information")) + (unless (and content-length/str + (nat? (string->number content-length/str))) + (abort "Server did not include content-length")) (let* ([filename (make-temporary-file "planettmp~a.plt")] [maj (string->number maj/str)] [min (string->number min/str)] diff --git a/racket/collects/racket/async-channel.rkt b/racket/collects/racket/async-channel.rkt index 5c8b419d34..e4249b7519 100644 --- a/racket/collects/racket/async-channel.rkt +++ b/racket/collects/racket/async-channel.rkt @@ -197,16 +197,10 @@ (define (add-async-channel-context blame) (blame-add-context blame "a value passed through")) -(define (check-async-channel/c ctc val blame) +(define (check-async-channel/c ctc val blame neg-party) (unless (async-channel? val) - (raise-blame-error blame val '(expected "an async channel" given: "~e") val))) - -(define (check-async-channel/c-np ctc val blame) - (if (async-channel? val) - #f - (λ (neg-party) - (raise-blame-error blame #:missing-party neg-party - val '(expected "an async channel" given: "~e") val)))) + (raise-blame-error blame val #:missing-party neg-party + '(expected "an async channel" given: "~e") val))) (define ((async-channel/c-first-order ctc) val) (async-channel? val)) @@ -214,33 +208,19 @@ (define (async-channel/c-stronger? a b) (contract-stronger? (base-async-channel/c-content a) (base-async-channel/c-content b))) -(define ((ho-val-first-projection impersonate/chaperone-async-channel) ctc) +(define ((late-neg-projection impersonate/chaperone-async-channel) ctc) (define elem-ctc (base-async-channel/c-content ctc)) - (define vfp (get/build-val-first-projection elem-ctc)) + (define lnp (contract-late-neg-projection elem-ctc)) (λ (blame) - (define async-channel-blame (add-async-channel-context blame)) - (define pos-elem-proj (vfp async-channel-blame)) - (define neg-elem-proj (vfp (blame-swap async-channel-blame))) - (λ (val) - (or (check-async-channel/c-np ctc val blame) - (λ (neg-party) - (impersonate/chaperone-async-channel - val - (λ (v) ((pos-elem-proj v) neg-party)) - (λ (v) ((neg-elem-proj v) neg-party)) - impersonator-prop:contracted ctc - impersonator-prop:blame (blame-add-missing-party blame neg-party))))))) - -(define ((ho-projection impersonate/chaperone-async-channel) ctc) - (let ([elem-ctc (base-async-channel/c-content ctc)]) - (λ (blame) - (let ([pos-elem-proj ((contract-projection elem-ctc) blame)] - [neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))]) - (λ (val) - (check-async-channel/c ctc val blame) - (impersonate/chaperone-async-channel val pos-elem-proj neg-elem-proj - impersonator-prop:contracted ctc - impersonator-prop:blame blame)))))) + (define pos-elem-proj (lnp blame)) + (define neg-elem-proj (lnp (blame-swap blame))) + (λ (val neg-party) + (check-async-channel/c ctc val blame neg-party) + (impersonate/chaperone-async-channel val + (λ (v) (pos-elem-proj v neg-party)) + (λ (v) (neg-elem-proj v neg-party)) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))) (struct base-async-channel/c (content)) @@ -251,8 +231,7 @@ #:name async-channel/c-name #:first-order async-channel/c-first-order #:stronger async-channel/c-stronger? - #:val-first-projection (ho-val-first-projection chaperone-async-channel) - #:projection (ho-projection chaperone-async-channel))) + #:late-neg-projection (late-neg-projection chaperone-async-channel))) (struct impersonator-async-channel/c base-async-channel/c () #:property prop:custom-write custom-write-property-proc @@ -261,8 +240,7 @@ #:name async-channel/c-name #:first-order async-channel/c-first-order #:stronger async-channel/c-stronger? - #:val-first-projection (ho-val-first-projection impersonate-async-channel) - #:projection (ho-projection impersonate-async-channel))) + #:late-neg-projection (late-neg-projection impersonate-async-channel))) (define (async-channel/c elem) (define ctc (coerce-contract 'async-channel/c elem)) diff --git a/racket/collects/racket/block.rkt b/racket/collects/racket/block.rkt index 5355969605..88326603e3 100644 --- a/racket/collects/racket/block.rkt +++ b/racket/collects/racket/block.rkt @@ -4,7 +4,8 @@ "private/stx.rkt" "private/small-scheme.rkt" "private/stxcase-scheme.rkt" - "private/qqstx.rkt")) + "private/qqstx.rkt" + syntax/intdef)) (#%provide block) @@ -59,12 +60,14 @@ [prev-exprs null]) (cond [(null? exprs) - #`(letrec-syntaxes+values - #,(map stx-cdr (reverse prev-stx-defns)) - #,(map stx-cdr (reverse prev-defns)) - #,@(if (null? prev-exprs) - (list #'(void)) - (reverse prev-exprs)))] + (internal-definition-context-track + def-ctx + #`(letrec-syntaxes+values + #,(map stx-cdr (reverse prev-stx-defns)) + #,(map stx-cdr (reverse prev-defns)) + #,@(if (null? prev-exprs) + (list #'(void)) + (reverse prev-exprs))))] [(and (stx-pair? (car exprs)) (identifier? (stx-car (car exprs))) (free-identifier=? #'define-syntaxes (stx-car (car exprs)))) diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index 3992d7610a..6354928697 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -20,37 +20,89 @@ "private/orc.rkt") (provide - (except-out (all-from-out "private/arrow.rkt") - making-a-method - procedure-accepts-and-more? - check-procedure - check-procedure/more - - contract-key - - ;; these two are provided for-syntax - ;check-tail-contract - ;make-this-parameters - - -> ->*) + base->? + ->d + base->-rngs/c + base->-doms/c + unconstrained-domain-> + the-unsupplied-arg + unsupplied-arg? + method-contract? + matches-arity-exactly? + keywords-match + bad-number-of-results + (for-syntax check-tail-contract + make-this-parameters + parse-leftover->*) + tail-marks-match? + values/drop + arity-checking-wrapper + unspecified-dom + blame-add-range-context + blame-add-nth-arg-context + (rename-out [->2 ->] [->*2 ->*]) dynamic->* predicate/c + + ->i + box-immutable/c + box/c + hash/c + hash/dc + vectorof + vector/c + vector-immutable/c + vector-immutableof + struct/dc + struct/c + struct-type-property/c - (all-from-out "private/arr-i.rkt" - "private/box.rkt" - "private/hash.rkt" - "private/vector.rkt" - "private/struct-dc.rkt" - "private/struct-prop.rkt") - (except-out (all-from-out "private/base.rkt") - current-contract-region - (for-syntax lifted-key add-lifted-property)) - (except-out (all-from-out "private/misc.rkt") - check-between/c - check-unary-between/c - random-any/c) - symbols or/c one-of/c + contract + recursive-contract + invariant-assertion + + flat-murec-contract + and/c + not/c + =/c >=/c <=/c /c between/c + integer-in + char-in + real-in + natural-number/c + string-len/c + false/c + printable/c + listof list*of non-empty-listof cons/c list/c cons/dc + promise/c + syntax/c + + parameter/c + procedure-arity-includes/c + + any/c + any + none/c + make-none/c + + prompt-tag/c + continuation-mark-key/c + + channel/c + evt/c + + flat-contract + flat-contract-predicate + flat-named-contract + + blame-add-car-context + blame-add-cdr-context + raise-not-cons-blame-error + + rename-contract + if/c + + symbols or/c first-or/c one-of/c flat-rec-contract provide/contract ;(for-syntax make-provide/contract-transformer) ;; not documented! @@ -73,7 +125,23 @@ case-> ;; from here (needs `->`, so can't be deeper) - failure-result/c) + failure-result/c + + contract? + chaperone-contract? + impersonator-contract? + flat-contract? + + contract-late-neg-projection + contract-name + contract-projection + contract-val-first-projection + get/build-late-neg-projection + get/build-val-first-projection + + ;; not documented.... (ie unintentional export) + n->th) + ;; failure-result/c : contract ;; Describes the optional failure argument passed to hash-ref, for example. diff --git a/racket/collects/racket/contract/combinator.rkt b/racket/collects/racket/contract/combinator.rkt index b2075fe620..587adc2825 100644 --- a/racket/collects/racket/contract/combinator.rkt +++ b/racket/collects/racket/contract/combinator.rkt @@ -1,24 +1,281 @@ #lang racket/base (require "private/prop.rkt" + (prefix-in : (only-in "private/prop.rkt" + build-chaperone-contract-property + build-flat-contract-property + make-chaperone-contract + make-flat-contract)) "private/guts.rkt" "private/blame.rkt") (provide - (except-out (all-from-out "private/prop.rkt") - contract-struct-name - contract-struct-first-order - contract-struct-projection - contract-struct-val-first-projection - contract-struct-stronger? - contract-struct? - chaperone-contract-struct? - flat-contract-struct?) + prop:contract + contract-struct-late-neg-projection + contract-struct-generate + contract-struct-exercise + contract-struct-list-contract? - (except-out (all-from-out "private/guts.rkt") - check-flat-contract - check-flat-named-contract - make-predicate-contract - has-contract? - value-contract) + prop:flat-contract + prop:chaperone-contract - (except-out (all-from-out "private/blame.rkt") make-blame)) + contract-property? + build-contract-property + + chaperone-contract-property? + + flat-contract-property? + + make-contract + + prop:opt-chaperone-contract + prop:opt-chaperone-contract? + prop:opt-chaperone-contract-get-test + + prop:orc-contract + prop:orc-contract? + prop:orc-contract-get-subcontracts + + prop:recursive-contract + prop:recursive-contract? + prop:recursive-contract-unroll + + prop:arrow-contract + prop:arrow-contract? + prop:arrow-contract-get-info + (struct-out arrow-contract-info) + + coerce-contract + coerce-contracts + coerce-flat-contract + coerce-flat-contracts + coerce-chaperone-contract + coerce-chaperone-contracts + coerce-contract/f + + build-compound-type-name + + contract-stronger? + list-contract? + + contract-first-order + contract-first-order-passes? + + prop:contracted prop:blame + impersonator-prop:contracted impersonator-prop:blame + has-blame? value-blame + + ;; helpers for adding properties that check syntax uses + define/final-prop + define/subexpression-pos-prop + define/subexpression-pos-prop/name + + eq-contract? + eq-contract-val + equal-contract? + equal-contract-val + char-in/c + + contract-continuation-mark-key + with-contract-continuation-mark + + (struct-out wrapped-extra-arg-arrow) + contract-custom-write-property-proc + (rename-out [contract-custom-write-property-proc custom-write-property-proc]) + + set-some-basic-contracts! + + blame? + blame-source + blame-positive + blame-negative + blame-contract + blame-value + blame-original? + blame-swapped? + blame-swap + blame-replace-negative ;; used for indy blame + blame-update ;; used for option contract transfers + blame-add-context + blame-add-unknown-context + blame-context + + blame-add-missing-party + blame-missing-party? + + raise-blame-error + current-blame-format + (struct-out exn:fail:contract:blame) + blame-fmt->-string + + (rename-out [-make-chaperone-contract make-chaperone-contract] + [-make-flat-contract make-flat-contract] + [-build-chaperone-contract-property build-chaperone-contract-property] + [-build-flat-contract-property build-flat-contract-property]) + skip-projection-wrapper?) + +(define skip-projection-wrapper? (make-parameter #f)) + +(define (maybe-add-wrapper f x) + (cond + [(and x (not (skip-projection-wrapper?))) + (f x)] + [else x])) + +(define -make-chaperone-contract + (let ([make-chaperone-contract + (λ (#:name [name 'anonymous-chaperone-contract] + #:first-order [first-order (λ (x) #t)] + #:late-neg-projection [late-neg-projection #f] + #:val-first-projection [val-first-projection #f] + #:projection [projection #f] + #:stronger [stronger #f] + #:list-contract? [is-list-contract #f]) + (:make-chaperone-contract + #:name name + #:first-order first-order + #:late-neg-projection + (maybe-add-wrapper add-late-neg-chaperone-check late-neg-projection) + #:val-first-projection + (maybe-add-wrapper add-val-first-chaperone-check val-first-projection) + #:projection + (maybe-add-wrapper add-projection-chaperone-check projection) + #:stronger stronger + #:list-contract? is-list-contract))]) + make-chaperone-contract)) + +(define -build-chaperone-contract-property + (let () + (define (build-chaperone-contract-property + #:name [get-name (λ (c) 'anonymous-chaperone-contract)] + #:first-order [get-first-order (λ (c) (λ (x) #t))] + #:val-first-projection [val-first-proj #f] + #:late-neg-projection [late-neg-proj #f] + #:projection [get-projection #f] + #:stronger [stronger #f] + #:generate [generate #f] + #:exercise [exercise #f]) + (:build-chaperone-contract-property + #:name get-name + #:first-order get-first-order + #:val-first-projection + (maybe-add-wrapper add-prop-val-first-chaperone-check val-first-proj) + #:late-neg-projection + (maybe-add-wrapper add-prop-late-neg-chaperone-check late-neg-proj) + #:projection + (maybe-add-wrapper add-prop-chaperone-check get-projection) + #:stronger stronger + #:generate generate + #:exercise exercise)) + build-chaperone-contract-property)) + +(define (add-prop-late-neg-chaperone-check get-late-neg) + (λ (c) + (add-late-neg-chaperone-check (get-late-neg c)))) + +(define (add-late-neg-chaperone-check accepts-blame) + (λ (b) + (define accepts-val-and-np (accepts-blame b)) + (λ (x neg-party) + (check-and-signal x + (accepts-val-and-np x neg-party) + 'make-chaperone-contract::late-neg-projection)))) + +(define (add-prop-val-first-chaperone-check get) + (λ (c) + (add-val-first-chaperone-check (get c)))) + +(define (add-val-first-chaperone-check vfp) + (λ (b) + (define x-acceptor (vfp b)) + (λ (x) + (define neg-acceptor (x-acceptor x)) + (λ (neg-party) + (check-and-signal x + (neg-acceptor neg-party) + 'make-chaperone-contract::late-neg-projection))))) + +(define (add-prop-chaperone-check get) + (λ (c) + (add-projection-chaperone-check (get c)))) + +(define (add-projection-chaperone-check proj) + (λ (b) + (define x-acceptor (proj b)) + (λ (x) + (check-and-signal x (x-acceptor x) + 'make-chaperone-contract::projection)))) + + +(define (check-and-signal val chapd-val who) + (unless (chaperone-of? chapd-val val) + (raise-result-error who + (format "chaperone-of ~e" val) + chapd-val)) + chapd-val) + +(define -make-flat-contract + (let ([make-flat-contract + (λ (#:name [name 'anonymous-chaperone-contract] + #:first-order [first-order (λ (x) #t)] + #:late-neg-projection [late-neg-projection #f] + #:val-first-projection [val-first-projection #f] + #:projection [projection #f] + #:stronger [stronger #f] + #:list-contract? [is-list-contract #f]) + (:make-flat-contract + #:name name + #:first-order first-order + #:late-neg-projection (force-late-neg-eq late-neg-projection) + #:val-first-projection (force-val-first-eq val-first-projection) + #:projection (force-projection-eq projection) + #:stronger stronger + #:list-contract? is-list-contract))]) + make-flat-contract)) + +(define -build-flat-contract-property + (let ([build-flat-contract-property + (λ (#:name [name (λ (c) 'anonymous-chaperone-contract)] + #:first-order [first-order (λ (c) (λ (x) #t))] + #:late-neg-projection [late-neg-projection #f] + #:val-first-projection [val-first-projection #f] + #:projection [projection #f] + #:stronger [stronger #f] + #:list-contract? [is-list-contract #f]) + (:build-flat-contract-property + #:name name + #:first-order first-order + #:late-neg-projection + (and late-neg-projection (λ (c) (force-late-neg-eq (late-neg-projection c)))) + #:val-first-projection + (and val-first-projection (λ (c) (force-val-first-eq (val-first-projection c)))) + #:projection + (and projection (λ (c) (force-projection-eq (projection c)))) + #:stronger stronger + #:list-contract? is-list-contract))]) + build-flat-contract-property)) + +(define (force-late-neg-eq accepts-blame) + (and accepts-blame + (λ (b) + (define accepts-val-and-np (accepts-blame b)) + (λ (x neg-party) + (accepts-val-and-np x neg-party) + x)))) + +(define (force-val-first-eq vfp) + (and vfp + (λ (b) + (define x-acceptor (vfp b)) + (λ (x) + (define neg-acceptor (x-acceptor x)) + (λ (neg-party) + (neg-acceptor neg-party) + x))))) + +(define (force-projection-eq proj) + (and proj + (λ (b) + (define x-acceptor (proj b)) + (λ (x) + (x-acceptor x) + x)))) diff --git a/racket/collects/racket/contract/parametric.rkt b/racket/collects/racket/contract/parametric.rkt index fc0fb30b74..1c6a321ab0 100644 --- a/racket/collects/racket/contract/parametric.rkt +++ b/racket/collects/racket/contract/parametric.rkt @@ -1,6 +1,4 @@ #lang racket/base (require "private/exists.rkt" "private/parametric.rkt") -(provide (all-from-out "private/parametric.rkt") - (except-out (all-from-out "private/exists.rkt") - ∀∃?)) +(provide new-∃/c new-∀/c parametric->/c) diff --git a/racket/collects/racket/contract/private/arr-i-parse.rkt b/racket/collects/racket/contract/private/arr-i-parse.rkt index 9362f76785..ebbd1be11d 100644 --- a/racket/collects/racket/contract/private/arr-i-parse.rkt +++ b/racket/collects/racket/contract/private/arr-i-parse.rkt @@ -5,8 +5,8 @@ ;; has these old, wrong names in it. [make-module-identifier-mapping make-free-identifier-mapping] [module-identifier-mapping-get free-identifier-mapping-get] - [module-identifier-mapping-put! free-identifier-mapping-put!]) - "application-arity-checking.rkt" + [module-identifier-mapping-put! free-identifier-mapping-put!] + [module-identifier-mapping-for-each free-identifier-mapping-for-each]) "arr-util.rkt" (for-template racket/base "misc.rkt")) @@ -19,12 +19,13 @@ code does the parsing and validation of the syntax. |# +;; istx-is-chaperone-contract? : boolean? ;; args : (listof arg?) ;; rst : (or/c #f arg/res?) ;; pre : (listof pre/post?) ;; ress : (or/c #f (listof eres?) (listof lres?)) ;; post : (listof pre/post?) -(struct istx (args rst pre ress post) #:transparent) +(struct istx (is-chaperone-contract? args rst pre ress post) #:transparent) ;; NOTE: the ress field may contain a mixture of eres and lres structs ;; but only temporarily; in that case, a syntax error ;; is signaled and the istx struct is not used afterwards @@ -58,11 +59,13 @@ code does the parsing and validation of the syntax. (define (parse-->i stx) (if (identifier? stx) (raise-syntax-error #f "expected ->i to follow an open parenthesis" stx) - (let-values ([(raw-mandatory-doms raw-optional-doms - id/rest-id pre-cond range post-cond) + (let-values ([(is-chaperone-contract? + raw-mandatory-doms raw-optional-doms + id/rest-id pre-cond range post-cond) (pull-out-pieces stx)]) (let ([candidate - (istx (append (parse-doms stx #f raw-mandatory-doms) + (istx is-chaperone-contract? + (append (parse-doms stx #f raw-mandatory-doms) (parse-doms stx #t raw-optional-doms)) id/rest-id pre-cond @@ -100,8 +103,41 @@ code does the parsing and validation of the syntax. (define (ensure-bound vars) (for ([var (in-list vars)]) (unless (free-identifier-mapping-get nm var (λ () #f)) - (raise-syntax-error #f "dependent variable not bound" - stx var)))) + (define vars '()) + (free-identifier-mapping-for-each + nm + (λ (id _) + (define sym (syntax-e id)) + (unless (member sym vars) + (set! vars (cons sym vars))))) + + (define (insert x l) + (cond + [(null? l) (list x)] + [else + (cond + [(symboli expression" + "\n variables:" + (for/list ([var (in-list sorted-vars)] + [i (in-naturals)]) + (format " ~a" var))) + stx var)))) ;; not-range-bound : (listof identifier[used-by-an-arg]) -> void (define (not-range-bound arg-vars arg?) @@ -142,6 +178,7 @@ code does the parsing and validation of the syntax. ;; no dups in the rest var (when (istx-rst istx) (when (arg/res-vars (istx-rst istx)) + (ensure-bound (arg/res-vars (istx-rst istx))) (not-range-bound (arg/res-vars (istx-rst istx)) #t)) (no-var-dups (arg/res-var (istx-rst istx)))) @@ -358,12 +395,26 @@ code does the parsing and validation of the syntax. ;; pull-out-pieces : ;; stx -> (values raw-mandatory-doms raw-optional-doms id/rest-id pre-cond range post-cond) (define (pull-out-pieces stx) - (let*-values ([(raw-mandatory-doms leftover) + (let*-values ([(is-chaperone-contract? leftover) (syntax-case stx () - [(_ (raw-mandatory-doms ...) . leftover) + [(_ #:chaperone . leftover) + (values #t #'leftover)] + [(_ . leftover) + (let ([lst (syntax->list stx)]) + (when (null? (cdr lst)) + (raise-syntax-error #f "expected a sequence of mandatory domain elements" + stx)) + (when (keyword? (syntax-e (cadr lst))) + (raise-syntax-error #f "unknown keyword" + stx + (cadr lst))) + (values #f #'leftover))])] + [(raw-mandatory-doms leftover) + (syntax-case leftover () + [((raw-mandatory-doms ...) . leftover) (values (syntax->list #'(raw-mandatory-doms ...)) #'leftover)] - [(_ a . leftover) + [(a . leftover) (raise-syntax-error #f "expected a sequence of mandatory domain elements" stx #'a)] @@ -569,7 +620,9 @@ code does the parsing and validation of the syntax. (values (reverse post-conds) leftover)]))]) (syntax-case leftover () [() - (values raw-mandatory-doms raw-optional-doms id/rest-id pre-conds range post-conds)] + (values is-chaperone-contract? + raw-mandatory-doms raw-optional-doms id/rest-id pre-conds + range post-conds)] [(a . b) (raise-syntax-error #f "bad syntax" stx #'a)] [_ diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt index e3f6ff3159..6393b98bbb 100644 --- a/racket/collects/racket/contract/private/arr-i.rkt +++ b/racket/collects/racket/contract/private/arr-i.rkt @@ -27,12 +27,13 @@ (provide (rename-out [->i/m ->i])) -(define (build-??-args ctc blame) - (define arg-ctc-projs (map (λ (x) (contract-projection (->i-arg-contract x))) (->i-arg-ctcs ctc))) - (define indy-arg-ctc-projs (map (λ (x) (contract-projection (cdr x))) +(define (build-??-args c-or-i-procedure ctc blame) + (define arg-ctc-projs (map (λ (x) (get/build-late-neg-projection (->i-arg-contract x))) + (->i-arg-ctcs ctc))) + (define indy-arg-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x))) (->i-indy-arg-ctcs ctc))) - (define rng-ctc-projs (map (λ (x) (contract-projection (cdr x))) (->i-rng-ctcs ctc))) - (define indy-rng-ctc-projs (map (λ (x) (contract-projection (cdr x))) + (define rng-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x))) (->i-rng-ctcs ctc))) + (define indy-rng-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x))) (->i-indy-rng-ctcs ctc))) (define has-rest (->i-rest ctc)) (define here (->i-here ctc)) @@ -81,17 +82,18 @@ [rng-pr (in-list (->i-indy-rng-ctcs ctc))]) (rng-proj (blame-add-context indy-rng-blame (format "the ~a result of" (car rng-pr)))))) - (list* (λ (val mtd?) + (list* c-or-i-procedure + (λ (val mtd?) (if has-rest (check-procedure/more val mtd? (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) - blame) + blame #f) (check-procedure val mtd? (->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) - blame))) + blame #f))) ctc blame swapped-blame ;; used by the #:pre and #:post checking (append blames @@ -103,11 +105,11 @@ (->i-rng-dep-ctcs ctc) partial-indy-rngs))) -(define arr->i-proj - (λ (ctc) +(define arr->i-late-neg-proj + (λ (ctc c-or-i-procedure) (define func (->i-mk-wrapper ctc)) (λ (blame) - (define ???-args (build-??-args ctc blame)) + (define ???-args (build-??-args c-or-i-procedure ctc blame)) (apply func ???-args)))) @@ -183,140 +185,157 @@ pre/post-procs mandatory-args opt-args mandatory-kwds opt-kwds rest mtd? here mk-wrapper mk-val-first-wrapper name-info) - #:property prop:custom-write custom-write-property-proc - #:property prop:contract - (build-contract-property - #:val-first-projection - (λ (ctc) - (define blame-accepting-proj (arr->i-proj ctc)) - (λ (blame) - (λ (val) - (wrapped-extra-arg-arrow - (λ (neg-party) - ((blame-accepting-proj (blame-add-missing-party blame neg-party)) val)) - (->i-mk-val-first-wrapper ctc))))) - #:late-neg-projection - (λ (ctc) - (define blame-accepting-proj (arr->i-proj ctc)) - (λ (blame) - (λ (val neg-party) - ((blame-accepting-proj (blame-add-missing-party blame neg-party)) val)))) - #:projection arr->i-proj - #:name (λ (ctc) - (define (arg/ress->spec infos ctcs dep-ctcs skip?) - (let loop ([infos infos] - [ctcs ctcs] - [dep-ctcs dep-ctcs]) - (cond - [(null? infos) '()] - [else - (let* ([info (car infos)] - [dep/nodep (list-ref info 0)] - [var (list-ref info 1)] - [vars (list-ref info 2)] - [kwd (list-ref info 3)]) - (case dep/nodep - [(nodep) - (if (skip? info) - (loop (cdr infos) (cdr ctcs) dep-ctcs) - `(,@(if kwd - (list kwd) - (list)) - [,var ,(contract-name (car ctcs))] - . - ,(loop (cdr infos) (cdr ctcs) dep-ctcs)))] - [(dep) - (define body-src (list-ref info 5)) - (if (skip? info) - (loop (cdr infos) ctcs (cdr dep-ctcs)) - `(,@(if kwd - (list kwd) - (list)) - [,var ,vars ,body-src] - . - ,(loop (cdr infos) ctcs (cdr dep-ctcs))))]))]))) - (let* ([name-info (->i-name-info ctc)] - [args-info (vector-ref name-info 0)] - [rest-info (vector-ref name-info 1)] - [pre-infos (vector-ref name-info 2)] - [rng-info (vector-ref name-info 3)] - [post-infos (vector-ref name-info 4)]) - `(->i ,(arg/ress->spec args-info - (map ->i-arg-contract (->i-arg-ctcs ctc)) - (->i-arg-dep-ctcs ctc) - (λ (x) (list-ref x 4))) - ,@(let ([rests (arg/ress->spec args-info - (map ->i-arg-contract (->i-arg-ctcs ctc)) - (->i-arg-dep-ctcs ctc) - (λ (x) (not (list-ref x 4))))]) - (if (null? rests) - '() - (list rests))) - ,@(if rest-info - (case (car rest-info) - [(nodep) `(#:rest - [,(list-ref rest-info 1) - ,(contract-name - (car - (reverse - (map ->i-arg-contract (->i-arg-ctcs ctc)))))])] - [(dep) `(#:rest [,(list-ref rest-info 1) - ,(list-ref rest-info 2) - ,(list-ref rest-info 3)])]) - '()) - ,@(apply - append - (for/list ([pre-info pre-infos]) - (define ids (list-ref pre-info 0)) - (define name (list-ref pre-info 1)) - (define code (list-ref pre-info 2)) - (cond - [(string? name) - `(#:pre/name ,ids ,name ,code)] - [(equal? name 'bool) - `(#:pre ,ids ,code)] - [(equal? name 'desc) - `(#:pre/desc ,ids ,code)]))) - ,(cond - [(not rng-info) - 'any] - [else - (let ([infos (arg/ress->spec rng-info - (map cdr (->i-rng-ctcs ctc)) - (->i-rng-dep-ctcs ctc) - (λ (x) #f))]) - (cond - [(or (null? infos) (not (null? (cdr infos)))) - `(values ,@infos)] - [else - (car infos)]))]) - ,@(apply - append - (for/list ([post-info post-infos]) - (define ids (list-ref post-info 0)) - (define name (list-ref post-info 1)) - (define code (list-ref post-info 2)) - (cond - [(string? name) - `(#:post/name ,ids ,name ,code)] - [(equal? name 'bool) - `(#:post ,ids ,code)] - [(equal? name 'desc) - `(#:post/desc ,ids ,code)])))))) - #:first-order - (λ (ctc) - (let ([has-rest (->i-rest ctc)] - [mtd? (->i-mtd? ctc)] - [mand-args (->i-mandatory-args ctc)] - [opt-args (->i-opt-args ctc)] - [mand-kwds (->i-mandatory-kwds ctc)] - [opt-kwds (->i-opt-kwds ctc)]) - (λ (val) - (if has-rest - (check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f) - (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f))))) - #:exercise exercise->i - #:stronger (λ (this that) (eq? this that)))) ;; WRONG + #:property prop:custom-write custom-write-property-proc) + +(define (mk-prop chaperone?) + (define c-or-i-procedure (if chaperone? chaperone-procedure impersonate-procedure)) + ((if chaperone? build-chaperone-contract-property build-contract-property) + #:val-first-projection + (λ (ctc) + (define blame-accepting-proj (arr->i-late-neg-proj ctc c-or-i-procedure)) + (maybe-warn-about-val-first ctc) + (λ (blame) + (define val+neg-party-accepting-proj (blame-accepting-proj blame)) + (λ (val) + (wrapped-extra-arg-arrow + (λ (neg-party) + (val+neg-party-accepting-proj val neg-party)) + (->i-mk-val-first-wrapper ctc))))) + #:late-neg-projection + (λ (ctc) (arr->i-late-neg-proj ctc c-or-i-procedure)) + #:name (λ (ctc) + (define (arg/ress->spec infos ctcs dep-ctcs skip?) + (let loop ([infos infos] + [ctcs ctcs] + [dep-ctcs dep-ctcs]) + (cond + [(null? infos) '()] + [else + (let* ([info (car infos)] + [dep/nodep (list-ref info 0)] + [var (list-ref info 1)] + [vars (list-ref info 2)] + [kwd (list-ref info 3)]) + (case dep/nodep + [(nodep) + (if (skip? info) + (loop (cdr infos) (cdr ctcs) dep-ctcs) + `(,@(if kwd + (list kwd) + (list)) + [,var ,(contract-name (car ctcs))] + . + ,(loop (cdr infos) (cdr ctcs) dep-ctcs)))] + [(dep) + (define body-src (list-ref info 5)) + (if (skip? info) + (loop (cdr infos) ctcs (cdr dep-ctcs)) + `(,@(if kwd + (list kwd) + (list)) + [,var ,vars ,body-src] + . + ,(loop (cdr infos) ctcs (cdr dep-ctcs))))]))]))) + (let* ([name-info (->i-name-info ctc)] + [args-info (vector-ref name-info 0)] + [rest-info (vector-ref name-info 1)] + [pre-infos (vector-ref name-info 2)] + [rng-info (vector-ref name-info 3)] + [post-infos (vector-ref name-info 4)]) + `(->i ,(arg/ress->spec args-info + (map ->i-arg-contract (->i-arg-ctcs ctc)) + (->i-arg-dep-ctcs ctc) + (λ (x) (list-ref x 4))) + ,@(let ([rests (arg/ress->spec args-info + (map ->i-arg-contract (->i-arg-ctcs ctc)) + (->i-arg-dep-ctcs ctc) + (λ (x) (not (list-ref x 4))))]) + (if (null? rests) + '() + (list rests))) + ,@(if rest-info + (case (car rest-info) + [(nodep) `(#:rest + [,(list-ref rest-info 1) + ,(contract-name + (car + (reverse + (map ->i-arg-contract (->i-arg-ctcs ctc)))))])] + [(dep) `(#:rest [,(list-ref rest-info 1) + ,(list-ref rest-info 2) + ,(list-ref rest-info 3)])]) + '()) + ,@(apply + append + (for/list ([pre-info pre-infos]) + (define ids (list-ref pre-info 0)) + (define name (list-ref pre-info 1)) + (define code (list-ref pre-info 2)) + (cond + [(string? name) + `(#:pre/name ,ids ,name ,code)] + [(equal? name 'bool) + `(#:pre ,ids ,code)] + [(equal? name 'desc) + `(#:pre/desc ,ids ,code)]))) + ,(cond + [(not rng-info) + 'any] + [else + (let ([infos (arg/ress->spec rng-info + (map cdr (->i-rng-ctcs ctc)) + (->i-rng-dep-ctcs ctc) + (λ (x) #f))]) + (cond + [(or (null? infos) (not (null? (cdr infos)))) + `(values ,@infos)] + [else + (car infos)]))]) + ,@(apply + append + (for/list ([post-info post-infos]) + (define ids (list-ref post-info 0)) + (define name (list-ref post-info 1)) + (define code (list-ref post-info 2)) + (cond + [(string? name) + `(#:post/name ,ids ,name ,code)] + [(equal? name 'bool) + `(#:post ,ids ,code)] + [(equal? name 'desc) + `(#:post/desc ,ids ,code)])))))) + #:first-order + (λ (ctc) + (let ([has-rest (->i-rest ctc)] + [mtd? (->i-mtd? ctc)] + [mand-args (->i-mandatory-args ctc)] + [opt-args (->i-opt-args ctc)] + [mand-kwds (->i-mandatory-kwds ctc)] + [opt-kwds (->i-opt-kwds ctc)]) + (λ (val) + (if has-rest + (check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f #f) + (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f #f))))) + #:exercise exercise->i + #:stronger (λ (this that) (eq? this that)))) ;; WRONG + +(struct chaperone->i ->i () #:property prop:chaperone-contract (mk-prop #t)) +(struct impersonator->i ->i () #:property prop:contract (mk-prop #f)) +(define (make-->i is-chaperone-contract? blame-info + arg-ctcs arg-dep-ctcs indy-arg-ctcs + rng-ctcs rng-dep-ctcs indy-rng-ctcs + pre/post-procs + mandatory-args opt-args mandatory-kwds opt-kwds rest + mtd? here mk-wrapper mk-val-first-wrapper name-info) + (define maker (if is-chaperone-contract? chaperone->i impersonator->i)) + (maker blame-info + arg-ctcs arg-dep-ctcs indy-arg-ctcs + rng-ctcs rng-dep-ctcs indy-rng-ctcs + pre/post-procs + mandatory-args opt-args mandatory-kwds opt-kwds rest + mtd? here mk-wrapper mk-val-first-wrapper name-info)) + + ;; find-ordering : (listof arg) -> (values (listof arg) (listof number)) ;; sorts the arguments according to the dependency order. @@ -555,7 +574,7 @@ evaluted left-to-right.) (define-for-syntax (maybe-generate-temporary x) (and x (car (generate-temporaries (list x))))) -(define (signal-pre/post pre? val kind blame condition-result . var-infos) +(define (signal-pre/post pre? val kind blame neg-party condition-result . var-infos) (define vars-str (apply string-append @@ -578,7 +597,7 @@ evaluted left-to-right.) vars-str)] [else (pre-post/desc-result->string condition-result pre? '->i)])) - (raise-blame-error blame val "~a" msg)) + (raise-blame-error blame #:missing-party neg-party val "~a" msg)) (define-for-syntax (add-pre-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress call-stx) @@ -599,6 +618,7 @@ evaluted left-to-right.) val '#,(pre/post-kind pre) swapped-blame + neg-party condition-result #,@(map (λ (x) #`(list '#,x #,(arg/res-to-indy-var indy-arg-vars @@ -629,6 +649,7 @@ evaluted left-to-right.) val '#,(pre/post-kind post) blame + neg-party condition-result #,@(map (λ (x) #`(list '#,x #,(arg/res-to-indy-var indy-arg-vars ordered-args @@ -640,6 +661,7 @@ evaluted left-to-right.) ;; add-wrapper-let : ;; syntax? -- placed into the body position of the generated let expression +;; boolean? -- indicates if this is a chaperone contract ;; boolean? -- indicates if this is an arg or a res; affects only how blame-var-table is filled in ;; (listof arg/res) -- sorted version of the arg/res structs, ordered by evaluation order ;; (listof int) -- indices that give the mapping from the ordered-args to the original order @@ -655,7 +677,7 @@ evaluted left-to-right.) ;; adds nested lets that bind the wrapper-args and the indy-arg/res-vars to projected values, ;; with 'body' in the body of the let also handles adding code to check to see if unsupplied ;; args are present (skipping the contract check, if so) -(define-for-syntax (add-wrapper-let body swapped-blame? neg-calls? +(define-for-syntax (add-wrapper-let body is-chaperone-contract? swapped-blame? neg-calls? ordered-arg/reses indicies arg/res-proj-vars indy-arg/res-proj-vars wrapper-arg/ress indy-arg/res-vars @@ -670,10 +692,10 @@ evaluted left-to-right.) stx)) (for/fold ([body body]) - ([indy-arg/res-var (in-list indy-arg/res-vars)] - [an-arg/res (in-list ordered-arg/reses)] - [index indicies] - [i (in-naturals)]) + ([indy-arg/res-var (in-list indy-arg/res-vars)] + [an-arg/res (in-list ordered-arg/reses)] + [index indicies] + [i (in-naturals)]) (let ([wrapper-arg (vector-ref wrapper-arg/ress index)] [arg/res-proj-var (vector-ref arg/res-proj-vars index)] [indy-arg/res-proj-var (vector-ref indy-arg/res-proj-vars index)]) @@ -695,9 +717,10 @@ evaluted left-to-right.) ordered-ress var)) (arg/res-vars an-arg/res)) - #,wrapper-arg - #,(build-blame-identifier #t swapped-blame? (arg/res-var an-arg/res))) - #`(#,indy-arg/res-proj-var #,wrapper-arg)))]) + #,wrapper-arg + #,(build-blame-identifier #t swapped-blame? (arg/res-var an-arg/res)) + neg-party) + #`(#,indy-arg/res-proj-var #,wrapper-arg neg-party)))]) (list))]) #`(let (#,@indy-binding [#,wrapper-arg @@ -706,11 +729,13 @@ evaluted left-to-right.) wrapper-arg (cond [(and (eres? an-arg/res) (arg/res-vars an-arg/res)) - #`(un-dep #,(eres-eid an-arg/res) - #,wrapper-arg - #,(build-blame-identifier #f - swapped-blame? - (arg/res-var an-arg/res)))] + #`(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) + #,(eres-eid an-arg/res) + #,wrapper-arg + #,(build-blame-identifier #f + swapped-blame? + (arg/res-var an-arg/res)) + neg-party)] [(arg/res-vars an-arg/res) #`(#,arg/res-proj-var #,@(map (λ (var) (arg/res-to-indy-var indy-arg-vars @@ -719,10 +744,11 @@ evaluted left-to-right.) ordered-ress var)) (arg/res-vars an-arg/res)) - #,wrapper-arg - #,(build-blame-identifier #f swapped-blame? (arg/res-var an-arg/res)))] + #,wrapper-arg + #,(build-blame-identifier #f swapped-blame? (arg/res-var an-arg/res)) + neg-party)] [else - #`(#,arg/res-proj-var #,wrapper-arg)]))]) + #`(#,arg/res-proj-var #,wrapper-arg neg-party)]))]) #,body))))) @@ -784,11 +810,12 @@ evaluted left-to-right.) (list #`(case-lambda [#,(vector->list wrapper-ress) - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + blame #,(add-wrapper-let (add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress #`(values #,@(vector->list wrapper-ress))) + (istx-is-chaperone-contract? an-istx) #f #f ordered-ress res-indices res-proj-vars indy-res-proj-vars @@ -868,6 +895,7 @@ evaluted left-to-right.) (istx-rst an-istx) wrapper-args this-param))) + (istx-is-chaperone-contract? an-istx) #t #f ordered-args arg-indices arg-proj-vars indy-arg-proj-vars @@ -877,22 +905,20 @@ evaluted left-to-right.) (map cdr blame-ids) (with-syntax ([arg-checker (or (syntax-local-infer-name stx) 'arg-checker)]) #`(λ #,wrapper-proc-arglist - (λ (val) + (λ (val neg-party) (chk val #,(and (syntax-parameter-value #'making-a-method) #t)) - (impersonate-procedure + (c-or-i-procedure val (let ([arg-checker (λ #,(args/vars->arglist an-istx wrapper-args this-param) #,wrapper-body)]) (make-keyword-procedure (λ (kwds kwd-args . args) - (with-continuation-mark - contract-continuation-mark-key blame - (keyword-apply arg-checker kwds kwd-args args))) + (with-contract-continuation-mark + blame (keyword-apply arg-checker kwds kwd-args args))) (λ args - (with-continuation-mark - contract-continuation-mark-key blame - (apply arg-checker args))))) + (with-contract-continuation-mark + blame (apply arg-checker args))))) impersonator-prop:contracted ctc impersonator-prop:blame blame)))))) @@ -956,7 +982,7 @@ evaluted left-to-right.) '())))) (define wrapper-proc-arglist - #`(chk ctc blame swapped-blame #,@(map car blame-ids) + #`(c-or-i-procedure chk ctc blame swapped-blame #,@(map car blame-ids) ;; the pre- and post-condition procs #,@(for/list ([pres (istx-pre an-istx)] @@ -1030,7 +1056,7 @@ evaluted left-to-right.) (define this-param (and (syntax-parameter-value #'making-a-method) (car (generate-temporaries '(this))))) - #`(λ #,wrapper-proc-arglist + #`(λ #,wrapper-proc-arglist (λ (f) (λ (neg-party #,@(args/vars->arglist an-istx wrapper-args this-param)) #,(add-wrapper-let @@ -1039,6 +1065,7 @@ evaluted left-to-right.) (istx-rst an-istx) wrapper-args this-param) + (istx-is-chaperone-contract? an-istx) #t #t ordered-args arg-indices arg-proj-vars indy-arg-proj-vars @@ -1061,9 +1088,24 @@ evaluted left-to-right.) #`(f #,@argument-list))) (begin-encourage-inline - (define (un-dep ctc obj blame) - (let ([ctc (coerce-contract '->i ctc)]) - (((contract-projection ctc) blame) obj)))) + (define (un-dep/maybe-chaperone orig-ctc obj blame neg-party chaperone?) + (cond + [(and (procedure? orig-ctc) + (procedure-arity-includes? orig-ctc 1)) + (if (orig-ctc obj) + obj + (raise-predicate-blame-error-failure blame obj neg-party + (object-name orig-ctc)))] + [else + (define ctc (if chaperone? + (coerce-chaperone-contract '->i orig-ctc) + (coerce-contract '->i orig-ctc))) + (((get/build-late-neg-projection ctc) blame) obj neg-party)])) + (define (un-dep/chaperone orig-ctc obj blame neg-party) + (un-dep/maybe-chaperone orig-ctc obj blame neg-party #t)) + + (define (un-dep orig-ctc obj blame neg-party) + (un-dep/maybe-chaperone orig-ctc obj blame neg-party #f))) (define-for-syntax (mk-used-indy-vars an-istx) (let ([vars (make-free-identifier-mapping)]) @@ -1162,11 +1204,14 @@ evaluted left-to-right.) "could not find ~s in ~s\n" an-id arg/ress-to-look-in)) ans)) + + (define is-chaperone-contract? (istx-is-chaperone-contract? an-istx)) #`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ... [res-exp-xs (coerce-contract '->i res-exps)] ...) #,(syntax-property - #`(->i + #`(make-->i + #,is-chaperone-contract? ;; the information needed to make the blame records and their new contexts '#,blame-ids ;; all of the non-dependent argument contracts @@ -1183,11 +1228,12 @@ evaluted left-to-right.) this->i) 'racket/contract:contract-on-boundary (gensym '->i-indy-boundary))) - #`(λ (#,@orig-vars val blame) + #`(λ (#,@orig-vars val blame neg-party) #,@(arg/res-vars arg) ;; this used to use opt/direct, but ;; opt/direct duplicates code (bad!) - (un-dep #,ctc-stx val blame)))) + (#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) + #,ctc-stx val blame neg-party)))) ;; then the non-dependent argument contracts that are themselves dependend on (list #,@(filter values (map (λ (arg/res indy-id) @@ -1223,11 +1269,12 @@ evaluted left-to-right.) #`(λ #,orig-vars #,@(arg/res-vars arg) (opt/c #,arg-stx)) - #`(λ (#,@orig-vars val blame) + #`(λ (#,@orig-vars val blame neg-party) ;; this used to use opt/direct, but ;; opt/direct duplicates code (bad!) #,@(arg/res-vars arg) - (un-dep #,arg-stx val blame))))) + (#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) + #,arg-stx val blame neg-party))))) #''()) #,(if (istx-ress an-istx) #`(list #,@(filter values diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index bcff1fc39d..01e0469037 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -8,11 +8,10 @@ "misc.rkt" "prop.rkt" "guts.rkt" - "generate.rkt" - racket/stxparam (prefix-in arrow: "arrow.rkt")) (provide (for-syntax build-chaperone-constructor/real) + procedure-arity-exactly/no-kwds ->-proj check-pre-cond check-post-cond @@ -34,15 +33,15 @@ [(optional-dom-kwd-proj ...) (nvars (length optional-dom-kwds) 'optional-dom-proj)] [(rng-proj ...) (if rngs (generate-temporaries rngs) '())] [(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())]) - #`(λ (blame f neg-party + #`(λ (blame f neg-party blame-party-info rng-ctcs mandatory-dom-proj ... optional-dom-proj ... rest-proj ... mandatory-dom-kwd-proj ... optional-dom-kwd-proj ... rng-proj ...) - #,(create-chaperone - #'blame #'f + #,(create-chaperone + #'blame #'neg-party #'blame-party-info #'f #'rng-ctcs this-args (syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(optional-dom-proj ...)) @@ -59,20 +58,20 @@ (define (check-pre-cond pre blame neg-party val) - (with-continuation-mark contract-continuation-mark-key - (cons blame neg-party) - (unless (pre) - (raise-blame-error (blame-swap blame) - #:missing-party neg-party - val "#:pre condition")))) + (with-contract-continuation-mark + (cons blame neg-party) + (unless (pre) + (raise-blame-error (blame-swap blame) + #:missing-party neg-party + val "#:pre condition")))) (define (check-post-cond post blame neg-party val) - (with-continuation-mark contract-continuation-mark-key - (cons blame neg-party) - (unless (post) - (raise-blame-error blame - #:missing-party neg-party - val "#:post condition")))) + (with-contract-continuation-mark + (cons blame neg-party) + (unless (post) + (raise-blame-error blame + #:missing-party neg-party + val "#:post condition")))) (define (check-pre-cond/desc post blame neg-party val) (handle-pre-post/desc-string #t post blame neg-party val)) @@ -116,7 +115,8 @@ (if pre? "pre" "post") condition-result)])) -(define-for-syntax (create-chaperone blame val +(define-for-syntax (create-chaperone blame neg-party blame-party-info + val rng-ctcs this-args doms opt-doms req-kwds opt-kwds @@ -152,7 +152,7 @@ [(opt-kwd ...) (map car opt-kwds)] [(opt-kwd-ctc ...) (map cadr opt-kwds)] [(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))] - [(rng-ctc ...) (if rngs rngs '())] + [(rng-late-neg-projs ...) (if rngs rngs '())] [(rng-x ...) (if rngs (generate-temporaries rngs) '())]) (with-syntax ([(rng-checker-name ...) (if rngs @@ -163,12 +163,11 @@ (list (with-syntax ([rng-len (length rngs)]) (with-syntax ([rng-results - #'(values (rng-ctc rng-x neg-party) + #'(values (rng-late-neg-projs rng-x neg-party) ...)]) #'(case-lambda [(rng-x ...) - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (let () post ... @@ -251,7 +250,9 @@ dom-projd-args ...)))]) (if no-rng-checking? (inner-stx-gen #'()) - (arrow:check-tail-contract #'(rng-ctc ...) + (arrow:check-tail-contract rng-ctcs + blame-party-info + neg-party #'(rng-checker-name ...) inner-stx-gen)))] [kwd-return @@ -276,7 +277,9 @@ #`(let ([kwd-results kwd-stx]) #,(if no-rng-checking? (outer-stx-gen #'()) - (arrow:check-tail-contract #'(rng-ctc ...) + (arrow:check-tail-contract rng-ctcs + blame-party-info + neg-party #'(rng-checker-name ...) outer-stx-gen))))]) (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] @@ -290,15 +293,13 @@ ;; Overhead of double-wrapping has not been ;; noticeable in my measurements so far. ;; - stamourv - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (let () pre ... basic-return)))] [kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda #`(λ kwd-lam-params - (with-continuation-mark - contract-continuation-mark-key + (with-contract-continuation-mark (cons blame neg-party) (let () pre ... kwd-return)))]) @@ -308,7 +309,7 @@ #`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) (let ([basic-lambda-name basic-lambda]) (arrow:arity-checking-wrapper val - (blame-add-missing-party blame neg-party) + blame neg-party basic-lambda-name void #,min-method-arity @@ -321,7 +322,7 @@ #`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) (let ([kwd-lambda-name kwd-lambda]) (arrow:arity-checking-wrapper val - (blame-add-missing-party blame neg-party) + blame neg-party void kwd-lambda-name #,min-method-arity @@ -335,7 +336,7 @@ (let ([basic-lambda-name basic-lambda] [kwd-lambda-name kwd-lambda]) (arrow:arity-checking-wrapper val - (blame-add-missing-party blame neg-party) + blame neg-party basic-lambda-name kwd-lambda-name #,min-method-arity @@ -357,6 +358,14 @@ late-neg?) (define optionals-length (- (length doms) min-arity)) (define mtd? #f) ;; not yet supported for the new contracts + (define okay-to-do-only-arity-check? + (and (not rest) + (not pre?) + (not post?) + (null? kwd-infos) + (not rngs) + (andmap any/c? doms) + (= optionals-length 0))) (λ (orig-blame) (define rng-blame (arrow:blame-add-range-context orig-blame)) (define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t)) @@ -403,12 +412,15 @@ man-then-opt-partial-kwds partial-ranges (if partial-rest (list partial-rest) '()))) - + (define blame-party-info (arrow:get-blame-party-info orig-blame)) (define (successfully-got-the-right-kind-of-function val neg-party) - (define chap/imp-func (apply chaperone-constructor orig-blame val neg-party the-args)) + (define chap/imp-func (apply chaperone-constructor + orig-blame val + neg-party blame-party-info + rngs the-args)) (cond [chap/imp-func - (if post? + (if (or post? (not rngs)) (chaperone-or-impersonate-procedure val chap/imp-func @@ -419,23 +431,27 @@ chap/imp-func impersonator-prop:contracted ctc impersonator-prop:blame (blame-add-missing-party orig-blame neg-party) - impersonator-prop:application-mark (cons arrow:contract-key - ;; is this right? - partial-ranges)))] + impersonator-prop:application-mark + (cons arrow:tail-contract-key (list* neg-party blame-party-info rngs))))] [else val])) - (cond [late-neg? - (λ (val neg-party) + (define (arrow-higher-order:lnp val neg-party) (cond [(do-arity-checking orig-blame val doms rest min-arity kwd-infos) => (λ (f) (f neg-party))] [else - (successfully-got-the-right-kind-of-function val neg-party)]))] + (successfully-got-the-right-kind-of-function val neg-party)])) + (if okay-to-do-only-arity-check? + (λ (val neg-party) + (cond + [(procedure-arity-exactly/no-kwds val min-arity) val] + [else (arrow-higher-order:lnp val neg-party)])) + arrow-higher-order:lnp)] [else - (λ (val) + (define (arrow-higher-order:vfp val) (wrapped-extra-arg-arrow (cond [(do-arity-checking orig-blame val doms rest min-arity kwd-infos) @@ -444,4 +460,20 @@ [else (λ (neg-party) (successfully-got-the-right-kind-of-function val neg-party))]) - (apply plus-one-arity-function orig-blame val plus-one-constructor-args)))]))) + (apply plus-one-arity-function orig-blame val plus-one-constructor-args))) + (if okay-to-do-only-arity-check? + (λ (val) + (cond + [(procedure-arity-exactly/no-kwds val min-arity) + (wrapped-extra-arg-arrow + (λ (neg-party) val) + (apply plus-one-arity-function orig-blame val plus-one-constructor-args))] + [else (arrow-higher-order:vfp val)])) + arrow-higher-order:vfp)]))) + +(define (procedure-arity-exactly/no-kwds val min-arity) + (and (procedure? val) + (equal? (procedure-arity val) min-arity) + (let-values ([(man opt) (procedure-keywords val)]) + (and (null? man) + (null? opt))))) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 84bf657b79..32497e22c2 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -3,7 +3,6 @@ "application-arity-checking.rkt" "arr-util.rkt") "kwd-info-struct.rkt" - "arity-checking.rkt" "blame.rkt" "misc.rkt" "prop.rkt" @@ -16,7 +15,9 @@ (provide ->2 ->*2 dynamic->* (for-syntax ->2-handled? + ->2-arity-check-only->? ->*2-handled? + ->2*-arity-check-only->? ->-valid-app-shapes ->*-valid-app-shapes) (rename-out [-predicate/c predicate/c])) @@ -26,11 +27,13 @@ [(_ args ...) (syntax-parameter-value #'arrow:making-a-method) #f] - [(_ any/c ... any) - ;; should turn into a flat contract - #f] [_ #t])) +(define-for-syntax (->2-arity-check-only->? stx) + (syntax-case stx (any any/c) + [(_ any/c ... any) (- (length (syntax->list stx)) 2)] + [_ #f])) + (define-for-syntax (->*2-handled? stx) (syntax-case stx (any values any/c) [(_ args ...) @@ -38,6 +41,12 @@ #f] [_ #t])) +(define-for-syntax (->2*-arity-check-only->? stx) + (syntax-case stx (any any/c) + [(_ (any/c ...) any) (length (syntax->list (cadr (syntax->list stx))))] + [(_ (any/c ...) () any) (length (syntax->list (cadr (syntax->list stx))))] + [_ #f])) + (define-for-syntax popular-keys ;; of the 8417 contracts that get compiled during ;; 'raco setup' of the current tree, these are all @@ -251,9 +260,9 @@ '()))) (define let-values-clause #`[#,(reverse args-vars) - (with-continuation-mark contract-continuation-mark-key - blame+neg-party - (values #,@(reverse args-expressions)))]) + (with-contract-continuation-mark + blame+neg-party + (values #,@(reverse args-expressions)))]) (define the-clause (if rngs @@ -270,7 +279,7 @@ [args (values args #,@(map (λ (x) #'#f) (syntax->list #'(res-x ...))))]))) - (with-continuation-mark contract-continuation-mark-key + (with-contract-continuation-mark blame+neg-party (cond [failed @@ -314,7 +323,8 @@ #,(if post post #'#f) #,(if rngs #'(list rb ...) #'#f))])) #`(λ (blame f regb ... optb ... kb ... okb ... rb ... #,@(if rest (list #'restb) '())) - #,body-proc))))) + (procedure-specialize + #,body-proc)))))) (define (make-checking-proc f blame pre original-mandatory-kwds kbs @@ -895,7 +905,7 @@ optional-keywords (and rest-contract #t) rng-len) - (λ (blame f neg-party . args) + (λ (blame f neg-party blame-party-info rng-ctc-x . args) (define-next next args) (define mandatory-dom-projs (next min-arity)) (define optional-dom-projs (next optionals)) @@ -911,7 +921,6 @@ (for/list ([kwd (in-list (append mandatory-keywords optional-keywords))] [kwd-proj (in-list (append mandatory-dom-kwd-projs optional-dom-kwd-projs))]) (cons kwd kwd-proj)))) - (define complete-blame (blame-add-missing-party blame neg-party)) (define interposition-proc (make-keyword-procedure @@ -936,7 +945,8 @@ (loop (cdr args) (cdr projs)))]))) (define (result-checker . results) (unless (= rng-len (length results)) - (arrow:bad-number-of-results complete-blame f rng-len results)) + (arrow:bad-number-of-results (blame-add-missing-party blame neg-party) + f rng-len results)) (apply values (for/list ([res (in-list results)] @@ -952,7 +962,7 @@ (cons result-checker args-dealt-with) args-dealt-with))))) - (arrow:arity-checking-wrapper f complete-blame + (arrow:arity-checking-wrapper f blame neg-party interposition-proc interposition-proc min-arity max-arity min-arity max-arity @@ -1152,6 +1162,7 @@ (define (make-property build-X-property chaperone-or-impersonate-procedure) (define val-first-proj (λ (->stct) + (maybe-warn-about-val-first ->stct) (->-proj chaperone-or-impersonate-procedure ->stct (base->-min-arity ->stct) (base->-doms ->stct) @@ -1176,45 +1187,45 @@ (base->-plus-one-arity-function ->stct) (base->-chaperone-constructor ->stct) #t))) - (parameterize ([skip-projection-wrapper? #t]) - (build-X-property - #:name base->-name - #:first-order ->-first-order - #:projection - (λ (this) - (define cthis (val-first-proj this)) - (λ (blame) - (define cblame (cthis blame)) - (λ (val) - ((cblame val) #f)))) - #:stronger - (λ (this that) - (and (base->? that) - (= (length (base->-doms that)) - (length (base->-doms this))) - (= (base->-min-arity this) (base->-min-arity that)) - (andmap contract-stronger? (base->-doms that) (base->-doms this)) - (= (length (base->-kwd-infos this)) - (length (base->-kwd-infos that))) - (for/and ([this-kwd-info (base->-kwd-infos this)] - [that-kwd-info (base->-kwd-infos that)]) - (and (equal? (kwd-info-kwd this-kwd-info) - (kwd-info-kwd that-kwd-info)) - (contract-stronger? (kwd-info-ctc that-kwd-info) - (kwd-info-ctc this-kwd-info)))) - (if (base->-rngs this) - (and (base->-rngs that) - (andmap contract-stronger? (base->-rngs this) (base->-rngs that))) - (not (base->-rngs that))) - (not (base->-pre? this)) - (not (base->-pre? that)) - (not (base->-post? this)) - (not (base->-post? that)))) - #:generate ->-generate - #:exercise ->-exercise - #:val-first-projection val-first-proj - #:late-neg-projection late-neg-proj))) + (build-X-property + #:name base->-name + #:first-order ->-first-order + #:projection + (λ (this) + (define cthis (val-first-proj this)) + (λ (blame) + (define cblame (cthis blame)) + (λ (val) + ((cblame val) #f)))) + #:stronger ->-stronger + #:generate ->-generate + #:exercise ->-exercise + #:val-first-projection val-first-proj + #:late-neg-projection late-neg-proj)) +(define (->-stronger this that) + (and (base->? that) + (= (length (base->-doms that)) + (length (base->-doms this))) + (= (base->-min-arity this) (base->-min-arity that)) + (andmap contract-struct-stronger? (base->-doms that) (base->-doms this)) + (= (length (base->-kwd-infos this)) + (length (base->-kwd-infos that))) + (for/and ([this-kwd-info (base->-kwd-infos this)] + [that-kwd-info (base->-kwd-infos that)]) + (and (equal? (kwd-info-kwd this-kwd-info) + (kwd-info-kwd that-kwd-info)) + (contract-struct-stronger? (kwd-info-ctc that-kwd-info) + (kwd-info-ctc this-kwd-info)))) + (if (base->-rngs this) + (and (base->-rngs that) + (andmap contract-struct-stronger? (base->-rngs this) (base->-rngs that))) + (not (base->-rngs that))) + (not (base->-pre? this)) + (not (base->-pre? that)) + (not (base->-post? this)) + (not (base->-post? that)))) + (define-struct (-> base->) () #:property prop:chaperone-contract @@ -1242,7 +1253,7 @@ (make--> 0 '() '() #f #f (list (coerce-contract 'whatever void?)) #f - (λ (blame f _ignored-rng-contract) + (λ (blame f _ignored-rng-ctcs _ignored-rng-proj) (λ (neg-party) (call-with-values (λ () (f)) @@ -1276,7 +1287,11 @@ (call-with-values (λ () (f argument)) (rng-checker f blame neg-party)))) - (λ (blame f neg-party _ignored-dom-contract _ignored-rng-contract) + (λ (blame f neg-party + _ignored-blame-party-info + _ignored-rng-ctcs + _ignored-dom-contract + _ignored-rng-contract) (unless (procedure? f) (raise-blame-error blame #:missing-party neg-party f @@ -1289,7 +1304,9 @@ given: "~e") f)) (cond - [(struct-predicate-procedure? f) #f] + [(and (struct-predicate-procedure? f) + (not (impersonator? f))) + #f] [(and (equal? (procedure-arity f) 1) (let-values ([(required mandatory) (procedure-keywords f)]) (and (null? required) diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index 42dd7ee2ee..384784b4a1 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -4,7 +4,6 @@ "blame.rkt" "prop.rkt" "misc.rkt" - "generate.rkt" racket/stxparam racket/private/performance-hint) (require (for-syntax racket/base) @@ -33,8 +32,9 @@ (for-syntax check-tail-contract make-this-parameters parse-leftover->*) - contract-key + tail-contract-key tail-marks-match? + get-blame-party-info values/drop arity-checking-wrapper unspecified-dom @@ -50,34 +50,51 @@ (list id) null)) -(define contract-key (gensym 'contract-key)) +(define tail-contract-key (gensym 'tail-contract-key)) -(define-for-syntax (check-tail-contract rng-ctcs rng-checkers call-gen) +(define-for-syntax (check-tail-contract rng-ctcs blame-party-info neg-party rng-checkers call-gen) + (unless (identifier? rng-ctcs) + (raise-argument-error 'check-tail-contract + "identifier?" + 0 + rng-ctcs rng-checkers call-gen)) #`(call-with-immediate-continuation-mark - contract-key + tail-contract-key (λ (m) - (if (tail-marks-match? m . #,rng-ctcs) + (if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party) #,(call-gen #'()) #,(call-gen rng-checkers))))) -(begin-encourage-inline - (define tail-marks-match? - (case-lambda - [(m) (and m (null? m))] - [(m rng-ctc) - (and m - (not (null? m)) - (null? (cdr m)) - (procedure-closure-contents-eq? (car m) rng-ctc))] - [(m rng-ctc1 rng-ctc2) - (and m - (= (length m) 2) - (procedure-closure-contents-eq? (car m) rng-ctc1) - (procedure-closure-contents-eq? (cadr m) rng-ctc1))] - [(m . rng-ctcs) - (and m - (= (length m) (length rng-ctcs)) - (andmap procedure-closure-contents-eq? m rng-ctcs))]))) +;; m : (or/c #f (cons/c neg-party (cons/c (list/c pos-party boolean?[blame-swapped?]) (listof ctc)))) +;; rng-ctc : (or/c #f (listof ctc)) +;; blame-party-info : (list/c pos-party boolean?[blame-swapped?]) +;; neg-party : neg-party +(define (tail-marks-match? m rng-ctcs blame-party-info neg-party) + (and m + rng-ctcs + (eq? (car m) neg-party) + (let ([mark-blame-part-info (cadr m)]) + (and (eq? (car mark-blame-part-info) (car blame-party-info)) + (eq? (cadr mark-blame-part-info) (cadr blame-party-info)))) + (let loop ([m (cddr m)] + [rng-ctcs rng-ctcs]) + (cond + [(null? m) (null? rng-ctcs)] + [(null? rng-ctcs) (null? m)] + [else + (define m1 (car m)) + (define rng-ctc1 (car rng-ctcs)) + (cond + [(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] + [(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] + [else #f])])))) + +;; used as part of the information in the continuation mark +;; that records what is to be checked for a pending contract +(define (get-blame-party-info blame) + (define swapped? (blame-swapped? blame)) + (list (if swapped? (blame-negative blame) (blame-positive blame)) + swapped?)) (define-syntax (unconstrained-domain-> stx) (syntax-case stx () @@ -87,46 +104,52 @@ [(p-app-x ...) (generate-temporaries #'(rngs ...))] [(res-x ...) (generate-temporaries #'(rngs ...))]) #`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) - (let ([proj-x (contract-projection rngs-x)] ...) + (let ([rngs-list (list rngs-x ...)] + [proj-x (get/build-late-neg-projection rngs-x)] ...) (define (projection wrapper get-ctc) (λ (orig-blame) + (define blame-party-info (get-blame-party-info orig-blame)) (define ctc (get-ctc)) (let ([rng-blame (blame-add-range-context orig-blame)]) - (let* ([p-app-x (proj-x rng-blame)] ... - [res-checker (λ (res-x ...) (values/drop (p-app-x res-x) ...))]) - (λ (val) - (check-is-a-procedure orig-blame val) + (let* ([p-app-x (proj-x rng-blame)] ...) + (λ (val neg-party) + (check-is-a-procedure orig-blame neg-party val) + (define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...)) (wrapper val (make-keyword-procedure (λ (kwds kwd-vals . args) - (with-continuation-mark - contract-continuation-mark-key orig-blame + (with-contract-continuation-mark + (cons orig-blame neg-party) #,(check-tail-contract - #'(p-app-x ...) + #'rngs-list + #'blame-party-info + #'neg-party (list #'res-checker) (λ (s) #`(apply values #,@s kwd-vals args))))) (λ args - (with-continuation-mark - contract-continuation-mark-key orig-blame + (with-contract-continuation-mark + (cons orig-blame neg-party) #,(check-tail-contract - #'(p-app-x ...) + #'rngs-list + #'blame-party-info + #'neg-party (list #'res-checker) (λ (s) #`(apply values #,@s args)))))) impersonator-prop:contracted ctc impersonator-prop:application-mark - (cons contract-key (list p-app-x ...)))))))) + (cons tail-contract-key (list neg-party blame-party-info rngs-x ...)))))))) (make-unconstrained-domain-> (list rngs-x ...) projection))))])) -(define (check-is-a-procedure orig-blame val) +(define (check-is-a-procedure orig-blame neg-party val) (unless (procedure? val) - (raise-blame-error orig-blame + (raise-blame-error orig-blame #:missing-party neg-party val '(expected: "a procedure" given: "~v") val))) -(define (make-unconstrained-domain-> ctcs projection) +(define (make-unconstrained-domain-> ctcs late-neg-projection) (define name (apply build-compound-type-name 'unconstrained-domain-> (map contract-name ctcs))) @@ -134,11 +157,11 @@ (if (andmap chaperone-contract? ctcs) (make-chaperone-contract #:name name - #:projection (projection chaperone-procedure (λ () ctc)) + #:late-neg-projection (late-neg-projection chaperone-procedure (λ () ctc)) #:first-order procedure?) (make-contract #:name name - #:projection (projection impersonate-procedure (λ () ctc)) + #:late-neg-projection (late-neg-projection impersonate-procedure (λ () ctc)) #:first-order procedure?))) ctc) @@ -201,18 +224,25 @@ (loop (cdr accepted) req-kwds (cdr opt-kwds))] [else #f]))]))) -(define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs) +(define-for-syntax (create-chaperone blame neg-party blame-party-info val pre post this-args + doms opt-doms dom-rest req-kwds opt-kwds + rngs rng-ctc-id) (with-syntax ([blame blame] + [neg-party neg-party] [val val]) (with-syntax ([(pre ...) (if pre (list #`(unless #,pre - (raise-blame-error (blame-swap blame) val "#:pre condition"))) + (raise-blame-error + (blame-swap blame) #:missing-party neg-party + val "#:pre condition"))) null)] [(post ...) (if post (list #`(unless #,post - (raise-blame-error blame val "#:post condition"))) + (raise-blame-error + blame #:missing-party neg-party + val "#:post condition"))) null)]) (with-syntax ([(this-param ...) this-args] [(dom-ctc ...) doms] @@ -240,12 +270,12 @@ (if (and (pair? rngs) (null? (cdr rngs))) (with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))] [name (car (syntax->list #'(rng-x ...)))]) - #'(proj name)) - #'(values/drop (rng-ctc rng-x) ...))]) + #'(proj name neg-party)) + #'(values/drop (rng-ctc rng-x neg-party) ...))]) #'(case-lambda [(rng-x ...) - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + (cons blame neg-party) (let () post ... rng-results))] @@ -267,13 +297,15 @@ [else #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ...)])] [opt+rest-uses - (for/fold ([i (if dom-rest #'(rest-ctc rest-x) #'null)]) - ([o (in-list (reverse (syntax->list #'([opt-dom-ctc opt-dom-x] ...))))]) + (for/fold ([i (if dom-rest #'(rest-ctc rest-x neg-party) #'null)]) + ([o (in-list (reverse + (syntax->list + #'((opt-dom-ctc opt-dom-x) ...))))]) (let* ([l (syntax->list o)] [c (car l)] [x (cadr l)]) #`(let ([r #,i]) - (if (eq? unspecified-dom #,x) r (cons (#,c #,x) r)))))] + (if (eq? unspecified-dom #,x) r (cons (#,c #,x neg-party) r)))))] [(kwd-param ...) (apply append (map list @@ -282,9 +314,12 @@ [kwd-stx (let* ([req-stxs (map (λ (s) (λ (r) #`(cons #,s #,r))) - (syntax->list #'((req-kwd-ctc req-kwd-x) ...)))] + (syntax->list #'((req-kwd-ctc req-kwd-x neg-party) ...)))] [opt-stxs - (map (λ (x c) (λ (r) #`(let ([r #,r]) (if (eq? unspecified-dom #,x) r (cons (#,c #,x) r))))) + (map (λ (x c) (λ (r) #`(let ([r #,r]) + (if (eq? unspecified-dom #,x) + r + (cons (#,c #,x neg-party) r))))) (syntax->list #'(opt-kwd-x ...)) (syntax->list #'(opt-kwd-ctc ...)))] [reqs (map cons req-keywords req-stxs)] @@ -301,16 +336,25 @@ [basic-return (let ([inner-stx-gen (if need-apply-values? - (λ (s) #`(apply values #,@s this-param ... (dom-ctc dom-x) ... opt+rest-uses)) - (λ (s) #`(values/drop #,@s this-param ... (dom-ctc dom-x) ...)))]) + (λ (s) #`(apply values #,@s this-param ... + (dom-ctc dom-x neg-party) ... opt+rest-uses)) + (λ (s) #`(values/drop #,@s this-param ... + (dom-ctc dom-x neg-party) ...)))]) (if no-rng-checking? (inner-stx-gen #'()) - (check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) inner-stx-gen)))] + (check-tail-contract rng-ctc-id + blame-party-info + #'neg-party + #'(rng-checker-name ...) + inner-stx-gen)))] [kwd-return (let* ([inner-stx-gen (if need-apply-values? - (λ (s k) #`(apply values #,@s #,@k this-param ... (dom-ctc dom-x) ... opt+rest-uses)) - (λ (s k) #`(values/drop #,@s #,@k this-param ... (dom-ctc dom-x) ...)))] + (λ (s k) #`(apply values #,@s #,@k this-param ... + (dom-ctc dom-x neg-party) ... + opt+rest-uses)) + (λ (s k) #`(values/drop #,@s #,@k this-param ... + (dom-ctc dom-x neg-party) ...)))] [outer-stx-gen (if (null? req-keywords) (λ (s) @@ -322,7 +366,11 @@ #`(let ([kwd-results kwd-stx]) #,(if no-rng-checking? (outer-stx-gen #'()) - (check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen))))]) + (check-tail-contract rng-ctc-id + blame-party-info + #'neg-party + #'(rng-checker-name ...) + outer-stx-gen))))]) (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] [basic-lambda #'(λ basic-params ;; Arrow contract domain checking is instrumented @@ -334,14 +382,14 @@ ;; Overhead of double-wrapping has not been ;; noticeable in my measurements so far. ;; - stamourv - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + (cons blame neg-party) (let () pre ... basic-return)))] [kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda #`(λ kwd-lam-params - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + (cons blame neg-party) (let () pre ... kwd-return)))]) (with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))]) @@ -349,7 +397,7 @@ [(and (null? req-keywords) (null? opt-keywords)) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) (let ([basic-lambda-name basic-lambda]) - (arity-checking-wrapper val blame + (arity-checking-wrapper val blame neg-party basic-lambda-name void #,min-method-arity @@ -361,7 +409,7 @@ [(pair? req-keywords) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) (let ([kwd-lambda-name kwd-lambda]) - (arity-checking-wrapper val blame + (arity-checking-wrapper val blame neg-party void kwd-lambda-name #,min-method-arity @@ -374,7 +422,7 @@ #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) (let ([basic-lambda-name basic-lambda] [kwd-lambda-name kwd-lambda]) - (arity-checking-wrapper val blame + (arity-checking-wrapper val blame neg-party basic-lambda-name kwd-lambda-name #,min-method-arity @@ -385,7 +433,7 @@ '(opt-kwd ...))))]))))))))))) ;; should we pass both the basic-lambda and the kwd-lambda? -(define (arity-checking-wrapper val blame basic-lambda kwd-lambda +(define (arity-checking-wrapper val blame neg-party basic-lambda kwd-lambda min-method-arity max-method-arity min-arity max-arity req-kwd opt-kwd) ;; should not build this unless we are in the 'else' case (and maybe not at all) @@ -404,44 +452,45 @@ (define kwd-checker (if (and (null? req-kwd) (null? opt-kwd)) (λ (kwds kwd-args . args) - (raise-no-keywords-arg blame val kwds)) + (raise-no-keywords-arg blame #:missing-party neg-party val kwds)) (λ (kwds kwd-args . args) - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + (cons blame neg-party) (let () (define args-len (length args)) (unless (valid-number-of-args? args) (raise-wrong-number-of-args-error - blame val + blame #:missing-party neg-party val args-len max-arity min-method-arity max-method-arity)) ;; these two for loops are doing O(n^2) work that could be linear ;; (since the keyword lists are sorted) (for ([req-kwd (in-list req-kwd)]) (unless (memq req-kwd kwds) - (raise-blame-error (blame-swap blame) val + (raise-blame-error (blame-swap blame) #:missing-party neg-party + val '(expected "keyword argument ~a") req-kwd))) (for ([k (in-list kwds)]) (unless (memq k all-kwds) - (raise-blame-error (blame-swap blame) val + (raise-blame-error (blame-swap blame) #:missing-party neg-party val '(received: "unexpected keyword argument ~a") k))) (keyword-apply kwd-lambda kwds kwd-args args)))))) (define basic-checker-name (if (null? req-kwd) (λ args - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + (cons blame neg-party) (let () (unless (valid-number-of-args? args) (define args-len (length args)) (raise-wrong-number-of-args-error - blame val + blame #:missing-party neg-party val args-len max-arity min-method-arity max-method-arity)) (apply basic-lambda args)))) (λ args - (raise-blame-error (blame-swap blame) val + (raise-blame-error (blame-swap blame) #:missing-party neg-party val "expected required keyword ~a" (car req-kwd))))) (if (or (not va) (pair? vr) (pair? va)) @@ -509,15 +558,16 @@ mtd? mctc? func)) -(define ((->-proj wrapper) ctc) - (let* ([doms-proj (map contract-projection +(define ((late-neg-->-proj wrapper) ctc) + (let* ([doms-proj (map get/build-late-neg-projection (if (base->-dom-rest/c ctc) (append (base->-doms/c ctc) (list (base->-dom-rest/c ctc))) (base->-doms/c ctc)))] - [doms-optional-proj (map contract-projection (base->-optional-doms/c ctc))] - [rngs-proj (map contract-projection (base->-rngs/c ctc))] - [mandatory-kwds-proj (map contract-projection (base->-mandatory-kwds/c ctc))] - [optional-kwds-proj (map contract-projection (base->-optional-kwds/c ctc))] + [doms-optional-proj (map get/build-late-neg-projection (base->-optional-doms/c ctc))] + [rngs-ctc (base->-rngs/c ctc)] + [rngs-proj (map get/build-late-neg-projection rngs-ctc)] + [mandatory-kwds-proj (map get/build-late-neg-projection (base->-mandatory-kwds/c ctc))] + [optional-kwds-proj (map get/build-late-neg-projection (base->-optional-kwds/c ctc))] [mandatory-keywords (base->-mandatory-kwds ctc)] [optional-keywords (base->-optional-kwds ctc)] [func (base->-func ctc)] @@ -529,11 +579,10 @@ [mtd? (base->-mtd? ctc)]) (λ (orig-blame) (define rng-blame (blame-add-range-context orig-blame)) - (define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t)) (define partial-doms (for/list ([dom (in-list doms-proj)] [n (in-naturals 1)]) - (dom (blame-add-context orig-blame + (dom (blame-add-context orig-blame (if (and has-rest? (n . > . dom-length)) "the rest argument of" @@ -560,14 +609,18 @@ (kwd-proj (blame-add-context orig-blame (format "the ~a argument of" kwd) #:swap? #t)))) - (define the-args (append partial-doms partial-optional-doms - partial-mandatory-kwds partial-optional-kwds - partial-ranges)) - (λ (val) + (define the-args (cons rngs-ctc + (append partial-doms partial-optional-doms + partial-mandatory-kwds partial-optional-kwds + partial-ranges))) + (define blame-party-info (get-blame-party-info orig-blame)) + (λ (val neg-party) (if has-rest? - (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords orig-blame) - (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords orig-blame)) - (define chap/imp-func (apply func orig-blame val the-args)) + (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords + orig-blame neg-party) + (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords + orig-blame neg-party)) + (define chap/imp-func (apply func orig-blame neg-party blame-party-info val the-args)) (if post (wrapper val @@ -577,9 +630,8 @@ val chap/imp-func impersonator-prop:contracted ctc - impersonator-prop:application-mark (cons contract-key - ;; is this right? - partial-ranges))))))) + impersonator-prop:application-mark + (cons tail-contract-key (list* neg-party blame-party-info rngs-ctc)))))))) (define (->-name ctc) (single-arrow-name-maker @@ -610,16 +662,16 @@ (define (->-stronger? this that) (and (base->? that) (= (length (base->-doms/c that)) (length (base->-doms/c this))) - (andmap contract-stronger? (base->-doms/c that) (base->-doms/c this)) + (andmap contract-struct-stronger? (base->-doms/c that) (base->-doms/c this)) (equal? (base->-mandatory-kwds this) (base->-mandatory-kwds that)) - (andmap contract-stronger? (base->-mandatory-kwds/c that) (base->-mandatory-kwds/c this)) + (andmap contract-struct-stronger? (base->-mandatory-kwds/c that) (base->-mandatory-kwds/c this)) (equal? (base->-optional-kwds this) (base->-optional-kwds that)) - (andmap contract-stronger? (base->-optional-kwds/c that) (base->-optional-kwds/c this)) + (andmap contract-struct-stronger? (base->-optional-kwds/c that) (base->-optional-kwds/c this)) (= (length (base->-rngs/c that)) (length (base->-rngs/c this))) - (andmap contract-stronger? (base->-rngs/c this) (base->-rngs/c that)) + (andmap contract-struct-stronger? (base->-rngs/c this) (base->-rngs/c that)) ;; these procs might be based on state; only ;; allow stronger to be true when #:pre and @@ -632,18 +684,17 @@ (define-struct (chaperone-> base->) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:projection (->-proj chaperone-procedure) - #:name ->-name - #:first-order ->-first-order - #:stronger ->-stronger?))) + (build-chaperone-contract-property + #:late-neg-projection (late-neg-->-proj chaperone-procedure) + #:name ->-name + #:first-order ->-first-order + #:stronger ->-stronger?)) (define-struct (impersonator-> base->) () #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection (->-proj impersonate-procedure) + #:late-neg-projection (late-neg-->-proj impersonate-procedure) #:name ->-name #:first-order ->-first-order #:stronger ->-stronger?)) @@ -792,19 +843,22 @@ [(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->)) (syntax->list kwd-ctcs))] [(kwds ...) kwds] + [(rng-ctc-x) (generate-temporaries '(rng-ctc-x))] [use-any? use-any?]) (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)] [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)] [outer-lambda - #`(lambda (blame val dom-names ... kwd-names ... rng-names ...) + #`(lambda (blame neg-party blame-party-info val rng-ctc-x + dom-names ... kwd-names ... rng-names ...) #,(create-chaperone - #'blame #'val #f #f + #'blame #'neg-party #'blame-party-info #'val #f #f (syntax->list #'(this-params ...)) (syntax->list #'(dom-names ...)) null #f (map list (syntax->list #'(kwds ...)) (syntax->list #'(kwd-names ...))) null - (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))))]) + (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...))) + #'rng-ctc-x))]) (syntax-property (syntax/loc stx (build--> '-> @@ -957,6 +1011,7 @@ [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)] [(rng-proj ...) (generate-temporaries (or rng-ctc '()))] [(rng ...) (generate-temporaries (or rng-ctc '()))] + [(rng-ctc-x) (generate-temporaries '(rng-ctc-x))] [(this-parameter ...) (make-this-parameters (car (generate-temporaries '(this))))]) (quasisyntax/loc stx @@ -977,7 +1032,7 @@ #''()) #,(if rng-ctc #f #t) mtd? ->m-ctc? - (λ (blame f + (λ (blame neg-party blame-party-info f rng-ctc-x mandatory-dom-proj ... #,@(if rest-ctc #'(rest-proj) @@ -987,7 +1042,7 @@ optional-dom-kwd-proj ... rng-proj ...) #,(create-chaperone - #'blame #'f pre post + #'blame #'neg-party #'blame-party-info #'f pre post (syntax->list #'(this-parameter ...)) (syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(optional-dom-proj ...)) @@ -996,7 +1051,8 @@ (syntax->list #'(mandatory-dom-kwd-proj ...))) (map list (syntax->list #'(optional-dom-kwd ...)) (syntax->list #'(optional-dom-kwd-proj ...))) - (if rng-ctc (syntax->list #'(rng-proj ...)) #f)))))))))))])) + (if rng-ctc (syntax->list #'(rng-proj ...)) #f) + #'rng-ctc-x))))))))))])) (define (convert-pre-post/desc-to-boolean pre? b) (cond @@ -1249,7 +1305,7 @@ (syntax-local-infer-name stx) #`(λ args (apply f args)))))))))))))])) -(define ((->d-proj wrap-procedure) ->d-stct) +(define ((late-neg-->d-proj wrap-procedure) ->d-stct) (let* ([opt-count (length (base-->d-optional-dom-ctcs ->d-stct))] [mandatory-count (+ (length (base-->d-mandatory-dom-ctcs ->d-stct)) (if (base-->d-mtd? ->d-stct) 1 0))] @@ -1266,28 +1322,32 @@ [else (cons (+ mandatory-count i) (loop (+ i 1)))]))])]) (λ (blame) - (λ (val) - (if (base-->d-rest-ctc ->d-stct) - (check-procedure/more val - (base-->d-mtd? ->d-stct) - (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length - (base-->d-mandatory-keywords ->d-stct) - (base-->d-optional-keywords ->d-stct) - blame) - (check-procedure val - (base-->d-mtd? ->d-stct) - (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length - (length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length - (base-->d-mandatory-keywords ->d-stct) - (base-->d-optional-keywords ->d-stct) - blame)) - (wrap-procedure - val - (make-keyword-procedure - (λ (kwd-args kwd-arg-vals . raw-orig-args) - (with-continuation-mark - contract-continuation-mark-key blame - (let* ([orig-args (if (base-->d-mtd? ->d-stct) + (define dom-blame (blame-add-context blame "the domain of" #:swap? #t)) + (define rng-blame (blame-add-range-context blame)) + (λ (val neg-party) + (if (base-->d-rest-ctc ->d-stct) + (check-procedure/more val + (base-->d-mtd? ->d-stct) + (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length + (base-->d-mandatory-keywords ->d-stct) + (base-->d-optional-keywords ->d-stct) + blame + neg-party) + (check-procedure val + (base-->d-mtd? ->d-stct) + (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length + (length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length + (base-->d-mandatory-keywords ->d-stct) + (base-->d-optional-keywords ->d-stct) + blame + neg-party)) + (wrap-procedure + val + (make-keyword-procedure + (λ (kwd-args kwd-arg-vals . raw-orig-args) + (with-contract-continuation-mark + (cons blame neg-party) + (let* ([orig-args (if (base-->d-mtd? ->d-stct) (cdr raw-orig-args) raw-orig-args)] [this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))] @@ -1296,7 +1356,7 @@ (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) (when (base-->d-pre-cond ->d-stct) (unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args) - (raise-blame-error (blame-swap blame) + (raise-blame-error (blame-swap blame) #:missing-party neg-party val "#:pre violation~a" (build-values-string ", argument" dep-pre-args)))) @@ -1315,45 +1375,45 @@ [rng-underscore? (box? (base-->d-range ->d-stct))]) (if rng (list (λ orig-results - (with-continuation-mark - contract-continuation-mark-key blame - (let* ([range-count (length rng)] - [post-args (append orig-results raw-orig-args)] - [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] - [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count - post-args (base-->d-rest-ctc ->d-stct) - (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) - (when (base-->d-post-cond ->d-stct) - (unless (apply (base-->d-post-cond ->d-stct) dep-post-args) - (raise-blame-error blame + (with-contract-continuation-mark + (cons blame neg-party) + (let* ([range-count (length rng)] + [post-args (append orig-results raw-orig-args)] + [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] + [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count + post-args (base-->d-rest-ctc ->d-stct) + (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) + (when (base-->d-post-cond ->d-stct) + (unless (apply (base-->d-post-cond ->d-stct) dep-post-args) + (raise-blame-error blame #:missing-party neg-party + val + "#:post violation~a~a" + (build-values-string ", argument" dep-pre-args) + (build-values-string (if (null? dep-pre-args) + ", result" + "\n result") + orig-results)))) + + (unless (= range-count (length orig-results)) + (raise-blame-error blame #:missing-party neg-party val - "#:post violation~a~a" - (build-values-string ", argument" dep-pre-args) - (build-values-string (if (null? dep-pre-args) - ", result" - "\n result") - orig-results)))) - - (unless (= range-count (length orig-results)) - (raise-blame-error blame - val - "expected ~a results, got ~a" - range-count - (length orig-results))) - (apply - values - (let loop ([results orig-results] - [result-contracts rng]) - (cond - [(null? result-contracts) '()] - [else - (cons - (invoke-dep-ctc (car result-contracts) - (if rng-underscore? #f dep-post-args) - (car results) - blame - #f) - (loop (cdr results) (cdr result-contracts)))]))))))) + "expected ~a results, got ~a" + range-count + (length orig-results))) + (apply + values + (let loop ([results orig-results] + [result-contracts rng]) + (cond + [(null? result-contracts) '()] + [else + (cons + (invoke-dep-ctc (car result-contracts) + (if rng-underscore? #f dep-post-args) + (car results) + rng-blame + neg-party) + (loop (cdr results) (cdr result-contracts)))]))))))) null)) ;; contracted keyword arguments @@ -1365,9 +1425,16 @@ [(or (null? building-kwd-args) (null? all-kwds)) '()] [else (if (eq? (car all-kwds) (car building-kwd-args)) - (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) blame #t) - (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) - (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))]) + (cons (invoke-dep-ctc (car kwd-ctcs) + dep-pre-args + (car building-kwd-arg-vals) + dom-blame + neg-party) + (loop (cdr all-kwds) (cdr kwd-ctcs) + (cdr building-kwd-args) + (cdr building-kwd-arg-vals))) + (loop (cdr all-kwds) (cdr kwd-ctcs) + building-kwd-args building-kwd-arg-vals))]))]) (if (null? kwd-res) null (list kwd-res))) @@ -1383,20 +1450,24 @@ (cond [(null? args) (if (base-->d-rest-ctc ->d-stct) - (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() blame #t) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() + dom-blame neg-party) '())] [(null? non-kwd-ctcs) (if (base-->d-rest-ctc ->d-stct) - (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args blame #t) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) + dep-pre-args args dom-blame neg-party) ;; ran out of arguments, but don't have a rest parameter. ;; procedure-reduce-arity (or whatever the new thing is ;; going to be called) should ensure this doesn't happen. (error 'shouldnt\ happen))] - [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) blame #t) + [else (cons (invoke-dep-ctc (car non-kwd-ctcs) + dep-pre-args (car args) + dom-blame neg-party) (loop (cdr args) (cdr non-kwd-ctcs)))])))))))) - impersonator-prop:contracted ->d-stct))))) + impersonator-prop:contracted ->d-stct))))) (define (build-values-string desc dep-pre-args) (cond @@ -1413,15 +1484,14 @@ (loop (cdr lst)))])))])) ;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst -(define (invoke-dep-ctc dep-ctc dep-args val blame dom?) +(define (invoke-dep-ctc dep-ctc dep-args val blame neg-party) (let ([ctc (coerce-contract '->d (if dep-args (apply dep-ctc dep-args) dep-ctc))]) - (((contract-projection ctc) - (if dom? - (blame-add-context blame "the domain of" #:swap? #t) - (blame-add-range-context blame))) - val))) + (((get/build-late-neg-projection ctc) + blame) + val + neg-party))) ;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any) (define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args) @@ -1529,8 +1599,8 @@ [optional-kwds (base-->d-optional-keywords ctc)]) (λ (val) (if (base-->d-rest-ctc ctc) - (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f) - (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f))))) + (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f #f) + (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f #f))))) (define (->d-stronger? this that) (eq? this that)) ;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that @@ -1564,7 +1634,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection (->d-proj impersonate-procedure) + #:late-neg-projection (late-neg-->d-proj impersonate-procedure) #:name ->d-name #:first-order ->d-first-order #:stronger ->d-stronger?)) @@ -1637,7 +1707,8 @@ ;; check-procedure : ... (or/c #f blame) -> (or/c boolean? void?) ;; if blame is #f, then just return a boolean indicating that this matched ;; (for use in arity checking) -(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame) +(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords + blame neg-party) (define passes? (and (procedure? val) (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals) @@ -1646,7 +1717,7 @@ [blame (unless passes? (raise-blame-error - blame + blame #:missing-party neg-party val '(expected " a ~a that accepts ~a~a~a argument~a~a~a" given: "~e") (if mtd? "method" "procedure") @@ -1712,7 +1783,7 @@ ;; check-procedure/more : ... (or/c #f blame) -> (or/c boolean? void?) ;; if blame is #f, then just return a boolean indicating that this matched ;; (for use in arity checking) -(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame) +(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame neg-party) (define passes? (and (procedure? val) (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length)) @@ -1836,23 +1907,7 @@ (define-syntax (-> stx) - (syntax-case stx (any any/c boolean?) - [(_ any/c ... any) - (not (syntax-parameter-value #'making-a-method)) - ;; special case the (-> any/c ... any) contracts to be first-order checks only - (let ([dom-len (- (length (syntax->list stx)) 2)]) - #`(flat-named-contract - '(-> #,@(build-list dom-len (λ (x) 'any/c)) any) - (λ (x) - (procedure-arity-includes?/no-kwds x #,dom-len))))] - [_ - #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))])) - -(define (procedure-arity-includes?/no-kwds val dom-len) - (and (procedure? val) - (procedure-arity-includes? val dom-len) - (let-values ([(man opt) (procedure-keywords val)]) - (null? man)))) + #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))) ;; this is to make the expanded versions a little easier to read (define-syntax (values/drop stx) diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt index 446bf538a6..e2b49f0025 100644 --- a/racket/collects/racket/contract/private/base.rkt +++ b/racket/collects/racket/contract/private/base.rkt @@ -13,10 +13,7 @@ "guts.rkt" "blame.rkt" "prop.rkt" - "arrow.rkt" - "misc.rkt" - "generate.rkt" - ) + "generate.rkt") (begin-for-syntax (define lifted-key (gensym 'contract:lifted)) @@ -140,33 +137,36 @@ forced-ctc] [else current])) -(define (recursive-contract-projection ctc) +(define (recursive-contract-late-neg-projection ctc) (cond [(recursive-contract-list-contract? ctc) (λ (blame) (define r-ctc (force-recursive-contract ctc)) - (define f (contract-projection r-ctc)) + (define f (get/build-late-neg-projection r-ctc)) (define blame-known (blame-add-context blame #f)) - (λ (val) + (λ (val neg-party) (unless (list? val) - (raise-blame-error blame-known + (raise-blame-error blame-known #:missing-party neg-party val '(expected: "list?" given: "~e") val)) - ((f blame-known) val)))] + ((f blame-known) val neg-party)))] [else (λ (blame) (define r-ctc (force-recursive-contract ctc)) - (define f (contract-projection r-ctc)) + (define f (get/build-late-neg-projection r-ctc)) (define blame-known (blame-add-context blame #f)) - (λ (val) - ((f blame-known) val)))])) + (λ (val neg-party) + ((f blame-known) val neg-party)))])) (define (recursive-contract-stronger this that) (equal? this that)) (define ((recursive-contract-first-order ctc) val) - (contract-first-order-passes? (force-recursive-contract ctc) - val)) + (cond + [(contract-first-order-okay-to-give-up?) #t] + [else (contract-first-order-try-less-hard + (contract-first-order-passes? (force-recursive-contract ctc) + val))])) (define (recursive-contract-generate ctc) (λ (fuel) @@ -187,7 +187,7 @@ (build-flat-contract-property #:name recursive-contract-name #:first-order recursive-contract-first-order - #:projection recursive-contract-projection + #:late-neg-projection recursive-contract-late-neg-projection #:stronger recursive-contract-stronger #:generate recursive-contract-generate #:list-contract? recursive-contract-list-contract?)) @@ -197,7 +197,7 @@ (build-chaperone-contract-property #:name recursive-contract-name #:first-order recursive-contract-first-order - #:projection recursive-contract-projection + #:late-neg-projection recursive-contract-late-neg-projection #:stronger recursive-contract-stronger #:generate recursive-contract-generate #:list-contract? recursive-contract-list-contract?)) @@ -207,7 +207,7 @@ (build-contract-property #:name recursive-contract-name #:first-order recursive-contract-first-order - #:projection recursive-contract-projection + #:late-neg-projection recursive-contract-late-neg-projection #:stronger recursive-contract-stronger #:generate recursive-contract-generate #:list-contract? recursive-contract-list-contract?)) diff --git a/racket/collects/racket/contract/private/blame.rkt b/racket/collects/racket/contract/private/blame.rkt index 700576e1c4..da3b3b925c 100644 --- a/racket/collects/racket/contract/private/blame.rkt +++ b/racket/collects/racket/contract/private/blame.rkt @@ -18,6 +18,7 @@ blame-context blame-add-missing-party + blame-missing-party? raise-blame-error current-blame-format @@ -30,7 +31,11 @@ (equal?/recur (blame-contract a) (blame-contract b)) (equal?/recur (blame-positive a) (blame-positive b)) (equal?/recur (blame-negative a) (blame-negative b)) - (equal?/recur (blame-original? a) (blame-original? b)))) + (equal?/recur (blame-original? a) (blame-original? b)) + (equal?/recur (blame-context a) (blame-context b)) + (equal?/recur (blame-top-known? a) (blame-top-known? b)) + (equal?/recur (blame-important a) (blame-important b)) + (equal?/recur (blame-missing-party? a) (blame-missing-party? b)))) (define (blame-hash b hash/recur) (bitwise-xor (hash/recur (blame-source b)) @@ -38,10 +43,17 @@ (hash/recur (blame-contract b)) (hash/recur (blame-positive b)) (hash/recur (blame-negative b)) - (hash/recur (blame-original? b)))) + (hash/recur (blame-original? b)) + (hash/recur (blame-context b)) + (hash/recur (blame-top-known? b)) + (hash/recur (blame-important b)) + (hash/recur (blame-missing-party? b)))) +;; missing-party? field is #t when the missing party +;; is still missing and it is #f when the missing party +;; has been filled in (or if it was filled in from the start) (define-struct blame - [source value build-name positive negative original? context top-known? important] + [source value build-name positive negative original? context top-known? important missing-party?] #:property prop:equal+hash (list blame=? blame-hash blame-hash)) @@ -67,7 +79,8 @@ original? '() #t - #f))]) + #f + (not negative)))]) make-blame)) ;; s : (or/c string? #f) @@ -177,22 +190,25 @@ blame))) (define (blame-add-missing-party b missing-party) + (define (check-and-fail) + (unless (blame-missing-party? b) + (error 'blame-add-missing-party "already have the party: ~s; trying to add ~s" + (if (blame-swapped? b) (blame-positive b) (blame-negative b)) + missing-party))) (cond [(not missing-party) b] [(blame-swapped? b) - (when (blame-positive b) - (error 'add-missing-party "already have the party: ~s; trying to add ~s" - (blame-positive b) - missing-party)) + (check-and-fail) (struct-copy blame b - [positive (list missing-party)])] + [positive (or (blame-positive b) + (list missing-party))] + [missing-party? #f])] [else - (when (blame-negative b) - (error 'add-missing-party "already have the party: ~s; trying to add ~s" - (blame-negative b) - missing-party)) + (check-and-fail) (struct-copy blame b - [negative (list missing-party)])])) + [negative (or (blame-negative b) + (list missing-party))] + [missing-party? #f])])) (define (blame-fmt->-string blame fmt) (cond diff --git a/racket/collects/racket/contract/private/box.rkt b/racket/collects/racket/contract/private/box.rkt index 5f2c1a2e2b..e88d576cd1 100644 --- a/racket/collects/racket/contract/private/box.rkt +++ b/racket/collects/racket/contract/private/box.rkt @@ -3,8 +3,7 @@ (require (for-syntax racket/base) "prop.rkt" "blame.rkt" - "guts.rkt" - "misc.rkt") + "guts.rkt") (provide box-immutable/c (rename-out [wrap-box/c box/c])) @@ -100,11 +99,11 @@ (cond [(and (equal? this-immutable #t) (equal? that-immutable #t)) - (contract-stronger? this-content-r that-content-r)] + (contract-struct-stronger? this-content-r that-content-r)] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) - (and (contract-stronger? this-content-r that-content-r) - (contract-stronger? that-content-w this-content-w))] + (and (contract-struct-stronger? this-content-r that-content-r) + (contract-struct-stronger? that-content-w this-content-w))] [else #f])] [else #f])) @@ -128,32 +127,7 @@ [fail-proc (fail-proc neg-party)] [else (late-neg-proj (unbox val) neg-party) - val])))) - #:projection - (λ (ctc) - (λ (blame) - (λ (val) - (check-box/c ctc val blame) - (((contract-projection (base-box/c-content-w ctc)) blame) (unbox val)) - val))))) - -(define (ho-projection box-wrapper) - (λ (ctc) - (let ([elem-w-ctc (base-box/c-content-w ctc)] - [elem-r-ctc (base-box/c-content-r ctc)] - [immutable (base-box/c-immutable ctc)]) - (λ (blame) - (let ([pos-elem-r-proj ((contract-projection elem-r-ctc) blame)] - [neg-elem-w-proj ((contract-projection elem-w-ctc) (blame-swap blame))]) - (λ (val) - (check-box/c ctc val blame) - (if (and (immutable? val) (not (chaperone? val))) - (box-immutable (pos-elem-r-proj (unbox val))) - (box-wrapper val - (λ (b v) (pos-elem-r-proj v)) ; unbox-proc - (λ (b v) (neg-elem-w-proj v)) ; set-proc - impersonator-prop:contracted ctc - impersonator-prop:blame blame)))))))) + val])))))) (define (ho-late-neg-projection chaperone/impersonate-box) (λ (ctc) @@ -188,8 +162,7 @@ #:name box/c-name #:first-order box/c-first-order #:stronger box/c-stronger - #:late-neg-projection (ho-late-neg-projection chaperone-box) - #:projection (ho-projection chaperone-box))) + #:late-neg-projection (ho-late-neg-projection chaperone-box))) (define-struct (impersonator-box/c base-box/c) () #:property prop:custom-write custom-write-property-proc @@ -198,8 +171,7 @@ #:name box/c-name #:first-order box/c-first-order #:stronger box/c-stronger - #:late-neg-projection (ho-late-neg-projection impersonate-box) - #:projection (ho-projection impersonate-box))) + #:late-neg-projection (ho-late-neg-projection impersonate-box))) (define-syntax (wrap-box/c stx) (syntax-case stx () diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt index 1214f2d1ff..b644cf10a9 100644 --- a/racket/collects/racket/contract/private/case-arrow.rkt +++ b/racket/collects/racket/contract/private/case-arrow.rkt @@ -2,6 +2,7 @@ (require (for-syntax racket/base syntax/name) + (only-in racket/list last) racket/stxparam "guts.rkt" "blame.rkt" @@ -51,121 +52,132 @@ [_ (raise-syntax-error #f "expected ->" stx case)])) -(define-for-syntax (parse-out-case stx case n) - (let-values ([(doms rst rng) (separate-out-doms/rst/rng stx case)]) - (with-syntax ([(dom-proj-x ...) (generate-temporaries doms)] +(define-for-syntax (parse-out-case stx neg-party blame-party-info case n) + (let-values ([(dom-ctc-exprs rst-ctc-expr rng-ctc-exprs) (separate-out-doms/rst/rng stx case)]) + (with-syntax ([(dom-proj-x ...) (generate-temporaries dom-ctc-exprs)] [(rst-proj-x) (generate-temporaries '(rest-proj-x))] - [(rng-proj-x ...) (generate-temporaries (if rng rng '()))]) - (with-syntax ([(dom-formals ...) (generate-temporaries doms)] + [(rng-proj-x ...) (generate-temporaries (if rng-ctc-exprs rng-ctc-exprs '()))] + [(rng-ctcs-x) (generate-temporaries '(rng-ctc-x))]) + (with-syntax ([(dom-formals ...) (generate-temporaries dom-ctc-exprs)] [(rst-formal) (generate-temporaries '(rest-param))] - [(rng-id ...) (if rng - (generate-temporaries rng) + [(rng-id ...) (if rng-ctc-exprs + (generate-temporaries rng-ctc-exprs) '())] [(this-parameter ...) (make-this-parameters (car (generate-temporaries '(this))))]) - #`(#,doms - #,rst - #,(if rng #`(list #,@rng) #f) - #,(length (syntax->list doms)) ;; spec - (dom-proj-x ... #,@(if rst #'(rst-proj-x) #'())) + #`(#,dom-ctc-exprs + #,rst-ctc-expr + #,(if rng-ctc-exprs #`(list #,@rng-ctc-exprs) #f) + #,(length (syntax->list dom-ctc-exprs)) ;; spec + (dom-proj-x ... #,@(if rst-ctc-expr #'(rst-proj-x) #'())) (rng-proj-x ...) - (this-parameter ... dom-formals ... . #,(if rst #'rst-formal '())) + rng-ctcs-x + (this-parameter ... dom-formals ... . #,(if rst-ctc-expr #'rst-formal '())) #,(cond - [rng + [rng-ctc-exprs (let ([rng-checkers (list #`(case-lambda - [(rng-id ...) (values/drop (rng-proj-x rng-id) ...)] + [(rng-id ...) (values/drop (rng-proj-x rng-id neg-party) ...)] [args - (bad-number-of-results blame f + (bad-number-of-results blame #:missing-party neg-party f #,(length (syntax->list #'(rng-id ...))) args #,n)]))] - [rng-length (length (syntax->list rng))]) - (if rst - (check-tail-contract #'(rng-proj-x ...) rng-checkers + [rng-length (length (syntax->list rng-ctc-exprs))]) + (if rst-ctc-expr + (check-tail-contract #'rng-ctcs-x + blame-party-info neg-party + rng-checkers (λ (rng-checks) #`(apply values #,@rng-checks this-parameter ... - (dom-proj-x dom-formals) ... - (rst-proj-x rst-formal)))) - (check-tail-contract #'(rng-proj-x ...) rng-checkers - (λ (rng-checks) - #`(values/drop #,@rng-checks this-parameter ... - (dom-proj-x dom-formals) ...)))))] - [rst + (dom-proj-x dom-formals neg-party) ... + (rst-proj-x rst-formal neg-party)))) + (check-tail-contract + #'rng-ctcs-x blame-party-info neg-party rng-checkers + (λ (rng-checks) + #`(values/drop #,@rng-checks this-parameter ... + (dom-proj-x dom-formals neg-party) ...)))))] + [rst-ctc-expr #`(apply values this-parameter ... - (dom-proj-x dom-formals) ... - (rst-proj-x rst-formal))] + (dom-proj-x dom-formals neg-party) ... + (rst-proj-x rst-formal neg-party))] [else #`(values/drop this-parameter ... - (dom-proj-x dom-formals) ...)])))))) + (dom-proj-x dom-formals neg-party) ...)])))))) (define-syntax (case-> stx) (syntax-case stx () [(_ cases ...) (let () (define name (syntax-local-infer-name stx)) - (with-syntax ([(((dom-proj ...) - rst-proj - rng-proj + (with-syntax ([(((dom-ctc-expr ...) + rst-ctc-expr + rng-ctc-exprs spec (dom-proj-x ...) (rng-proj-x ...) + rng-ctcs-x formals body) ...) (for/list ([x (in-list (syntax->list #'(cases ...)))] [n (in-naturals)]) - (parse-out-case stx x n))] + (parse-out-case stx #'neg-party #'blame-party-info x n))] [mctc? (and (syntax-parameter-value #'method-contract?) #t)]) #`(syntax-parameterize ((making-a-method #f)) (build-case-> - (list (list dom-proj ...) ...) - (list rst-proj ...) - (list rng-proj ...) + (list (list dom-ctc-expr ...) ...) + (list rst-ctc-expr ...) + (list rng-ctc-exprs ...) '(spec ...) mctc? (λ (chk wrapper blame + blame-party-info ctc + rng-ctcs-x ... #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) - (λ (f) + (λ (f neg-party) (put-it-together #,(let ([case-lam (syntax/loc stx (case-lambda [formals body] ...))]) (if name #`(let ([#,name #,case-lam]) #,name) case-lam)) - (list (list rng-proj-x ...) ...) - f blame wrapper ctc + f blame neg-party blame-party-info wrapper ctc chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))])) -(define (put-it-together the-case-lam range-projections f blame wrapper ctc chk mtd?) +(define (put-it-together the-case-lam f blame neg-party blame-party-info wrapper ctc chk mtd?) (chk f mtd?) + (define rng-ctcs (base-case->-rng-ctcs ctc)) (define checker (make-keyword-procedure - (raise-no-keywords-error f blame) + (raise-no-keywords-error f blame neg-party) (λ args - (with-continuation-mark contract-continuation-mark-key blame - (apply the-case-lam args))))) - (define same-rngs (same-range-projections range-projections)) + (with-contract-continuation-mark + (cons blame neg-party) + (apply the-case-lam args))))) + (define same-rngs (same-range-contracts rng-ctcs)) (if same-rngs (wrapper f checker impersonator-prop:contracted ctc - impersonator-prop:blame blame - impersonator-prop:application-mark (cons contract-key same-rngs)) + impersonator-prop:blame (blame-add-missing-party blame neg-party) + impersonator-prop:application-mark + (cons tail-contract-key (list* neg-party blame-party-info same-rngs))) (wrapper f checker impersonator-prop:contracted ctc - impersonator-prop:blame blame))) + impersonator-prop:blame (blame-add-missing-party blame neg-party)))) -(define (raise-no-keywords-error f blame) +(define (raise-no-keywords-error f blame neg-party) (λ (kwds kwd-args . args) - (raise-blame-error blame f "expected no keywords, got keyword ~a" (car kwds)))) + (raise-blame-error blame f #:missing-party neg-party + "expected no keywords, got keyword ~a" (car kwds)))) ;; dom-ctcs : (listof (listof contract)) ;; rst-ctcs : (listof contract) @@ -180,14 +192,17 @@ (define (case->-proj wrapper) (λ (ctc) (define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc)) - (define rng-ctcs (map contract-projection - (get-case->-rng-ctcs ctc))) + (define rng-ctcs (get-case->-rng-ctcs ctc)) + (define rng-lol-ctcs (base-case->-rng-ctcs ctc)) + (define rng-late-neg-ctcs (map get/build-late-neg-projection rng-ctcs)) (define rst-ctcs (base-case->-rst-ctcs ctc)) (define specs (base-case->-specs ctc)) (λ (blame) (define dom-blame (blame-add-context blame "the domain of" #:swap? #t)) (define rng-blame (blame-add-context blame "the range of")) - (define projs (append (map (λ (f) ((cdr f) + (define blame-party-info (get-blame-party-info blame)) + (define projs (append rng-lol-ctcs + (map (λ (f) ((cdr f) (blame-add-context (blame-add-context blame @@ -205,12 +220,13 @@ (cdr target) (let* ([p (f rng-blame)] [new (lambda args - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + ;; last arg is missing party + (cons blame (last args)) (apply p args)))]) (set! memo (cons (cons f new) memo)) new)))) - rng-ctcs))) + rng-late-neg-ctcs))) (define (chk val mtd?) (cond [(null? specs) @@ -220,13 +236,14 @@ (for-each (λ (dom-length has-rest?) (if has-rest? - (check-procedure/more val mtd? dom-length '() '() blame) - (check-procedure val mtd? dom-length 0 '() '() blame))) + (check-procedure/more val mtd? dom-length '() '() blame #f) + (check-procedure val mtd? dom-length 0 '() '() blame #f))) specs rst-ctcs)])) (apply (base-case->-wrapper ctc) chk wrapper blame + blame-party-info ctc projs)))) @@ -260,7 +277,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property - #:projection (case->-proj chaperone-procedure) + #:late-neg-projection (case->-proj chaperone-procedure) #:name case->-name #:first-order case->-first-order #:stronger case->-stronger?)) @@ -269,7 +286,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection (case->-proj impersonate-procedure) + #:late-neg-projection (case->-proj impersonate-procedure) #:name case->-name #:first-order case->-first-order #:stronger case->-stronger?)) @@ -290,27 +307,32 @@ [rst (in-list (base-case->-rst-ctcs ctc))] [i (in-naturals)]) (define dom+case-nums - (map (λ (dom) (cons i (contract-projection dom))) doms)) + (map (λ (dom) (cons i (get/build-late-neg-projection dom))) doms)) (append acc (if rst (append dom+case-nums - (list (cons i (contract-projection rst)))) + (list (cons i (get/build-late-neg-projection rst)))) dom+case-nums)))) (define (get-case->-rng-ctcs ctc) (for/fold ([acc '()]) - ([x (in-list (base-case->-rng-ctcs ctc))] - #:when x) + ([x (in-list (base-case->-rng-ctcs ctc))] + #:when x) (append acc x))) ;; Takes a list of (listof projection), and returns one of the ;; lists if all the lists contain the same projections. If the list is ;; null, it returns #f. -(define (same-range-projections rng-ctcss) - (if (null? rng-ctcss) - #f - (let* ([fst (car rng-ctcss)] - [all-same? (for/and ([ps (in-list (cdr rng-ctcss))]) - (and (= (length fst) (length ps)) - (andmap procedure-closure-contents-eq? fst ps)))]) - (and all-same? fst)))) +(define (same-range-contracts rng-ctcss) + (cond + [(null? rng-ctcss) #f] + [else + (define fst (car rng-ctcss)) + (and (for/and ([ps (in-list (cdr rng-ctcss))]) + (and ps + (= (length fst) (length ps)) + (for/and ([c (in-list ps)] + [fst-c (in-list fst)]) + (and (contract-struct-stronger? c fst-c) + (contract-struct-stronger? fst-c c))))) + fst)])) diff --git a/racket/collects/racket/contract/private/ds.rkt b/racket/collects/racket/contract/private/ds.rkt index 246fd1de5f..8dc55bf60b 100644 --- a/racket/collects/racket/contract/private/ds.rkt +++ b/racket/collects/racket/contract/private/ds.rkt @@ -20,8 +20,7 @@ it around flattened out. (require "guts.rkt" "prop.rkt" "blame.rkt" - "opt.rkt" - "misc.rkt") + "opt.rkt") (require (for-syntax racket/base) (for-syntax "ds-helpers.rkt") (for-syntax "helpers.rkt") @@ -236,7 +235,7 @@ it around flattened out. [b-sel (contract-get b selector-indices)]) (if (contract-struct? a-sel) (if (contract-struct? b-sel) - (contract-stronger? a-sel b-sel) + (contract-struct-stronger? a-sel b-sel) #f) (if (contract-struct? b-sel) #f @@ -276,8 +275,8 @@ it around flattened out. (let ([old-contract/info (wrap-get val 1)]) (if (and (equal? (contract/info-blame new-contract/info) (contract/info-blame old-contract/info)) - (contract-stronger? (contract/info-contract old-contract/info) - (contract/info-contract new-contract/info))) + (contract-struct-stronger? (contract/info-contract old-contract/info) + (contract/info-contract new-contract/info))) #t (already-there? new-contract/info (wrap-get val 0) (- depth 1)))))] [else diff --git a/racket/collects/racket/contract/private/exists.rkt b/racket/collects/racket/contract/private/exists.rkt index f5161c4dd0..8fbfda0f6a 100644 --- a/racket/collects/racket/contract/private/exists.rkt +++ b/racket/collects/racket/contract/private/exists.rkt @@ -11,19 +11,21 @@ [_new-∀/c new-∀/c]) ∀∃?) -(define (∀∃-proj ctc) - (let ([in (∀∃/c-in ctc)] - [out (∀∃/c-out ctc)] - [pred? (∀∃/c-pred? ctc)] - [neg? (∀∃/c-neg? ctc)]) - (define name (∀∃/c-name ctc)) - (λ (blame) - (if (equal? neg? (blame-swapped? blame)) - (λ (val) - (if (pred? val) - (out val) - (raise-blame-error blame val "not ~a: ~e" name val))) - in)))) +(define (∀∃-late-neg-proj ctc) + (define in (∀∃/c-in ctc)) + (define (inj v neg-party) (in v)) + (define out (∀∃/c-out ctc)) + (define pred? (∀∃/c-pred? ctc)) + (define neg? (∀∃/c-neg? ctc)) + (define name (∀∃/c-name ctc)) + (λ (blame) + (if (equal? neg? (blame-swapped? blame)) + (λ (val neg-party) + (if (pred? val) + (out val) + (raise-blame-error blame val #:missing-party neg-party + "not ~a: ~e" name val))) + inj))) (define-struct ∀∃/c (in out pred? name neg?) #:omit-define-syntaxes @@ -32,7 +34,7 @@ (build-contract-property #:name (λ (ctc) (∀∃/c-name ctc)) #:first-order (λ (ctc) (λ (x) #t)) ;; ??? - #:projection ∀∃-proj + #:late-neg-projection ∀∃-late-neg-proj #:stronger (λ (this that) (equal? this that)) #:generate (λ (ctc) (cond diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index 417b8a7cf6..d166a9d838 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -38,6 +38,7 @@ ;; helpers for adding properties that check syntax uses define/final-prop define/subexpression-pos-prop + define/subexpression-pos-prop/name make-predicate-contract @@ -47,22 +48,79 @@ equal-contract-val char-in/c + contract? + chaperone-contract? + impersonator-contract? + flat-contract? + contract-continuation-mark-key + with-contract-continuation-mark (struct-out wrapped-extra-arg-arrow) contract-custom-write-property-proc (rename-out [contract-custom-write-property-proc custom-write-property-proc]) - - set-some-basic-contracts!) -(define (contract-custom-write-property-proc stct port display?) - (write-string "#<" port) + contract-projection + contract-val-first-projection ;; might return #f (if none) + contract-late-neg-projection ;; might return #f (if none) + get/build-val-first-projection ;; builds one if necc., using contract-projection + get/build-late-neg-projection + warn-about-val-first? + + contract-name + maybe-warn-about-val-first + + set-some-basic-contracts! + + contract-first-order-okay-to-give-up? + contract-first-order-try-less-hard + contract-first-order-only-try-so-hard + + raise-predicate-blame-error-failure) + +(define (contract-custom-write-property-proc stct port mode) + (define (write-prefix) + (write-string "#<" port) + (cond + [(flat-contract-struct? stct) (write-string "flat-" port)] + [(chaperone-contract-struct? stct) (write-string "chaperone-" port)]) + (write-string "contract: " port)) + (define (write-suffix) + (write-string ">" port)) (cond - [(flat-contract-struct? stct) (write-string "flat-" port)] - [(chaperone-contract-struct? stct) (write-string "chaperone-" port)]) - (write-string "contract: " port) - (write-string (format "~.s" (contract-struct-name stct)) port) - (write-string ">" port)) + [(boolean? mode) + (write-prefix) + (write-string (format "~.s" (contract-struct-name stct)) port) + (write-suffix)] + [else + (cond + [(zero? mode) + (print (contract-struct-name stct) port 1)] + [else + (write-prefix) + (print (contract-struct-name stct) port 1) + (write-suffix)])])) + +(define (contract? x) (and (coerce-contract/f x) #t)) + +(define (flat-contract? x) + (let ([c (coerce-contract/f x)]) + (and c + (flat-contract-struct? c)))) + +(define (chaperone-contract? x) + (let ([c (coerce-contract/f x)]) + (and c + (or (chaperone-contract-struct? c) + (and (prop:opt-chaperone-contract? c) + ((prop:opt-chaperone-contract-get-test c) c)))))) + +(define (impersonator-contract? x) + (let ([c (coerce-contract/f x)]) + (and c + (not (flat-contract-struct? c)) + (not (chaperone-contract-struct? c))))) + (define (has-contract? v) (or (has-prop:contracted? v) @@ -81,11 +139,17 @@ (has-impersonator-prop:blame? v))) (define (value-blame v) + (define bv + (cond + [(has-prop:blame? v) + (get-prop:blame v)] + [(has-impersonator-prop:blame? v) + (get-impersonator-prop:blame v)] + [else #f])) (cond - [(has-prop:blame? v) - (get-prop:blame v)] - [(has-impersonator-prop:blame? v) - (get-impersonator-prop:blame v)] + [(and (pair? bv) (blame? (car bv))) + (blame-add-missing-party (car bv) (cdr bv))] + [(blame? bv) bv] [else #f])) (define-values (prop:contracted has-prop:contracted? get-prop:contracted) @@ -244,6 +308,7 @@ #f (memq x the-known-good-contracts))])] [(null? x) list/c-empty] + [(not x) false/c-contract] [(or (symbol? x) (boolean? x) (keyword? x)) (make-eq-contract x (if (name-default? name) @@ -318,6 +383,42 @@ (list (car (syntax-e stx))) '())))])))))])) +(define-syntax (define/subexpression-pos-prop/name stx) + (syntax-case stx () + [(_ ctc/proc header bodies ...) + (with-syntax ([ctc (if (identifier? #'header) + #'header + (car (syntax-e #'header)))]) + #'(begin + (define ctc/proc + (let () + (define header bodies ...) + ctc)) + (define-syntax (ctc stx) + (syntax-case stx () + [x + (identifier? #'x) + (syntax-property + #'ctc/proc + 'racket/contract:contract + (vector (gensym 'ctc) + (list stx) + '()))] + [(_ margs (... ...)) + (let ([this-one (gensym 'ctc)]) + (with-syntax ([(margs (... ...)) + (map (λ (x) (syntax-property x + 'racket/contract:positive-position + this-one)) + (syntax->list #'(margs (... ...))))] + [app (datum->syntax stx '#%app)]) + (syntax-property + #'(app ctc/proc margs (... ...)) + 'racket/contract:contract + (vector this-one + (list (car (syntax-e stx))) + '()))))]))))])) + (define-syntax (define/subexpression-pos-prop stx) (syntax-case stx () [(_ header bodies ...) @@ -325,35 +426,7 @@ #'header (car (syntax-e #'header)))]) (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))]) - #'(begin - (define ctc/proc - (let () - (define header bodies ...) - ctc)) - (define-syntax (ctc stx) - (syntax-case stx () - [x - (identifier? #'x) - (syntax-property - #'ctc/proc - 'racket/contract:contract - (vector (gensym 'ctc) - (list stx) - '()))] - [(_ margs (... ...)) - (let ([this-one (gensym 'ctc)]) - (with-syntax ([(margs (... ...)) - (map (λ (x) (syntax-property x - 'racket/contract:positive-position - this-one)) - (syntax->list #'(margs (... ...))))] - [app (datum->syntax stx '#%app)]) - (syntax-property - #'(app ctc/proc margs (... ...)) - 'racket/contract:contract - (vector this-one - (list (car (syntax-e stx))) - '()))))])))))])) + #'(define/subexpression-pos-prop/name ctc/proc header bodies ...)))])) ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) (define (build-compound-type-name . fs) @@ -411,6 +484,8 @@ ((predicate-contract-pred that) this-val)))) #:list-contract? (λ (c) (null? (eq-contract-val c))))) +(define false/c-contract (make-eq-contract #f #f)) + (define-struct equal-contract (val name) #:property prop:custom-write contract-custom-write-property-proc #:property prop:flat-contract @@ -549,13 +624,11 @@ (define p? (predicate-contract-pred ctc)) (define name (predicate-contract-name ctc)) (λ (blame) - (λ (v neg-party) - (if (p? v) - v - (raise-blame-error blame v #:missing-party neg-party - '(expected: "~s" given: "~e") - name - v))))) + (procedure-specialize + (λ (v neg-party) + (if (p? v) + v + (raise-predicate-blame-error-failure blame v neg-party name)))))) #:generate (λ (ctc) (let ([generate (predicate-contract-generate ctc)]) (cond @@ -570,13 +643,140 @@ #:list-contract? (λ (ctc) (or (equal? (predicate-contract-pred ctc) null?) (equal? (predicate-contract-pred ctc) empty?))))) +(define (raise-predicate-blame-error-failure blame v neg-party predicate-name) + (raise-blame-error blame v #:missing-party neg-party + '(expected: "~s" given: "~e") + predicate-name + v)) + (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) (define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (build-flat-contract name pred [generate #f]) (make-predicate-contract name pred generate #f)) + +(define (contract-name ctc) + (contract-struct-name + (coerce-contract 'contract-name ctc))) + +(define (contract-projection ctc) + (get/build-projection + (coerce-contract 'contract-projection ctc))) +(define (contract-val-first-projection ctc) + (get/build-val-first-projection + (coerce-contract 'contract-projection ctc))) +(define (contract-late-neg-projection ctc) + (get/build-late-neg-projection + (coerce-contract 'contract-projection ctc))) + +(define-logger racket/contract) + +(define (get/build-late-neg-projection ctc) + (cond + [(contract-struct-late-neg-projection ctc) => values] + [else + (log-racket/contract-warning "no late-neg-projection for ~s" ctc) + (cond + [(contract-struct-projection ctc) + => + (λ (projection) + (projection->late-neg-projection projection))] + [(contract-struct-val-first-projection ctc) + => + (λ (val-first-projection) + (val-first-projection->late-neg-projection val-first-projection))] + [else + (first-order->late-neg-projection (contract-struct-first-order ctc) + (contract-struct-name ctc))])])) + +(define (projection->late-neg-projection proj) + (λ (b) + (λ (x neg-party) + ((proj (blame-add-missing-party b neg-party)) x)))) +(define (val-first-projection->late-neg-projection vf-proj) + (λ (b) + (define vf-val-accepter (vf-proj b)) + (λ (x neg-party) + ((vf-val-accepter x) neg-party)))) +(define (first-order->late-neg-projection p? name) + (λ (b) + (λ (x neg-party) + (if (p? x) + x + (raise-blame-error + b x #:missing-party neg-party + '(expected: "~a" given: "~e") + name + x))))) + +(define warn-about-val-first? (make-parameter #t)) +(define (maybe-warn-about-val-first ctc) + (when (warn-about-val-first?) + (log-racket/contract-warning + "building val-first-projection of contract ~s for~a" + ctc + (build-context)))) + +(define (get/build-val-first-projection ctc) + (cond + [(contract-struct-val-first-projection ctc) => values] + [else + (maybe-warn-about-val-first ctc) + (late-neg-projection->val-first-projection + (get/build-late-neg-projection ctc))])) +(define (late-neg-projection->val-first-projection lnp) + (λ (b) + (define val+neg-party-accepter (lnp b)) + (λ (x) + (λ (neg-party) + (val+neg-party-accepter x neg-party))))) + +(define (get/build-projection ctc) + (cond + [(contract-struct-projection ctc) => values] + [else + (log-racket/contract-warning + "building projection of contract ~s for~a" + ctc + (build-context)) + (late-neg-projection->projection + (get/build-late-neg-projection ctc))])) +(define (late-neg-projection->projection lnp) + (λ (b) + (define val+np-acceptor (lnp b)) + (λ (x) + (val+np-acceptor x #f)))) + + +(define contract-first-order-okay-to-give-up-key (gensym 'contract-first-order-okay-to-give-up-key)) +(define (contract-first-order-okay-to-give-up?) + (zero? (continuation-mark-set-first #f + contract-first-order-okay-to-give-up-key + 1))) +(define-syntax-rule + (contract-first-order-try-less-hard e) + (contract-first-order-try-less-hard/proc (λ () e))) +(define (contract-first-order-try-less-hard/proc th) + (define cv (continuation-mark-set-first #f contract-first-order-okay-to-give-up-key)) + (if cv + (with-continuation-mark contract-first-order-okay-to-give-up-key (if (= cv 0) 0 (- cv 1)) + (th)) + (th))) +(define-syntax-rule + (contract-first-order-only-try-so-hard n e) + (with-continuation-mark contract-first-order-okay-to-give-up-key n e)) + ;; Key used by the continuation mark that holds blame information for the current contract. ;; That information is consumed by the contract profiler. (define contract-continuation-mark-key (make-continuation-mark-key 'contract)) + +(define-syntax-rule (with-contract-continuation-mark payload code) + (begin + ;; ;; When debugging a missing blame party error, turn this on, then run + ;; ;; the contract test suite. It should find the problematic combinator. + ;; (unless (or (pair? payload) (not (blame-missing-party? payload))) + ;; (error "internal error: missing blame party" payload)) + (with-continuation-mark contract-continuation-mark-key payload code))) + diff --git a/racket/collects/racket/contract/private/hash.rkt b/racket/collects/racket/contract/private/hash.rkt index b5f9005c8e..712d735975 100644 --- a/racket/collects/racket/contract/private/hash.rkt +++ b/racket/collects/racket/contract/private/hash.rkt @@ -4,8 +4,7 @@ syntax/location "guts.rkt" "blame.rkt" - "prop.rkt" - "misc.rkt") + "prop.rkt") (provide (rename-out [wrap-hash/c hash/c]) hash/dc) @@ -169,14 +168,14 @@ (cond [(and (equal? this-immutable #t) (equal? that-immutable #t)) - (and (contract-stronger? this-dom that-dom) - (contract-stronger? this-rng that-rng))] + (and (contract-struct-stronger? this-dom that-dom) + (contract-struct-stronger? this-rng that-rng))] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) - (and (contract-stronger? this-dom that-dom) - (contract-stronger? that-dom this-dom) - (contract-stronger? this-rng that-rng) - (contract-stronger? that-rng this-rng))] + (and (contract-struct-stronger? this-dom that-dom) + (contract-struct-stronger? that-dom this-dom) + (contract-struct-stronger? this-rng that-rng) + (contract-struct-stronger? that-rng this-rng))] [else #f])] [else #f])) @@ -194,9 +193,9 @@ (define immutable (base-hash/c-immutable ctc)) (define flat? (flat-hash/c? ctc)) (λ (blame) - (define dom-proj ((contract-projection (base-hash/c-dom ctc)) + (define dom-proj ((get/build-late-neg-projection (base-hash/c-dom ctc)) (blame-add-key-context blame #f))) - (define rng-proj ((contract-projection (base-hash/c-rng ctc)) + (define rng-proj ((get/build-late-neg-projection (base-hash/c-rng ctc)) (blame-add-value-context blame #f))) (λ (val neg-party) (cond @@ -204,8 +203,8 @@ val] [else (for ([(k v) (in-hash val)]) - (dom-proj k) - (rng-proj v)) + (dom-proj k neg-party) + (rng-proj v neg-party)) val])))))) (define (ho-projection chaperone-or-impersonate-hash) diff --git a/racket/collects/racket/contract/private/legacy.rkt b/racket/collects/racket/contract/private/legacy.rkt index 4ebdb5b4d3..2b7817f6ca 100644 --- a/racket/collects/racket/contract/private/legacy.rkt +++ b/racket/collects/racket/contract/private/legacy.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "blame.rkt" "prop.rkt" "misc.rkt" syntax/srcloc) +(require "blame.rkt" "prop.rkt" "guts.rkt" syntax/srcloc) (provide make-proj-contract raise-contract-error diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 7477a0e1aa..75cc3c9265 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -43,21 +43,10 @@ channel/c evt/c - chaperone-contract? - impersonator-contract? - flat-contract? - contract? - flat-contract flat-contract-predicate flat-named-contract - contract-projection - contract-val-first-projection ;; might return #f (if none) - contract-late-neg-projection ;; might return #f (if none) - get/build-val-first-projection ;; builds one if necc., using contract-projection - get/build-late-neg-projection - contract-name n->th blame-add-car-context @@ -67,7 +56,9 @@ random-any/c rename-contract - if/c) + if/c + + pairwise-stronger-contracts?) (define-syntax (flat-murec-contract stx) (syntax-case stx () @@ -107,17 +98,6 @@ (let ([tests (map contract-first-order (base-and/c-ctcs ctc))]) (λ (x) (for/and ([test (in-list tests)]) (test x))))) -(define (and-proj ctc) - (let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))]) - (lambda (blame) - (define projs - (for/list ([c (in-list mk-pos-projs)] - [n (in-naturals 1)]) - (c (blame-add-context blame (format "the ~a conjunct of" (n->th n)))))) - (for/fold ([proj (car projs)]) - ([p (in-list (cdr projs))]) - (λ (v) (p (proj v))))))) - (define (late-neg-and-proj ctc) (define mk-pos-projs (map get/build-late-neg-projection (base-and/c-ctcs ctc))) (λ (blame) @@ -134,22 +114,6 @@ (loop (cdr projs) ((car projs) val neg-party))]))))) -(define (first-order-and-proj ctc) - (λ (blame) - (λ (val) - (let loop ([predicates (first-order-and/c-predicates ctc)] - [ctcs (base-and/c-ctcs ctc)]) - (cond - [(null? predicates) val] - [else - (cond - [((car predicates) val) - (loop (cdr predicates) (cdr ctcs))] - [else - (define ctc1-proj (contract-projection (car ctcs))) - (define new-blame (blame-add-context blame "an and/c case of")) - ((ctc1-proj new-blame) val)])]))))) - (define (first-order-late-neg-and-proj ctc) (define predicates (first-order-and/c-predicates ctc)) (define blame-accepters (map get/build-late-neg-projection (base-and/c-ctcs ctc))) @@ -170,12 +134,8 @@ (define (and-stronger? this that) (and (base-and/c? that) - (let ([this-ctcs (base-and/c-ctcs this)] - [that-ctcs (base-and/c-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs))))) + (pairwise-stronger-contracts? (base-and/c-ctcs this) + (base-and/c-ctcs that)))) (define (and/c-generate? ctc) (cond @@ -244,21 +204,22 @@ (define (and/c-check-nonneg ctc pred) (define sub-contracts (base-and/c-ctcs ctc)) (cond - [(are-stronger-contracts? (list pred (not/c negative?)) - sub-contracts) + [(pairwise-stronger-contracts? + (list (coerce-contract 'and/c-check-nonneg pred) (not/c negative?)) + sub-contracts) (define go (hash-ref predicate-generator-table pred)) (λ (fuel) (λ () (abs (go fuel))))] [else #f])) -(define (are-stronger-contracts? c1s c2s) +(define (pairwise-stronger-contracts? c1s c2s) (let loop ([c1s c1s] [c2s c2s]) (cond [(and (null? c1s) (null? c2s)) #t] [(and (pair? c1s) (pair? c2s)) - (and (contract-stronger? (car c1s) (car c2s)) + (and (contract-struct-stronger? (car c1s) (car c2s)) (loop (cdr c1s) (cdr c2s)))] [else #f]))) @@ -267,7 +228,6 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property - #:projection first-order-and-proj #:late-neg-projection first-order-late-neg-and-proj #:name and-name #:first-order and-first-order @@ -276,19 +236,16 @@ (define-struct (chaperone-and/c base-and/c) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:projection and-proj - #:late-neg-projection late-neg-and-proj - #:name and-name - #:first-order and-first-order - #:stronger and-stronger? - #:generate and/c-generate?))) + (build-chaperone-contract-property + #:late-neg-projection late-neg-and-proj + #:name and-name + #:first-order and-first-order + #:stronger and-stronger? + #:generate and/c-generate?)) (define-struct (impersonator-and/c base-and/c) () #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection and-proj #:late-neg-projection late-neg-and-proj #:name and-name #:first-order and-first-order @@ -307,7 +264,7 @@ (identifier? #'x) #'real-and/c])) -(define/subexpression-pos-prop (real-and/c . raw-fs) +(define/subexpression-pos-prop/name real-and/c-name (real-and/c . raw-fs) (let ([contracts (coerce-contracts 'and/c raw-fs)]) (cond [(null? contracts) any/c] @@ -449,20 +406,21 @@ (build-flat-contract-property #:name (λ (c) `(,name ,(-ctc-x c))) #:first-order (λ (ctc) (define x (-ctc-x ctc)) (λ (y) (and (real? y) ( y x)))) - #:projection (λ (ctc) - (define x (-ctc-x ctc)) - (λ (blame) - (λ (val) - (if (and (real? val) ( val x)) - val - (raise-blame-error - blame val - '(expected: - "a number strictly ~a than ~v" - given: "~v") - less/greater - x - val))))) + #:late-neg-projection + (λ (ctc) + (define x (-ctc-x ctc)) + (λ (blame) + (λ (val neg-party) + (if (and (real? val) ( val x)) + val + (raise-blame-error + blame val #:missing-party neg-party + '(expected: + "a number strictly ~a than ~v" + given: "~v") + less/greater + x + val))))) #:generate (λ (ctc) (define x (-ctc-x ctc)) @@ -617,20 +575,20 @@ [(pe-listof-ctc? this) (pe-listof-ctc? that)] [(im-listof-ctc? this) (im-listof-ctc? that)] [else #t]) - (contract-stronger? this-elem that-elem))] + (contract-struct-stronger? this-elem that-elem))] [(the-cons/c? that) (define hd-ctc (the-cons/c-hd-ctc that)) (define tl-ctc (the-cons/c-tl-ctc that)) (and (ne-listof-ctc? this) - (contract-stronger? this-elem hd-ctc) - (contract-stronger? (ne->pe-ctc this) tl-ctc))] + (contract-struct-stronger? this-elem hd-ctc) + (contract-struct-stronger? (ne->pe-ctc this) tl-ctc))] [else #f])) (define (raise-listof-blame-error blame val empty-ok? neg-party) (raise-blame-error blame #:missing-party neg-party val '(expected: "~s" given: "~e") (if empty-ok? - "list?" + 'list? (format "~s" `(and/c list? pair?))) val)) @@ -671,47 +629,6 @@ [else (elem-fo? v)])))])) -(define (listof-projection ctc) - (define elem-proj (contract-projection (listof-ctc-elem-c ctc))) - (define pred? (if (pe-listof-ctc? ctc) - list? - non-empty-list?)) - (λ (blame) - (define elem-proj+blame (elem-proj (blame-add-listof-context blame))) - (cond - [(flat-listof-ctc? ctc) - (if (im-listof-ctc? ctc) - (λ (val) - (let loop ([val val]) - (cond - [(pair? val) - (elem-proj+blame (car val)) - (loop (cdr val))] - [else - (elem-proj+blame val)])) - val) - (λ (val) - (if (pred? val) - (begin - (for ([x (in-list val)]) - (elem-proj+blame x)) - val) - (raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f))))] - [else - (if (im-listof-ctc? ctc) - (λ (val) - (let loop ([val val]) - (cond - [(pair? val) - (cons (elem-proj+blame (car val)) - (loop (cdr val)))] - [else (elem-proj+blame val)]))) - (λ (val) - (if (pred? val) - (for/list ([x (in-list val)]) - (elem-proj+blame x)) - (raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f))))]))) - (define (listof-late-neg-projection ctc) (define elem-proj (get/build-late-neg-projection (listof-ctc-elem-c ctc))) (define pred? (if (pe-listof-ctc? ctc) @@ -759,7 +676,6 @@ (build-flat-contract-property #:name list-name #:first-order list-fo-check - #:projection listof-projection #:late-neg-projection listof-late-neg-projection #:generate listof-generate #:exercise listof-exercise @@ -769,7 +685,6 @@ (build-chaperone-contract-property #:name list-name #:first-order list-fo-check - #:projection listof-projection #:late-neg-projection listof-late-neg-projection #:generate listof-generate #:exercise listof-exercise @@ -779,7 +694,6 @@ (build-contract-property #:name list-name #:first-order list-fo-check - #:projection listof-projection #:late-neg-projection listof-late-neg-projection #:generate listof-generate #:exercise listof-exercise @@ -874,7 +788,6 @@ (define (blame-add-car-context blame) (blame-add-context blame "the car of")) (define (blame-add-cdr-context blame) (blame-add-context blame "the cdr of")) - (define ((cons/c-late-neg-ho-check combine) ctc) (define ctc-car (the-cons/c-hd-ctc ctc)) (define ctc-cdr (the-cons/c-tl-ctc ctc)) @@ -890,19 +803,6 @@ (car-p (car v) neg-party) (cdr-p (cdr v) neg-party))))) -(define ((cons/c-ho-check combine) ctc) - (define ctc-car (the-cons/c-hd-ctc ctc)) - (define ctc-cdr (the-cons/c-tl-ctc ctc)) - (define car-proj (contract-projection ctc-car)) - (define cdr-proj (contract-projection ctc-cdr)) - (λ (blame) - (let ([car-p (car-proj (blame-add-car-context blame))] - [cdr-p (cdr-proj (blame-add-cdr-context blame))]) - (λ (v) - (unless (pair? v) - (raise-not-cons-blame-error blame v)) - (combine v (car-p (car v)) (cdr-p (cdr v))))))) - (define (cons/c-first-order ctc) (define ctc-car (the-cons/c-hd-ctc ctc)) (define ctc-cdr (the-cons/c-tl-ctc ctc)) @@ -927,16 +827,16 @@ [(the-cons/c? that) (define that-hd (the-cons/c-hd-ctc that)) (define that-tl (the-cons/c-tl-ctc that)) - (and (contract-stronger? this-hd that-hd) - (contract-stronger? this-tl that-tl))] + (and (contract-struct-stronger? this-hd that-hd) + (contract-struct-stronger? this-tl that-tl))] [(ne-listof-ctc? that) (define elem-ctc (listof-ctc-elem-c that)) - (and (contract-stronger? this-hd elem-ctc) - (contract-stronger? this-tl (ne->pe-ctc that)))] + (and (contract-struct-stronger? this-hd elem-ctc) + (contract-struct-stronger? this-tl (ne->pe-ctc that)))] [(pe-listof-ctc? that) (define elem-ctc (listof-ctc-elem-c that)) - (and (contract-stronger? this-hd elem-ctc) - (contract-stronger? this-tl that))] + (and (contract-struct-stronger? this-hd elem-ctc) + (contract-struct-stronger? this-tl that))] [else #f])) @@ -959,7 +859,6 @@ #:property prop:flat-contract (build-flat-contract-property #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) v)) - #:projection (cons/c-ho-check (λ (v a d) v)) #:name cons/c-name #:first-order cons/c-first-order #:stronger cons/c-stronger? @@ -968,21 +867,18 @@ (define-struct (chaperone-cons/c the-cons/c) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d))) - #:projection (cons/c-ho-check (λ (v a d) (cons a d))) - #:name cons/c-name - #:first-order cons/c-first-order - #:stronger cons/c-stronger? - #:generate cons/c-generate - #:list-contract? cons/c-list-contract?))) + (build-chaperone-contract-property + #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d))) + #:name cons/c-name + #:first-order cons/c-first-order + #:stronger cons/c-stronger? + #:generate cons/c-generate + #:list-contract? cons/c-list-contract?)) (define-struct (impersonator-cons/c the-cons/c) () #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d))) - #:projection (cons/c-ho-check (λ (v a d) (cons a d))) #:name cons/c-name #:first-order cons/c-first-order #:stronger cons/c-stronger? @@ -1212,18 +1108,15 @@ (define (list/c-stronger this that) (cond [(generic-list/c? that) - (and (= (length (generic-list/c-args this)) - (length (generic-list/c-args that))) - (for/and ([this-s (in-list (generic-list/c-args this))] - [that-s (in-list (generic-list/c-args this))]) - (contract-stronger? this-s that-s)))] + (pairwise-stronger-contracts? (generic-list/c-args this) + (generic-list/c-args that))] [(listof-ctc? that) (define that-elem-ctc (listof-ctc-elem-c that)) (define this-elem-ctcs (generic-list/c-args this)) (and (or (pair? this-elem-ctcs) (pe-listof-ctc? that)) (for/and ([this-s (in-list this-elem-ctcs)]) - (contract-stronger? this-s that-elem-ctc)))] + (contract-struct-stronger? this-s that-elem-ctc)))] [else #f])) (struct generic-list/c (args)) @@ -1265,38 +1158,8 @@ val '(expected "a list" given: "~e") val)])))) - #:projection - (lambda (c) - (lambda (blame) - (lambda (x) - (unless (list? x) - (raise-blame-error blame x '(expected "a list" given: "~e") x)) - (let* ([args (generic-list/c-args c)] - [expected (length args)] - [actual (length x)]) - (expected-a-list-of-len x actual expected blame) - (for ([arg/c (in-list args)] [v (in-list x)] [i (in-naturals 1)]) - (((contract-projection arg/c) - (add-list-context blame i)) - v)) - x)))) #:list-contract? (λ (c) #t))) -(define (list/c-chaperone/other-projection c) - (define args (map contract-projection (generic-list/c-args c))) - (define expected (length args)) - (λ (blame) - (define projs (for/list ([arg/c (in-list args)] - [i (in-naturals 1)]) - (arg/c (add-list-context blame i)))) - (λ (x) - (unless (list? x) (expected-a-list x blame)) - (define actual (length x)) - (expected-a-list-of-len x actual expected blame #:missing-party #f) - (for/list ([item (in-list x)] - [proj (in-list projs)]) - (proj item))))) - (define (expected-a-list x blame #:missing-party [missing-party #f]) (raise-blame-error blame #:missing-party missing-party x '(expected: "a list" given: "~e") x)) @@ -1355,16 +1218,14 @@ (struct chaperone-list/c generic-list/c () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:name list/c-name-proc - #:first-order list/c-first-order - #:generate list/c-generate - #:exercise list/c-exercise - #:stronger list/c-stronger - #:projection list/c-chaperone/other-projection - #:late-neg-projection list/c-chaperone/other-late-neg-projection - #:list-contract? (λ (c) #t)))) + (build-chaperone-contract-property + #:name list/c-name-proc + #:first-order list/c-first-order + #:generate list/c-generate + #:exercise list/c-exercise + #:stronger list/c-stronger + #:late-neg-projection list/c-chaperone/other-late-neg-projection + #:list-contract? (λ (c) #t))) (struct higher-order-list/c generic-list/c () #:property prop:custom-write custom-write-property-proc @@ -1375,7 +1236,6 @@ #:generate list/c-generate #:exercise list/c-exercise #:stronger list/c-stronger - #:projection list/c-chaperone/other-projection #:late-neg-projection list/c-chaperone/other-late-neg-projection #:list-contract? (λ (c) #t))) @@ -1386,8 +1246,8 @@ #:name (λ (ctc) (build-compound-type-name 'syntax/c (syntax-ctc-ctc ctc))) #:stronger (λ (this that) (and (syntax-ctc? that) - (contract-stronger? (syntax-ctc-ctc this) - (syntax-ctc-ctc that)))) + (contract-struct-stronger? (syntax-ctc-ctc this) + (syntax-ctc-ctc that)))) #:first-order (λ (ctc) (define ? (flat-contract-predicate (syntax-ctc-ctc ctc))) (λ (v) @@ -1435,8 +1295,8 @@ (define (promise-ctc-stronger? this that) (and (promise-base-ctc? that) - (contract-stronger? (promise-base-ctc-ctc this) - (promise-base-ctc-ctc that)))) + (contract-struct-stronger? (promise-base-ctc-ctc this) + (promise-base-ctc-ctc that)))) (struct promise-base-ctc (ctc)) (struct chaperone-promise-ctc promise-base-ctc () @@ -1476,28 +1336,6 @@ #:omit-define-syntaxes #:property prop:contract (build-contract-property - #:projection - (λ (ctc) - (let* ([in-proc (contract-projection (parameter/c-in ctc))] - [out-proc (contract-projection (parameter/c-out ctc))]) - (λ (blame) - (define blame/c (blame-add-context blame "the parameter of")) - (define (add-profiling f) - (λ (x) - (with-continuation-mark contract-continuation-mark-key - (cons blame #f) - (f x)))) - (define partial-neg-contract (add-profiling (in-proc (blame-swap blame/c)))) - (define partial-pos-contract (add-profiling (out-proc blame/c))) - (λ (val) - (cond - [(parameter? val) - (make-derived-parameter - val - partial-neg-contract - partial-pos-contract)] - [else - (raise-blame-error blame val '(expected "a parameter"))]))))) #:late-neg-projection (λ (ctc) (define in-proc (get/build-late-neg-projection (parameter/c-in ctc))) @@ -1511,9 +1349,9 @@ [(parameter? val) (define (add-profiling f) (λ (x) - (with-continuation-mark contract-continuation-mark-key - (cons blame/c neg-party) - (f x neg-party)))) + (with-contract-continuation-mark + (cons blame/c neg-party) + (f x neg-party)))) (make-derived-parameter val (add-profiling in-proj) @@ -1538,10 +1376,10 @@ #:stronger (λ (this that) (and (parameter/c? that) - (and (contract-stronger? (parameter/c-out this) - (parameter/c-out that)) - (contract-stronger? (parameter/c-in that) - (parameter/c-in this))))))) + (and (contract-struct-stronger? (parameter/c-out this) + (parameter/c-out that)) + (contract-struct-stronger? (parameter/c-in that) + (parameter/c-in this))))))) (define-struct procedure-arity-includes/c (n) #:property prop:custom-write custom-write-property-proc @@ -1565,12 +1403,9 @@ n)) (make-procedure-arity-includes/c n)) -(define (get-any-projection c) any-projection) -(define (any-projection b) any-function) -(define (any-function x) x) - (define (get-any? c) any?) (define (any? x) #t) +(define any/c-blame->neg-party-fn (λ (blame) any/c-neg-party-fn)) (define any/c-neg-party-fn (λ (val neg-party) val)) (define (random-any/c env fuel) @@ -1608,10 +1443,10 @@ (define-struct any/c () #:property prop:custom-write custom-write-property-proc #:omit-define-syntaxes + #:property prop:any/c #f #:property prop:flat-contract (build-flat-contract-property - #:projection get-any-projection - #:late-neg-projection (λ (ctc) (λ (blame) any/c-neg-party-fn)) + #:late-neg-projection (λ (ctc) any/c-blame->neg-party-fn) #:stronger (λ (this that) (any/c? that)) #:name (λ (ctc) 'any/c) #:generate (λ (ctc) @@ -1625,16 +1460,6 @@ (define-syntax (any stx) (raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx)) -(define (none-curried-proj ctc) - (λ (blame) - (λ (val) - (raise-blame-error - blame - val - '("~s accepts no values" given: "~e") - (none/c-name ctc) - val)))) - (define (((none-curried-late-neg-proj ctc) blame) val neg-party) (raise-blame-error blame #:missing-party neg-party @@ -1648,7 +1473,6 @@ #:omit-define-syntaxes #:property prop:flat-contract (build-flat-contract-property - #:projection none-curried-proj #:late-neg-projection none-curried-late-neg-proj #:stronger (λ (this that) #t) #:name (λ (ctc) (none/c-name ctc)) @@ -1682,42 +1506,6 @@ (list '#:call/cc) (base-prompt-tag/c-call/ccs ctc)))) ;; build a projection for prompt tags -(define ((prompt-tag/c-proj chaperone?) ctc) - (define proxy (if chaperone? chaperone-prompt-tag impersonate-prompt-tag)) - (define proc-proxy (if chaperone? chaperone-procedure impersonate-procedure)) - (define ho-projs - (map contract-projection (base-prompt-tag/c-ctcs ctc))) - (define call/cc-projs - (map contract-projection (base-prompt-tag/c-call/ccs ctc))) - (λ (blame) - (define (make-proj projs swap?) - (λ vs - (define vs2 (for/list ([proj projs] [v vs]) - ((proj (if swap? (blame-swap blame) blame)) v))) - (apply values vs2))) - ;; prompt/abort projections - (define proj1 (make-proj ho-projs #f)) - (define proj2 (make-proj ho-projs #t)) - ;; call/cc projections - (define call/cc-guard (make-proj call/cc-projs #f)) - (define call/cc-proxy - (λ (f) - (proc-proxy - f - (λ args - (apply values (make-proj call/cc-projs #t) args))))) - ;; now do the actual wrapping - (λ (val) - (unless (contract-first-order-passes? ctc val) - (raise-blame-error - blame val - '(expected: "~s" given: "~e") - (contract-name ctc) - val)) - (proxy val proj1 proj2 call/cc-guard call/cc-proxy - impersonator-prop:contracted ctc - impersonator-prop:blame blame)))) - (define ((prompt-tag/c-late-neg-proj chaperone?) ctc) (define proxy (if chaperone? chaperone-prompt-tag impersonate-prompt-tag)) (define proc-proxy (if chaperone? chaperone-procedure impersonate-procedure)) @@ -1766,10 +1554,10 @@ (define (prompt-tag/c-stronger? this that) (and (base-prompt-tag/c? that) - (andmap (λ (this that) (contract-stronger? this that)) + (andmap (λ (this that) (contract-struct-stronger? this that)) (base-prompt-tag/c-ctcs this) (base-prompt-tag/c-ctcs that)) - (andmap (λ (this that) (contract-stronger? this that)) + (andmap (λ (this that) (contract-struct-stronger? this that)) (base-prompt-tag/c-call/ccs this) (base-prompt-tag/c-call/ccs that)))) @@ -1781,7 +1569,6 @@ #:property prop:chaperone-contract (build-chaperone-contract-property #:late-neg-projection (prompt-tag/c-late-neg-proj #t) - #:projection (prompt-tag/c-proj #t) #:first-order (λ (ctc) continuation-prompt-tag?) #:stronger prompt-tag/c-stronger? #:name prompt-tag/c-name)) @@ -1791,7 +1578,6 @@ #:property prop:contract (build-contract-property #:late-neg-projection (prompt-tag/c-late-neg-proj #f) - #:projection (prompt-tag/c-proj #f) #:first-order (λ (ctc) continuation-prompt-tag?) #:stronger prompt-tag/c-stronger? #:name prompt-tag/c-name)) @@ -1810,23 +1596,6 @@ 'continuation-mark-key/c (base-continuation-mark-key/c-ctc ctc))) -(define ((continuation-mark-key/c-proj proxy) ctc) - (define ho-proj - (contract-projection (base-continuation-mark-key/c-ctc ctc))) - (λ (blame) - (define proj1 (ho-proj blame)) - (define proj2 (ho-proj (blame-swap blame))) - (λ (val) - (unless (contract-first-order-passes? ctc val) - (raise-blame-error - blame val - '(expected: "~s" given: "~e") - (contract-name ctc) - val)) - (proxy val proj1 proj2 - impersonator-prop:contracted ctc - impersonator-prop:blame blame)))) - (define ((continuation-mark-key/c-late-neg-proj proxy) ctc) (define ho-proj (get/build-late-neg-projection (base-continuation-mark-key/c-ctc ctc))) @@ -1853,7 +1622,7 @@ (define (continuation-mark-key/c-stronger? this that) (and (base-continuation-mark-key/c? that) - (contract-stronger? + (contract-struct-stronger? (base-continuation-mark-key/c-ctc this) (base-continuation-mark-key/c-ctc that)))) @@ -1866,7 +1635,6 @@ #:property prop:chaperone-contract (build-chaperone-contract-property #:late-neg-projection (continuation-mark-key/c-late-neg-proj chaperone-continuation-mark-key) - #:projection (continuation-mark-key/c-proj chaperone-continuation-mark-key) #:first-order (λ (ctc) continuation-mark-key?) #:stronger continuation-mark-key/c-stronger? #:name continuation-mark-key/c-name)) @@ -1878,7 +1646,6 @@ #:property prop:contract (build-contract-property #:late-neg-projection (continuation-mark-key/c-late-neg-proj impersonate-continuation-mark-key) - #:projection (continuation-mark-key/c-proj impersonate-continuation-mark-key) #:first-order (λ (ctc) continuation-mark-key?) #:stronger continuation-mark-key/c-stronger? #:name continuation-mark-key/c-name)) @@ -1913,10 +1680,10 @@ ((proj blame) val)))) (define (generator evt) (values evt (checker evt))) - (λ (val) + (λ (val neg-party) (unless (contract-first-order-passes? evt-ctc val) (raise-blame-error - blame val + blame val #:missing-party neg-party '(expected: "~s" given: "~e") (contract-name evt-ctc) val)) @@ -1936,15 +1703,13 @@ (define (evt/c-stronger? this that) (define this-ctcs (chaperone-evt/c-ctcs this)) (define that-ctcs (chaperone-evt/c-ctcs that)) - (and (= (length this-ctcs) (that-ctcs)) - (for/and ([this this-ctcs] [that that-ctcs]) - (contract-stronger? this that)))) + (pairwise-stronger-contracts? this-ctcs that-ctcs)) ;; ctcs - Listof (define-struct chaperone-evt/c (ctcs) #:property prop:chaperone-contract (build-chaperone-contract-property - #:projection evt/c-proj + #:late-neg-projection evt/c-proj #:first-order evt/c-first-order #:stronger evt/c-stronger? #:name evt/c-name)) @@ -1962,23 +1727,6 @@ 'channel/c (base-channel/c-ctc ctc))) -(define ((channel/c-proj proxy) ctc) - (define ho-proj - (contract-projection (base-channel/c-ctc ctc))) - (λ (blame) - (define proj1 (λ (ch) (values ch (λ (v) ((ho-proj blame) v))))) - (define proj2 (λ (ch v) ((ho-proj (blame-swap blame)) v))) - (λ (val) - (unless (contract-first-order-passes? ctc val) - (raise-blame-error - blame val - '(expected: "~s" given: "~e") - (contract-name ctc) - val)) - (proxy val proj1 proj2 - impersonator-prop:contracted ctc - impersonator-prop:blame blame)))) - (define ((channel/c-late-neg-proj proxy) ctc) (define ho-proj (get/build-late-neg-projection (base-channel/c-ctc ctc))) @@ -2006,7 +1754,7 @@ (define (channel/c-stronger? this that) (and (base-channel/c? that) - (contract-stronger? + (contract-struct-stronger? (base-channel/c-ctc this) (base-channel/c-ctc that)))) @@ -2018,7 +1766,6 @@ #:property prop:chaperone-contract (build-chaperone-contract-property #:late-neg-projection (channel/c-late-neg-proj chaperone-channel) - #:projection (channel/c-proj chaperone-channel) #:first-order channel/c-first-order #:stronger channel/c-stronger? #:name channel/c-name)) @@ -2029,7 +1776,6 @@ #:property prop:contract (build-contract-property #:late-neg-projection (channel/c-late-neg-proj impersonate-channel) - #:projection (channel/c-proj impersonate-channel) #:first-order channel/c-first-order #:stronger channel/c-stronger? #:name channel/c-name)) @@ -2039,58 +1785,6 @@ (contract-struct-first-order (coerce-flat-contract 'flat-contract-predicate x))) -(define (flat-contract? x) - (let ([c (coerce-contract/f x)]) - (and c - (flat-contract-struct? c)))) - -(define (chaperone-contract? x) - (let ([c (coerce-contract/f x)]) - (and c - (or (chaperone-contract-struct? c) - (and (prop:opt-chaperone-contract? c) - ((prop:opt-chaperone-contract-get-test c) c)))))) - -(define (impersonator-contract? x) - (let ([c (coerce-contract/f x)]) - (and c - (not (flat-contract-struct? c)) - (not (chaperone-contract-struct? c))))) - -(define (contract-name ctc) - (contract-struct-name - (coerce-contract 'contract-name ctc))) - -(define (contract? x) (and (coerce-contract/f x) #t)) -(define (contract-projection ctc) - (contract-struct-projection - (coerce-contract 'contract-projection ctc))) -(define (contract-val-first-projection ctc) - (contract-struct-val-first-projection - (coerce-contract 'contract-projection ctc))) -(define (contract-late-neg-projection ctc) - (contract-struct-late-neg-projection - (coerce-contract 'contract-projection ctc))) - -(define (get/build-val-first-projection ctc) - (or (contract-struct-val-first-projection ctc) - (let ([p (contract-projection ctc)]) - (λ (blme) - (procedure-rename - (λ (val) - (λ (neg-party) - ((p (blame-add-missing-party blme neg-party)) val))) - (string->symbol (format "val-first: ~s" (contract-name ctc)))))))) - -(define (get/build-late-neg-projection ctc) - (or (contract-struct-late-neg-projection ctc) - (let ([p (contract-projection ctc)]) - (λ (blme) - (procedure-rename - (λ (val neg-party) - ((p (blame-add-missing-party blme neg-party)) val)) - (string->symbol (format "late-neg: ~s" (contract-name ctc)))))))) - (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (flat-named-contract name pre-contract [generate #f]) (cond @@ -2169,51 +1863,73 @@ (flat-named-contract name (flat-contract-predicate ctc)) (let* ([make-contract (if (chaperone-contract? ctc) make-chaperone-contract make-contract)]) (define (stronger? this other) - (contract-stronger? ctc other)) + (contract-struct-stronger? ctc other)) (make-contract #:name name - #:projection (contract-projection ctc) + #:late-neg-projection (get/build-late-neg-projection ctc) #:first-order (contract-first-order ctc) #:stronger stronger? #:list-contract? (list-contract? ctc)))))) -;; (if/c predicate then/c else/c) applies then/c to satisfying -;; predicate, else/c to those that don't. (define (if/c predicate then/c else/c) - #| - Naive version: - (or/c (and/c predicate then/c) - (and/c (not/c predicate) else/c)) - But that applies predicate twice. - |# (unless (procedure? predicate) (raise-type-error 'if/c "procedure?" predicate)) - (unless (contract? then/c) - (raise-type-error 'if/c "contract?" then/c)) - (unless (contract? else/c) - (raise-type-error 'if/c "contract?" else/c)) - (let ([then-ctc (coerce-contract 'if/c then/c)] - [else-ctc (coerce-contract 'if/c else/c)]) - (define name (build-compound-type-name 'if/c predicate then-ctc else-ctc)) - ;; Special case: if both flat contracts, make a flat contract. - (if (and (flat-contract? then-ctc) - (flat-contract? else-ctc)) - ;; flat contract - (let ([then-pred (flat-contract-predicate then-ctc)] - [else-pred (flat-contract-predicate else-ctc)]) - (define (pred x) - (if (predicate x) (then-pred x) (else-pred x))) - (flat-named-contract name pred)) - ;; ho contract - (let ([then-proj (contract-projection then-ctc)] - [then-fo (contract-first-order then-ctc)] - [else-proj (contract-projection else-ctc)] - [else-fo (contract-first-order else-ctc)]) - (define ((proj blame) x) - (if (predicate x) - ((then-proj blame) x) - ((else-proj blame) x))) - (make-contract - #:name name - #:projection proj - #:first-order - (lambda (x) (if (predicate x) (then-fo x) (else-fo x)))))))) + (unless (procedure-arity-includes? predicate 1) + (raise-type-error 'if/c "procedure that accepts 1 argument" predicate)) + (define then-ctc (coerce-contract 'if/c then/c)) + (define else-ctc (coerce-contract 'if/c else/c)) + (cond + [(and (flat-contract? then-ctc) + (flat-contract? else-ctc)) + (define then-pred (flat-contract-predicate then-ctc)) + (define else-pred (flat-contract-predicate else-ctc)) + (define name `(if/c ,(object-name predicate) + ,(contract-name then-pred) + ,(contract-name else-pred))) + (define (pred x) + (if (predicate x) (then-pred x) (else-pred x))) + (flat-named-contract name pred)] + [(and (chaperone-contract? then-ctc) + (chaperone-contract? else-ctc)) + (chaperone-if/c predicate then-ctc else-ctc)] + [else + (impersonator-if/c predicate then-ctc else-ctc)])) + +(define (if/c-first-order ctc) + (define predicate (base-if/c-predicate ctc)) + (define thn (contract-first-order (base-if/c-thn ctc))) + (define els (contract-first-order (base-if/c-els ctc))) + (λ (x) (if (predicate x) (thn x) (els x)))) + +(define (if/c-name ctc) + (define predicate (base-if/c-predicate ctc)) + (define thn (contract-name (base-if/c-thn ctc))) + (define els (contract-name (base-if/c-els ctc))) + `(if/c ,(object-name predicate) ,thn ,els)) + +(define (if/c-late-neg-proj ctc) + (define predicate (base-if/c-predicate ctc)) + (define thn (get/build-late-neg-projection (base-if/c-thn ctc))) + (define els (get/build-late-neg-projection (base-if/c-els ctc))) + (λ (blame) + (define thn-proj (thn blame)) + (define els-proj (els blame)) + (λ (val neg-party) + (if (predicate val) + (thn-proj val neg-party) + (els-proj val neg-party))))) + +(define-struct base-if/c (predicate thn els) + #:property prop:custom-write custom-write-property-proc) +(define-struct (chaperone-if/c base-if/c) () + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:late-neg-projection if/c-late-neg-proj + #:first-order if/c-first-order + #:name if/c-name)) + +(define-struct (impersonator-if/c base-if/c) () + #:property prop:contract + (build-contract-property + #:late-neg-projection if/c-late-neg-proj + #:first-order if/c-first-order + #:name if/c-name)) diff --git a/racket/collects/racket/contract/private/object.rkt b/racket/collects/racket/contract/private/object.rkt index 8ce589f349..f94fe74dcb 100644 --- a/racket/collects/racket/contract/private/object.rkt +++ b/racket/collects/racket/contract/private/object.rkt @@ -43,11 +43,11 @@ #:omit-define-syntaxes #:property prop:contract (build-contract-property - #:projection + #:late-neg-projection (λ (ctc) (λ (blame) - (λ (val) - (make-wrapper-object ctc val blame + (λ (val neg-party) + (make-wrapper-object ctc val blame neg-party (object-contract-methods ctc) (object-contract-method-ctcs ctc) (object-contract-fields ctc) (object-contract-field-ctcs ctc))))) #:name diff --git a/racket/collects/racket/contract/private/opt-guts.rkt b/racket/collects/racket/contract/private/opt-guts.rkt index aca87b6150..9ac523fe3a 100644 --- a/racket/collects/racket/contract/private/opt-guts.rkt +++ b/racket/collects/racket/contract/private/opt-guts.rkt @@ -23,6 +23,7 @@ opt/info-add-blame-context opt/info-change-val opt/info-positive-blame + opt/info-negative-blame opt/unknown opt-error-name @@ -164,6 +165,10 @@ (if (opt/info-swap-blame? oi) #`(blame-positive #,(opt/info-blame-original-id oi)) #`(blame-negative #,(opt/info-blame-original-id oi)))) +(define (opt/info-negative-blame oi) + (if (opt/info-swap-blame? oi) + #`(blame-negative #,(opt/info-blame-original-id oi)) + #`(blame-positive #,(opt/info-blame-original-id oi)))) ;; opt/info-swap-blame : opt/info -> opt/info ;; swaps pos and neg diff --git a/racket/collects/racket/contract/private/opt.rkt b/racket/collects/racket/contract/private/opt.rkt index 4743434a71..f3f44d5e98 100644 --- a/racket/collects/racket/contract/private/opt.rkt +++ b/racket/collects/racket/contract/private/opt.rkt @@ -1,6 +1,5 @@ #lang racket/base (require "prop.rkt" - "misc.rkt" "blame.rkt" "guts.rkt" "base.rkt" diff --git a/racket/collects/racket/contract/private/opters.rkt b/racket/collects/racket/contract/private/opters.rkt index 14d849abee..7eaa59ea07 100644 --- a/racket/collects/racket/contract/private/opters.rkt +++ b/racket/collects/racket/contract/private/opters.rkt @@ -4,9 +4,9 @@ "guts.rkt" "arrow.rkt" "blame.rkt" - "misc.rkt" "arrow.rkt" "arrow-val-first.rkt" + "arrow-higher-order.rkt" "orc.rkt" (for-syntax racket/base syntax/stx @@ -64,7 +64,8 @@ (define ps-optres (opt/i (opt/info-add-blame-context opt/info (λ (blame-stx) - #`(blame-add-or-context #,blame-stx))) + #`(blame-add-or-context #,blame-stx) + blame-stx)) (car ps))) (if (optres-flat ps-optres) (loop (cdr ps) @@ -576,7 +577,9 @@ (syntax-case stx () [(x) #'x] [(x ...) #'(values x ...)])) - #`(let* ([cont-mark-value (cons #,(opt/info-positive-blame opt/info) '#,rngs)] + #`(let* ([cont-mark-value (list* #,(opt/info-positive-blame opt/info) + #,(opt/info-negative-blame opt/info) + '#,rngs)] [exact-proc (case-lambda [(dom-arg ...) (let-values ([(rng-checker dom-vars ...) @@ -617,6 +620,10 @@ #`(list 'values #,@rng-names)))))) (define (opt/arrow-any-ctc doms) + (define all-anys? (for/and ([d (in-list doms)]) + (syntax-case d (any/c) + [any/c #t] + [anything-else #f]))) (let*-values ([(dom-vars) (generate-temporaries doms)] [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone? names) (let loop ([vars dom-vars] @@ -660,14 +667,20 @@ ((dom-arg ...) dom-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars))) - (syntax (begin - (check-procedure val #f dom-len 0 '() '() #|keywords|# blame) - (chaperone-procedure - val - (case-lambda - [(dom-arg ...) (values next-dom ...)] - [args - (bad-number-of-arguments blame val args dom-len)]))))) + (define do-chap-stx + #'(begin + (check-procedure val #f dom-len 0 '() '() #|keywords|# blame #f) + (chaperone-procedure + val + (case-lambda + [(dom-arg ...) (values next-dom ...)] + [args + (bad-number-of-arguments blame val args dom-len)])))) + (if all-anys? + #`(if (procedure-arity-exactly/no-kwds val #,(length doms)) + val + #,do-chap-stx) + do-chap-stx)) lifts-doms superlifts-doms partials-doms @@ -680,25 +693,6 @@ 'any)))) (syntax-case* stx (-> values any any/c boolean?) module-or-top-identifier=? - [(_ any/c ... any) - (with-syntax ([n (- (length (syntax->list stx)) 2)]) - (build-optres - #:exp - (with-syntax ((val (opt/info-val opt/info)) - (ctc (opt/info-contract opt/info)) - (blame (opt/info-blame opt/info))) - (syntax (if (and (procedure? val) - (procedure-arity-includes? val n)) - val - (raise-flat-arrow-err blame val n)))) - #:lifts null - #:superlifts null - #:partials null - #:flat #'(and (procedure? val) (procedure-arity-includes? val n)) - #:opt #f - #:stronger-ribs null - #:chaperone #t - #:name #`'(-> #,@(build-list (syntax-e #'n) (λ (x) 'any/c)) any)))] [(_ any/c boolean?) (predicate/c-optres opt/info #f)] [(_ dom ... (values rng ...)) @@ -742,7 +736,7 @@ (define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info #t)) (define (handle-non-exact-procedure val dom-len blame exact-proc) - (check-procedure val #f dom-len 0 '() '() blame) + (check-procedure val #f dom-len 0 '() '() blame #f) (chaperone-procedure val (make-keyword-procedure diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt index de482e19d6..4077120e65 100644 --- a/racket/collects/racket/contract/private/orc.rkt +++ b/racket/collects/racket/contract/private/orc.rkt @@ -7,11 +7,12 @@ "misc.rkt" (for-syntax racket/base)) -(provide symbols or/c one-of/c +(provide symbols or/c first-or/c one-of/c blame-add-or-context + blame-add-ior-context (rename-out [_flat-rec-contract flat-rec-contract])) -(define/subexpression-pos-prop or/c +(define/subexpression-pos-prop/name or/c-name or/c (case-lambda [() (make-none/c '(or/c))] [(x) (coerce-contract 'or/c x)] @@ -30,19 +31,7 @@ (loop ho-contracts (cons arg flat-contracts) (cdr args))] [else (loop (cons arg ho-contracts) flat-contracts (cdr args))]))]))) - (define pred - (cond - [(null? flat-contracts) not] - [else - (let loop ([fst (car flat-contracts)] - [rst (cdr flat-contracts)]) - (let ([fst-pred (flat-contract-predicate fst)]) - (cond - [(null? rst) fst-pred] - [else - (let ([r (loop (car rst) (cdr rst))]) - (λ (x) (or (fst-pred x) (r x))))])))])) - + (define pred (make-flat-predicate flat-contracts)) (cond [(null? ho-contracts) (make-flat-or/c pred flat-contracts)] @@ -57,16 +46,31 @@ (make-chaperone-multi-or/c name flat-contracts ho-contracts) (make-impersonator-multi-or/c name flat-contracts ho-contracts))])])) -(define (single-or/c-projection ctc) - (let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))] - [pred (single-or/c-pred ctc)]) - (λ (blame) - (define partial-contract - (c-proc (blame-add-or-context blame))) - (λ (val) - (cond - [(pred val) val] - [else (partial-contract val)]))))) +(define/subexpression-pos-prop first-or/c + (case-lambda + [() (make-none/c '(first-or/c))] + [(x) (coerce-contract 'first-or/c x)] + [raw-args + (define args (coerce-contracts 'first-or/c raw-args)) + (cond + [(andmap flat-contract? args) + (make-flat-first-or/c (make-flat-predicate args) args)] + [(andmap chaperone-contract? args) + (make-chaperone-first-or/c args)] + [else (make-impersonator-first-or/c args)])])) + +(define (make-flat-predicate flat-contracts) + (cond + [(null? flat-contracts) not] + [else + (let loop ([fst (car flat-contracts)] + [rst (cdr flat-contracts)]) + (let ([fst-pred (flat-contract-predicate fst)]) + (cond + [(null? rst) fst-pred] + [else + (let ([r (loop (car rst) (cdr rst))]) + (λ (x) (or (fst-pred x) (r x))))])))])) (define (single-or/c-late-neg-projection ctc) (define c-proj (get/build-late-neg-projection (single-or/c-ho-ctc ctc))) @@ -74,12 +78,14 @@ (λ (blame) (define p-app (c-proj (blame-add-or-context blame))) (λ (val neg-party) - (if (pred val) - val - (p-app val neg-party))))) + (cond + [(pred val) val] + [else (p-app val neg-party)])))) (define (blame-add-or-context blame) (blame-add-context blame "a part of the or/c of")) +(define (blame-add-ior-context blame) + (blame-add-context blame "a part of the first-or/c of")) (define (single-or/c-first-order ctc) (let ([pred (single-or/c-pred ctc)] @@ -88,14 +94,10 @@ (define (single-or/c-stronger? this that) (or (and (single-or/c? that) - (contract-stronger? (single-or/c-ho-ctc this) - (single-or/c-ho-ctc that)) - (let ([this-ctcs (single-or/c-flat-ctcs this)] - [that-ctcs (single-or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs)))) + (contract-struct-stronger? (single-or/c-ho-ctc this) + (single-or/c-ho-ctc that)) + (pairwise-stronger-contracts? (single-or/c-flat-ctcs this) + (single-or/c-flat-ctcs that))) (generic-or/c-stronger? this that))) (define (generic-or/c-stronger? this that) @@ -105,7 +107,7 @@ that-sub-ctcs (for/and ([this-sub-ctc (in-list this-sub-ctcs)]) (for/or ([that-sub-ctc (in-list that-sub-ctcs)]) - (contract-stronger? this-sub-ctc that-sub-ctc))))) + (contract-struct-stronger? this-sub-ctc that-sub-ctc))))) (define (or/c-sub-contracts ctc) (cond @@ -117,6 +119,7 @@ (multi-or/c-ho-ctcs ctc))] [(flat-or/c? ctc) (flat-or/c-flat-ctcs ctc)] + [(base-first-or/c? ctc) (base-first-or/c-ctcs ctc)] [else #f])) (define (or/c-exercise ho-contracts) @@ -197,24 +200,7 @@ (define-struct (chaperone-single-or/c single-or/c) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:projection single-or/c-projection - #:late-neg-projection single-or/c-late-neg-projection - #:name single-or/c-name - #:first-order single-or/c-first-order - #:stronger single-or/c-stronger? - #:generate (λ (ctc) (or/c-generate ctc - (cons (single-or/c-ho-ctc ctc) - (single-or/c-flat-ctcs ctc)))) - #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))) - #:list-contract? single-or/c-list-contract?))) - -(define-struct (impersonator-single-or/c single-or/c) () - #:property prop:custom-write custom-write-property-proc - #:property prop:contract - (build-contract-property - #:projection single-or/c-projection + (build-chaperone-contract-property #:late-neg-projection single-or/c-late-neg-projection #:name single-or/c-name #:first-order single-or/c-first-order @@ -225,35 +211,19 @@ #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))) #:list-contract? single-or/c-list-contract?)) -(define (multi-or/c-proj ctc) - (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)] - [c-procs (map (λ (x) (contract-projection x)) ho-contracts)] - [first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)] - [predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]) - (λ (blame) - (define disj-blame (blame-add-context blame "a part of the or/c of")) - (define partial-contracts - (for/list ([c-proc (in-list c-procs)]) - (c-proc disj-blame))) - (λ (val) - (cond - [(ormap (λ (pred) (pred val)) predicates) - val] - [else - (let loop ([checks first-order-checks] - [procs partial-contracts] - [contracts ho-contracts]) - (cond - [(null? checks) - (raise-blame-error blame val - '("none of the branches of the or/c matched" given: "~e") - val)] - [((car checks) val) - ((car procs) val)] - [else - (loop (cdr checks) - (cdr procs) - (cdr contracts))]))]))))) +(define-struct (impersonator-single-or/c single-or/c) () + #:property prop:custom-write custom-write-property-proc + #:property prop:contract + (build-contract-property + #:late-neg-projection single-or/c-late-neg-projection + #:name single-or/c-name + #:first-order single-or/c-first-order + #:stronger single-or/c-stronger? + #:generate (λ (ctc) (or/c-generate ctc + (cons (single-or/c-ho-ctc ctc) + (single-or/c-flat-ctcs ctc)))) + #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))) + #:list-contract? single-or/c-list-contract?)) (define (multi-or/c-late-neg-proj ctc) (define ho-contracts (multi-or/c-ho-ctcs ctc)) @@ -269,20 +239,57 @@ (pred val)) val] [else - (let loop ([checks first-order-checks] - [c-projs c-projs+blame] - [contracts ho-contracts]) + (define (try) + (let loop ([checks first-order-checks] + [c-projs c-projs+blame] + [contracts ho-contracts] + [candidate-c-proj #f] + [candidate-contract #f]) + (cond + [(null? checks) + (cond + [candidate-c-proj + (values candidate-c-proj #f)] + [else + (raise-none-or-matched blame val neg-party)])] + [((car checks) val) + (if candidate-c-proj + (values candidate-contract (car contracts)) + (loop (cdr checks) + (cdr c-projs) + (cdr contracts) + (car c-projs) + (car contracts)))] + [else + (loop (cdr checks) + (cdr c-projs) + (cdr contracts) + candidate-c-proj + candidate-contract)]))) + + (let loop ([how-hard '(10 100)]) (cond - [(null? checks) - (raise-blame-error blame val #:missing-party neg-party - '("none of the branches of the or/c matched" given: "~e") - val)] - [((car checks) val) - ((car c-projs) val neg-party)] + [(null? how-hard) + (define-values (last-try-first-one last-try-second-one) (try)) + (when (and last-try-first-one last-try-second-one) + (raise-blame-error blame val #:missing-party neg-party + '("two of the clauses in the or/c might both match: ~s and ~s" + given: + "~e") + (contract-name last-try-first-one) + (contract-name last-try-second-one) + val))] [else - (loop (cdr checks) - (cdr c-projs) - (cdr contracts))]))])))) + (define-values (this-try-first-one this-try-second-one) + (contract-first-order-only-try-so-hard (car how-hard) (try))) + (cond + [(not this-try-second-one) (this-try-first-one val neg-party)] + [else (loop (cdr how-hard))])]))])))) + +(define (raise-none-or-matched blame val neg-party) + (raise-blame-error blame val #:missing-party neg-party + '("none of the branches of the or/c matched" given: "~e") + val)) (define (multi-or/c-first-order ctc) (let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))] @@ -293,14 +300,10 @@ (define (multi-or/c-stronger? this that) (or (and (multi-or/c? that) - (let ([this-ctcs (multi-or/c-ho-ctcs this)] - [that-ctcs (multi-or/c-ho-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? this-ctcs that-ctcs))) - (let ([this-ctcs (multi-or/c-flat-ctcs this)] - [that-ctcs (multi-or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? this-ctcs that-ctcs)))) + (pairwise-stronger-contracts? (multi-or/c-ho-ctcs this) + (multi-or/c-ho-ctcs that)) + (pairwise-stronger-contracts? (multi-or/c-flat-ctcs this) + (multi-or/c-flat-ctcs that))) (generic-or/c-stronger? this that))) (define (mult-or/c-list-contract? c) @@ -317,24 +320,21 @@ (define-struct (chaperone-multi-or/c multi-or/c) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:projection multi-or/c-proj - #:late-neg-projection multi-or/c-late-neg-proj - #:name multi-or/c-name - #:first-order multi-or/c-first-order - #:stronger multi-or/c-stronger? - #:generate (λ (ctc) (or/c-generate ctc - (append (multi-or/c-ho-ctcs ctc) - (multi-or/c-flat-ctcs ctc)))) - #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))) - #:list-contract? mult-or/c-list-contract?))) + (build-chaperone-contract-property + #:late-neg-projection multi-or/c-late-neg-proj + #:name multi-or/c-name + #:first-order multi-or/c-first-order + #:stronger multi-or/c-stronger? + #:generate (λ (ctc) (or/c-generate ctc + (append (multi-or/c-ho-ctcs ctc) + (multi-or/c-flat-ctcs ctc)))) + #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))) + #:list-contract? mult-or/c-list-contract?)) (define-struct (impersonator-multi-or/c multi-or/c) () #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection multi-or/c-proj #:late-neg-projection multi-or/c-late-neg-proj #:name multi-or/c-name #:first-order multi-or/c-first-order @@ -354,7 +354,7 @@ #:name (λ (ctc) (apply build-compound-type-name - 'or/c + (if (flat-first-or/c? ctc) 'first-or/c 'or/c) (flat-or/c-flat-ctcs ctc))) #:stronger (λ (this that) @@ -365,7 +365,7 @@ [(and (<= (length this-ctcs) (length that-ctcs)) (for/and ([this-ctc (in-list this-ctcs)] [that-ctc (in-list that-ctcs)]) - (contract-stronger? this-ctc that-ctc))) + (contract-struct-stronger? this-ctc that-ctc))) #t] [(and (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) this-ctcs) (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) that-ctcs)) @@ -394,6 +394,48 @@ (for/and ([c (in-list (flat-or/c-flat-ctcs ctc))]) (list-contract? c))))) +(define-struct (flat-first-or/c flat-or/c) ()) + +(define (first-or/c-late-neg-proj ctc) + (define ho-contracts (base-first-or/c-ctcs ctc)) + (define c-projs (map get/build-late-neg-projection ho-contracts)) + (define first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)) + (λ (blame) + (define blame-w-context (blame-add-ior-context blame)) + (define c-projs+blame (map (λ (c-proj) (c-proj blame-w-context)) c-projs)) + (λ (val neg-party) + (let loop ([checks first-order-checks] + [c-projs c-projs+blame] + [contracts ho-contracts]) + (cond + [(null? checks) + (raise-none-ior-matched blame val neg-party)] + [else + (cond + [((car checks) val) + ((car c-projs) val neg-party)] + [else + (loop (cdr checks) + (cdr c-projs) + (cdr contracts))])]))))) + +(define (raise-none-ior-matched blame val neg-party) + (raise-blame-error blame val #:missing-party neg-party + '("none of the branches of the first-or/c matched" given: "~e") + val)) + +(define (first-or/c-name ctc) + (apply build-compound-type-name + 'first-or/c + (base-first-or/c-ctcs ctc))) + +(define (first-or/c-first-order ctc) + (define preds (map contract-first-order (base-first-or/c-ctcs ctc))) + (λ (x) (ormap (lambda (p?) (p? x)) preds))) + +(define (first-or/c-list-contract? c) + (for/and ([c (in-list (base-first-or/c-ctcs c))]) + (list-contract? c))) (define/final-prop (symbols s1 . s2s) (define ss (cons s1 s2s)) @@ -406,7 +448,31 @@ ss))) (apply or/c ss)) +(define-struct base-first-or/c (ctcs) + #:property prop:custom-write custom-write-property-proc + #:property prop:orc-contract + (λ (this) (base-first-or/c-ctcs this))) +(define-struct (chaperone-first-or/c base-first-or/c) () + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:late-neg-projection first-or/c-late-neg-proj + #:name first-or/c-name + #:first-order first-or/c-first-order + #:stronger multi-or/c-stronger? + #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc))) + #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc))) + #:list-contract? first-or/c-list-contract?)) +(define-struct (impersonator-first-or/c base-first-or/c) () + #:property prop:contract + (build-contract-property + #:late-neg-projection first-or/c-late-neg-proj + #:name first-or/c-name + #:first-order first-or/c-first-order + #:stronger generic-or/c-stronger? + #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc))) + #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc))) + #:list-contract? first-or/c-list-contract?)) (define/final-prop (one-of/c . elems) (for ([arg (in-list elems)] @@ -443,12 +509,12 @@ (λ (ctc) (flat-rec-contract-name ctc)) #:stronger (let ([recur? (make-parameter #t)]) - (λ (this that) + (λ (this that) (cond [(equal? this that) #t] [(recur?) (parameterize ([recur? #f]) - (contract-stronger? (get-flat-rec-me this) that))] + (contract-struct-stronger? (get-flat-rec-me this) that))] [else #f]))) #:first-order (λ (ctc) diff --git a/racket/collects/racket/contract/private/parametric.rkt b/racket/collects/racket/contract/private/parametric.rkt index c789f44c76..a0b072a104 100644 --- a/racket/collects/racket/contract/private/parametric.rkt +++ b/racket/collects/racket/contract/private/parametric.rkt @@ -1,7 +1,6 @@ #lang racket/base (require "prop.rkt" "blame.rkt" - "misc.rkt" "guts.rkt" (for-syntax "arr-util.rkt" racket/base)) (provide parametric->/c) @@ -50,42 +49,44 @@ (define instances (for/list ([var (in-list this-vars)]) (this-barrier/c #t var))) - (contract-stronger? (apply (polymorphic-contract-body this) instances) - (apply (polymorphic-contract-body that) instances))] + (contract-struct-stronger? (apply (polymorphic-contract-body this) instances) + (apply (polymorphic-contract-body that) instances))] [else #f])] [else #f])) - #:projection + #:late-neg-projection (lambda (c) (lambda (orig-blame) (define blame (blame-add-context orig-blame #f)) - (define (wrap p) + (define negative? (blame-swapped? blame)) + (define barrier/c (polymorphic-contract-barrier c)) + (define vars (polymorphic-contract-vars c)) + (define (wrap p neg-party) ;; values in polymorphic types come in from negative position, ;; relative to the poly/c contract - (define negative? (blame-swapped? blame)) - (define barrier/c (polymorphic-contract-barrier c)) (define instances - (for/list ([var (in-list (polymorphic-contract-vars c))]) + (for/list ([var (in-list vars)]) (barrier/c negative? var))) (define protector (apply (polymorphic-contract-body c) instances)) - (((contract-projection protector) blame) p)) + (((get/build-late-neg-projection protector) blame) p neg-party)) - (lambda (p) + (lambda (p neg-party) (unless (procedure? p) - (raise-blame-error blame p '(expected "a procedure" given: "~e") p)) + (raise-blame-error blame #:missing-party neg-party + p '(expected "a procedure" given: "~e") p)) (make-keyword-procedure - (lambda (keys vals . args) (keyword-apply (wrap p) keys vals args)) + (lambda (keys vals . args) (keyword-apply (wrap p neg-party) keys vals args)) (case-lambda - [() ((wrap p))] - [(a) ((wrap p) a)] - [(a b) ((wrap p) a b)] - [(a b c) ((wrap p) a b c)] - [(a b c d) ((wrap p) a b c d)] - [(a b c d e) ((wrap p) a b c d e)] - [(a b c d e f) ((wrap p) a b c d e f)] - [(a b c d e f g) ((wrap p) a b c d e f g)] - [(a b c d e f g h) ((wrap p) a b c d e f g h)] - [args (apply (wrap p) args)]))))))) + [() ((wrap p neg-party))] + [(a) ((wrap p neg-party) a)] + [(a b) ((wrap p neg-party) a b)] + [(a b c) ((wrap p neg-party) a b c)] + [(a b c d) ((wrap p neg-party) a b c d)] + [(a b c d e) ((wrap p neg-party) a b c d e)] + [(a b c d e f) ((wrap p neg-party) a b c d e f)] + [(a b c d e f g) ((wrap p neg-party) a b c d e f g)] + [(a b c d e f g h) ((wrap p neg-party) a b c d e f g h)] + [args (apply (wrap p neg-party) args)]))))))) (define (opaque/c positive? name) (define-values [ type make pred getter setter ] @@ -100,17 +101,20 @@ #:name (lambda (c) (barrier-contract-name c)) #:first-order (λ (c) (barrier-contract-pred c)) #:stronger (λ (this that) (eq? this that)) - #:projection + #:late-neg-projection (lambda (c) (define mk (barrier-contract-make c)) + (define (mk-np x neg-party) (mk x)) (define pred (barrier-contract-pred c)) (define get (barrier-contract-get c)) + (define cp? (barrier-contract-positive? c)) (lambda (blame) - (if (equal? (blame-original? blame) (barrier-contract-positive? c)) - mk - (lambda (x) + (if (equal? (blame-original? blame) cp?) + mk-np + (lambda (x neg-party) (if (pred x) (get x) - (raise-blame-error blame x '(expected: "~a" given: "~e") + (raise-blame-error blame #:missing-party neg-party + x '(expected: "~a" given: "~e") (barrier-contract-name c) x)))))))) diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt index cadcc3074d..4c51a8c21b 100644 --- a/racket/collects/racket/contract/private/prop.rkt +++ b/racket/collects/racket/contract/private/prop.rkt @@ -35,8 +35,6 @@ make-chaperone-contract make-flat-contract - skip-projection-wrapper? - prop:opt-chaperone-contract prop:opt-chaperone-contract? prop:opt-chaperone-contract-get-test @@ -52,7 +50,11 @@ prop:arrow-contract prop:arrow-contract? prop:arrow-contract-get-info - (struct-out arrow-contract-info)) + (struct-out arrow-contract-info) + + prop:any/c prop:any/c? + + build-context) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -97,10 +99,9 @@ first-order)) (define (contract-struct-projection c) - (let* ([prop (contract-struct-property c)] - [get-projection (contract-property-projection prop)] - [projection (get-projection c)]) - projection)) + (define prop (contract-struct-property c)) + (define get-projection (contract-property-projection prop)) + (and get-projection (get-projection c))) (define (contract-struct-val-first-projection c) (define prop (contract-struct-property c)) @@ -111,47 +112,56 @@ (define (contract-struct-late-neg-projection c) (define prop (contract-struct-property c)) (define get-projection (contract-property-late-neg-projection prop)) - (and get-projection + (and get-projection (get-projection c))) (define trail (make-parameter #f)) (define (contract-struct-stronger? a b) - (define prop (contract-struct-property a)) - (define stronger? (contract-property-stronger prop)) (cond - [(let ([th (trail)]) - (and th - (for/or ([(a2 bs-h) (in-hash th)]) - (and (eq? a a2) - (for/or ([(b2 _) (in-hash bs-h)]) - (eq? b b2)))))) - #t] - [(or (prop:recursive-contract? a) (prop:recursive-contract? b)) - (parameterize ([trail (or (trail) (make-hasheq))]) - (define trail-h (trail)) - (let ([a-h (hash-ref trail-h a #f)]) - (cond - [a-h - (hash-set! a-h b #t)] - [else - (define a-h (make-hasheq)) - (hash-set! trail-h a a-h) - (hash-set! a-h b #t)])) - (contract-struct-stronger? (if (prop:recursive-contract? a) - ((prop:recursive-contract-unroll a) a) - a) - (if (prop:recursive-contract? b) - ((prop:recursive-contract-unroll b) b) - b)))] + [(equal? a b) #t] [else - (let loop ([b b]) - (cond - [(stronger? a b) #t] - [(prop:orc-contract? b) - (define sub-contracts ((prop:orc-contract-get-subcontracts b) b)) - (for/or ([sub-contract (in-list sub-contracts)]) - (loop sub-contract))] - [else #f]))])) + (define prop (contract-struct-property a)) + (define stronger? (contract-property-stronger prop)) + (cond + [(stronger? a b) + ;; optimistically try skip some of the more complex work below + #t] + [(and (flat-contract-struct? a) (prop:any/c? b)) #t] ;; is the flat-check needed here? + [(let ([th (trail)]) + (and th + (for/or ([(a2 bs-h) (in-hash th)]) + (and (eq? a a2) + (for/or ([(b2 _) (in-hash bs-h)]) + (eq? b b2)))))) + #t] + [(or (prop:recursive-contract? a) (prop:recursive-contract? b)) + (parameterize ([trail (or (trail) (make-hasheq))]) + (define trail-h (trail)) + (let ([a-h (hash-ref trail-h a #f)]) + (cond + [a-h + (hash-set! a-h b #t)] + [else + (define a-h (make-hasheq)) + (hash-set! trail-h a a-h) + (hash-set! a-h b #t)])) + (contract-struct-stronger? (if (prop:recursive-contract? a) + ((prop:recursive-contract-unroll a) a) + a) + (if (prop:recursive-contract? b) + ((prop:recursive-contract-unroll b) b) + b)))] + [else + (let loop ([b b]) + (cond + [(stronger? a b) + #t] + [(prop:orc-contract? b) + (define sub-contracts ((prop:orc-contract-get-subcontracts b) b)) + (for/or ([sub-contract (in-list sub-contracts)]) + (loop sub-contract))] + [else + #f]))])])) (define (contract-struct-generate c) (define prop (contract-struct-property c)) @@ -256,9 +266,9 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define skip-projection-wrapper? (make-parameter #f)) +(define-logger racket/contract) -(define ((build-property mk default-name projection-wrapper) +(define ((build-property mk default-name proc-name first-order?) #:name [get-name #f] #:first-order [get-first-order #f] #:projection [get-projection #f] @@ -268,72 +278,58 @@ #:generate [generate (λ (ctc) (λ (fuel) #f))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:list-contract? [list-contract? (λ (c) #f)]) - - ;; this code is here to help me find the combinators that - ;; are still using only #:projection and not #:val-first-projection - #; - (when (and get-projection - (not get-val-first-projection)) - (printf "missing val-first-projection ~s\n" - get-projection)) - - (let* ([get-name (or get-name (lambda (c) default-name))] - [get-first-order (or get-first-order get-any?)] - [get-val-first-projection - (or get-val-first-projection - (and (not get-projection) - (get-val-first-first-order-projection get-name get-first-order)))] - [get-projection - (cond - [get-projection - (blame-context-projection-wrapper - (if (skip-projection-wrapper?) - get-projection - (projection-wrapper get-projection)))] - [else (val-first-projection->projection get-val-first-projection - get-name - get-first-order)])] - [stronger (or stronger weakest)]) + (unless (or get-first-order + get-projection + get-val-first-projection + get-late-neg-projection) + (error + proc-name + (string-append + "expected either the" + " #:projection, #:val-first-projection, #:late-neg-projection, or #:first-order" + " argument to not be #f, but all four were #f"))) - (mk get-name get-first-order - get-projection stronger - generate exercise - get-val-first-projection - get-late-neg-projection - list-contract?))) + (unless get-late-neg-projection + (unless first-order? + (log-racket/contract-warning + "no late-neg-projection passed to ~s~a" + proc-name + (build-context)))) + (mk (or get-name (λ (c) default-name)) + (or get-first-order get-any?) + get-projection + (or stronger weakest) + generate exercise + get-val-first-projection + (cond + [first-order? + (cond + [get-late-neg-projection get-late-neg-projection] + [(and (not get-projection) (not get-val-first-projection) get-first-order) + (λ (c) (late-neg-first-order-projection (get-name c) (get-first-order c)))] + [else #f])] + [else get-late-neg-projection]) + list-contract?)) + +(define (build-context) + (apply + string-append + (for/list ([i (in-list (continuation-mark-set->context + (current-continuation-marks)))]) + (format "\n ~s" i)))) + (define build-contract-property (procedure-rename - (build-property make-contract-property 'anonymous-contract values) + (build-property make-contract-property 'anonymous-contract 'build-contract-property #f) 'build-contract-property)) -;; Here we'll force the projection to always return the original value, -;; instead of assuming that the provided projection does so appropriately. -(define (flat-projection-wrapper f) - (λ (c) - (let ([proj (f c)]) - (λ (b) - (let ([p (proj b)]) - (λ (v) (p v) v)))))) - (define build-flat-contract-property (procedure-rename (build-property (compose make-flat-contract-property make-contract-property) - 'anonymous-flat-contract - flat-projection-wrapper) + 'anonymous-flat-contract 'build-flat-contract-property #t) 'build-flat-contract-property)) -(define (chaperone-projection-wrapper f) - (λ (c) - (let ([proj (f c)]) - (λ (b) - (let ([p (proj b)]) - (λ (v) - (let ([v* (p v)]) - (unless (chaperone-of? v* v) - (error 'prop:chaperone-contract (format "expected a chaperone of ~v, got ~v" v v*))) - v*))))))) - (define (blame-context-projection-wrapper proj) (λ (ctc) (define c-proj (proj ctc)) @@ -343,8 +339,7 @@ (define build-chaperone-contract-property (procedure-rename (build-property (compose make-chaperone-contract-property make-contract-property) - 'anonymous-chaperone-contract - chaperone-projection-wrapper) + 'anonymous-chaperone-contract 'build-chaperone-contract-property #f) 'build-chaperone-contract-property)) (define (get-any? c) any?) @@ -445,7 +440,7 @@ #:exercise (lambda (c) (make-flat-contract-exercise c)) #:list-contract? (λ (c) (make-flat-contract-list-contract? c)))) -(define ((build-contract mk default-name) +(define ((build-contract mk default-name proc-name first-order?) #:name [name #f] #:first-order [first-order #f] #:projection [projection #f] @@ -456,35 +451,50 @@ #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:list-contract? [list-contract? (λ (ctc) #f)]) - (let* ([name (or name default-name)] - [first-order (or first-order any?)] - [projection (or projection (first-order-projection name first-order))] - [val-first-projection (or val-first-projection - (and (not projection) - (val-first-first-order-projection name first-order)))] - [stronger (or stronger as-strong?)]) + (unless (or first-order + projection + val-first-projection + late-neg-projection) + (error + proc-name + (string-append + "expected either the" + " #:projection, #:val-first-projection, #:late-neg-projection, or #:first-order" + " argument to not be #f, but all four were #f"))) + + (unless late-neg-projection + (unless first-order? + (log-racket/contract-warning + "no late-neg-projection passed to ~s~a" + proc-name + (build-context)))) - (mk name first-order - projection val-first-projection late-neg-projection - stronger - generate exercise - list-contract?))) + (mk (or name default-name) + (or first-order any?) + projection val-first-projection + (cond + [first-order? + (cond + [late-neg-projection late-neg-projection] + [(and (not projection) (not val-first-projection) first-order) + (late-neg-first-order-projection name first-order)] + [else #f])] + [else late-neg-projection]) + (or stronger as-strong?) + generate exercise + list-contract?)) -(define ((get-val-first-first-order-projection get-name get-first-order) c) - (val-first-first-order-projection (get-name c) (get-first-order c))) - -(define (val-first-first-order-projection name p?) - (λ (b) - (λ (v) - (λ (neg-party) - (if (p? v) - v - (raise-blame-error - b #:missing-party neg-party - v - '(expected: "~s" given: "~e") - name - v)))))) +(define (late-neg-first-order-projection name p?) + (λ (b) + (λ (v neg-party) + (if (p? v) + v + (raise-blame-error + b #:missing-party neg-party + v + '(expected: "~s" given: "~e") + name + v))))) (define (as-strong? a b) (procedure-closure-contents-eq? @@ -493,17 +503,23 @@ (define make-contract (procedure-rename - (build-contract make-make-contract 'anonymous-contract) + (build-contract make-make-contract 'anonymous-contract 'make-contract #f) 'make-contract)) (define make-chaperone-contract (procedure-rename - (build-contract make-make-chaperone-contract 'anonymous-chaperone-contract) + (build-contract make-make-chaperone-contract + 'anonymous-chaperone-contract + 'make-chaperone-contract + #f) 'make-chaperone-contract)) (define make-flat-contract (procedure-rename - (build-contract make-make-flat-contract 'anonymous-flat-contract) + (build-contract make-make-flat-contract + 'anonymous-flat-contract + 'make-flat-contract + #t) 'make-flat-contract)) ;; property should be bound to a function that accepts the contract and @@ -518,6 +534,11 @@ prop:recursive-contract-unroll) (make-struct-type-property 'prop:recursive-contract)) +;; this property's value isn't looked at; it is just a signal +;; that the contract accepts any value +(define-values (prop:any/c prop:any/c? prop:get-any/c) + (make-struct-type-property 'prop:any/c)) + ;; get-info : (-> ctc arrow-contract-info?) (define-values (prop:arrow-contract prop:arrow-contract? prop:arrow-contract-get-info) (make-struct-type-property 'prop:arrow-contract)) @@ -528,4 +549,4 @@ ;; raises a blame error if val doesn't satisfy the first-order checks for the function ;; accepts-arglist : (-> (listof keyword?)[sorted by keyword syntax ;; returns an expression that evaluates to the source location of the argument (define-for-syntax (stx->srcloc-expr srcloc-stx) - #`(vector - '#,(syntax-source srcloc-stx) - #,(syntax-line srcloc-stx) - #,(syntax-column srcloc-stx) - #,(syntax-position srcloc-stx) - #,(syntax-span srcloc-stx))) + #`(quote-srcloc #,srcloc-stx)) (define-for-syntax (internal-function-to-be-figured-out ctrct id @@ -285,10 +276,12 @@ (define-values (arrow? the-valid-app-shapes) (syntax-case ctrct (->2 ->*2 ->i) [(->2 . _) - (->2-handled? ctrct) + (and (->2-handled? ctrct) + (not (->2-arity-check-only->? ctrct))) (values #t (->-valid-app-shapes ctrct))] [(->*2 . _) - (values (->*2-handled? ctrct) + (values (and (->*2-handled? ctrct) + (not (->2*-arity-check-only->? ctrct))) (->*-valid-app-shapes ctrct))] [(->i . _) (values #t (->i-valid-app-shapes ctrct))] [_ (values #f #f)])) @@ -384,36 +377,25 @@ ;; ... -> (or/c #f (-> blame val)) (define (do-partial-app ctc val name pos-module-source source) - (define p (contract-struct-val-first-projection ctc)) + (define p (parameterize ([warn-about-val-first? #f]) + ;; when we're building the val-first projection + ;; here we might be needing the plus1 arity + ;; function (which will be on the val first's result) + ;; so this is a legtimate use. don't warn. + (get/build-val-first-projection ctc))) (define blme (make-blame (build-source-location source) name (λ () (contract-name ctc)) pos-module-source #f #t)) + (define neg-accepter ((p blme) val)) - (cond - [p - (define neg-accepter ((p blme) val)) - - ;; we don't have the negative blame here, but we - ;; expect only positive failures from this; do the - ;; check and then toss the results. - (neg-accepter 'incomplete-blame-from-provide.rkt) - - neg-accepter] - [else - (define proj (contract-struct-projection ctc)) - - ;; we don't have the negative blame here, but we - ;; expect only positive failures from this; do the - ;; check and then toss the results. - ((proj blme) val) - - (procedure-rename - (λ (neg-party) - (define complete-blame (blame-add-missing-party blme neg-party)) - ((proj complete-blame) val)) - (string->symbol (format "provide.rkt:neg-party-fn:~s" (contract-name ctc))))])) + ;; we don't have the negative blame here, but we + ;; expect only positive failures from this; do the + ;; check and then toss the results. + (neg-accepter 'incomplete-blame-from-provide.rkt) + + neg-accepter) (define-for-syntax (true-provide/contract provide-stx just-check-errors? who) (syntax-case provide-stx () @@ -930,9 +912,11 @@ ;; directly here in the expansion makes this very expensive at compile time ;; when there are a lot of provide/contract clause using structs (define -struct:struct-name - (make-pc-struct-type 'struct-name + (make-pc-struct-type #,pos-module-source-id + 'struct-name struct-name-srcloc struct:struct-name + '(#,@field-names) field-contract-ids ...)) (provide (rename-out [-struct:struct-name struct:struct-name])))))))))) @@ -1135,9 +1119,18 @@ (define-syntax (provide/contract-for-contract-out stx) (provide/contract-for-whom stx 'contract-out)) -(define (make-pc-struct-type struct-name srcloc struct:struct-name . ctcs) +(define (make-pc-struct-type pos-module-source struct-name srcloc struct-type field-names . ctcs) + (define blame + (make-blame (build-source-location srcloc) struct-type (λ () `(substruct-of ,struct-name)) + pos-module-source #f #t)) + (define late-neg-acceptors + (for/list ([ctc (in-list ctcs)] + [field-name (in-list field-names)]) + ((get/build-late-neg-projection ctc) + (blame-add-context blame + (format "the ~a field of" field-name))))) (chaperone-struct-type - struct:struct-name + struct-type (λ (a b c d e f g h) (values a b c d e f g h)) (λ (x) x) (λ args @@ -1151,12 +1144,7 @@ null] [else (cons (car args) (loop (cdr args)))]))) (apply values - (map (λ (ctc val) - (contract ctc - val - 'not-enough-info-for-blame - 'not-enough-info-for-blame - name - srcloc)) - ctcs + (map (λ (late-neg-acceptors val) + (late-neg-acceptors val 'not-enough-info-for-blame)) + late-neg-acceptors vals))))) diff --git a/racket/collects/racket/contract/private/struct-dc.rkt b/racket/collects/racket/contract/private/struct-dc.rkt index a9a0be9096..b422a1e69f 100644 --- a/racket/collects/racket/contract/private/struct-dc.rkt +++ b/racket/collects/racket/contract/private/struct-dc.rkt @@ -223,7 +223,7 @@ (define (struct/dc-first-order ctc) (base-struct/dc-pred ctc)) -(define (struct/dc-proj ctc) +(define (struct/dc-late-neg-proj ctc) (define pred? (base-struct/dc-pred ctc)) (λ (blame) (define orig-blames @@ -240,7 +240,7 @@ (define ctxt-string (format "the ~a field of" (subcontract-field-name subcontract))) (blame-add-context blame ctxt-string #:swap? #t)] [else #f]))) - (define orig-indy-blames + (define orig-indy-blames (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]) (and (subcontract? subcontract) (blame-replace-negative @@ -260,7 +260,7 @@ (cond [(indep? subcontract) (define sub-ctc (indep-ctc subcontract)) - ((contract-projection sub-ctc) blame+ctxt)] + ((get/build-late-neg-projection sub-ctc) blame+ctxt)] [else #f]))) (define mut-projs (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] @@ -268,7 +268,7 @@ (cond [(and (indep? subcontract) (mutable? subcontract)) (define sub-ctc (indep-ctc subcontract)) - ((contract-projection sub-ctc) blame+ctxt)] + ((get/build-late-neg-projection sub-ctc) blame+ctxt)] [else #f]))) (define orig-indy-projs (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] @@ -276,7 +276,7 @@ (cond [(indep? subcontract) (define sub-ctc (indep-ctc subcontract)) - ((contract-projection sub-ctc) blame+ctxt)] + ((get/build-late-neg-projection sub-ctc) blame+ctxt)] [else #f]))) (define orig-mut-indy-projs (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] @@ -284,16 +284,17 @@ (cond [(indep? subcontract) (define sub-ctc (indep-ctc subcontract)) - ((contract-projection sub-ctc) blame+ctxt)] + ((get/build-late-neg-projection sub-ctc) blame+ctxt)] [else #f]))) - (λ (v) + (λ (v neg-party) (cond [(and (struct/c-imp-prop-pred? v) - (contract-stronger? (struct/c-imp-prop-get v) ctc)) + (contract-struct-stronger? (struct/c-imp-prop-get v) ctc)) v] [else (unless (pred? v) - (raise-blame-error blame v '(expected: "~a?" given: "~e") + (raise-blame-error blame #:missing-party neg-party + v '(expected: "~a?" given: "~e") (base-struct/dc-struct-name ctc) v)) (define invariant (for/or ([c (in-list (base-struct/dc-subcontracts ctc))]) @@ -319,7 +320,7 @@ v impersonate-args) (if invariant - (add-invariant-checks blame invariant chaperone-args) + (add-invariant-checks blame neg-party invariant chaperone-args) chaperone-args))] [else (define subcontract (car subcontracts)) ;; (or/c subcontract? invariant?) @@ -338,20 +339,21 @@ 'struct/dc (apply (dep-dep-proc subcontract) dep-args)))) (when dep-ctc (check-flat/chaperone dep-ctc subcontract)) - (define dep-ctc-blame-proj (and dep-ctc (contract-projection dep-ctc))) + (define dep-ctc-blame-proj (and dep-ctc (get/build-late-neg-projection dep-ctc))) (define-values (new-chaperone-args new-impersonate-args) (cond [(invariant? subcontract) - (unless (with-continuation-mark contract-continuation-mark-key blame - (apply (invariant-dep-proc subcontract) dep-args)) - (raise-invariant-blame-failure blame v + (unless (with-contract-continuation-mark + (cons blame neg-party) + (apply (invariant-dep-proc subcontract) dep-args)) + (raise-invariant-blame-failure blame neg-party v (reverse dep-args) (reverse (invariant-fields subcontract)))) (values chaperone-args impersonate-args)] [(immutable? subcontract) - (define (chk fld v) (with-continuation-mark - contract-continuation-mark-key blame - (proj v))) + (define (chk fld v) (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) (chk #f (sel v)) ;; check the field contract immediately (values (if (flat-contract? (indep-ctc subcontract)) chaperone-args @@ -360,9 +362,9 @@ [(lazy-immutable? subcontract) (values (list* sel (cache-λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) chaperone-args) impersonate-args)] [(mutable? subcontract) @@ -370,34 +372,34 @@ (values chaperone-args (list* sel (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) (mutable-set subcontract) (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (mut-proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (mut-proj v neg-party))) impersonate-args)) (values (list* sel (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) (mutable-set subcontract) (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (mut-proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (mut-proj v neg-party))) chaperone-args) impersonate-args))] [else (define proj (dep-ctc-blame-proj blame)) (cond [(dep-immutable? subcontract) - (define (chk fld v) (with-continuation-mark - contract-continuation-mark-key blame - (proj v))) + (define (chk fld v) (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) (chk #f (sel v)) ;; check the field contract immediately (values (if (flat-contract? dep-ctc) chaperone-args @@ -406,9 +408,9 @@ [(dep-lazy-immutable? subcontract) (values (list* sel (cache-λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) chaperone-args) impersonate-args)] [(dep-mutable? subcontract) @@ -416,51 +418,53 @@ (if (equal? (dep-type subcontract) '#:impersonator) (values (list* sel (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) (dep-mutable-set subcontract) (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (mut-proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (mut-proj v neg-party))) chaperone-args) impersonate-args) (values chaperone-args (list* sel (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (proj v neg-party))) (dep-mutable-set subcontract) (λ (fld v) - (with-continuation-mark - contract-continuation-mark-key blame - (mut-proj v))) + (with-contract-continuation-mark + (cons blame neg-party) + (mut-proj v neg-party))) impersonate-args)))] [(dep-on-state-immutable? subcontract) - (proj (sel v)) + (proj (sel v) neg-party) (values (list* sel (λ (strct val) - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + (cons blame neg-party) (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct - orig-indy-projs orig-indy-blames blame val))) + orig-indy-projs orig-indy-blames blame neg-party val))) chaperone-args) impersonate-args)] [(dep-on-state-mutable? subcontract) - (proj (sel v)) + (proj (sel v) neg-party) (define (get-chap-proc strct val) - (with-continuation-mark - contract-continuation-mark-key blame + (with-contract-continuation-mark + (cons blame neg-party) (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct - orig-indy-projs orig-indy-blames blame val))) + orig-indy-projs orig-indy-blames blame neg-party + val))) (define (set-chap-proc strct val) - (with-continuation-mark contract-continuation-mark-key blame - (build-dep-on-state-proj - (base-struct/dc-subcontracts ctc) subcontract strct - orig-mut-indy-projs orig-mut-indy-blames mut-blame val))) + (with-contract-continuation-mark + (cons blame neg-party) + (build-dep-on-state-proj + (base-struct/dc-subcontracts ctc) subcontract strct + orig-mut-indy-projs orig-mut-indy-blames mut-blame neg-party val))) (if (eq? (dep-type subcontract) '#:impersonator) (values chaperone-args (list* sel @@ -481,12 +485,14 @@ new-impersonate-args (if (and (subcontract? subcontract) (subcontract-depended-on? subcontract)) (cons (if dep-ctc-blame-proj - ((dep-ctc-blame-proj indy-blame) ((subcontract-ref subcontract) v)) - (indy-proj ((subcontract-ref subcontract) v))) + ((dep-ctc-blame-proj indy-blame) + ((subcontract-ref subcontract) v) + neg-party) + (indy-proj ((subcontract-ref subcontract) v) neg-party)) dep-args) dep-args))]))])))) -(define (check-invariant/mut blame invariant val sel field-v) +(define (check-invariant/mut blame neg-party invariant val sel field-v) (define args (let loop ([sels (invariant-sels invariant)] [args '()]) @@ -498,15 +504,15 @@ (loop (cdr sels) (cons field-v args)) (loop (cdr sels) (cons (sel val) args)))]))) (unless (apply (invariant-dep-proc invariant) args) - (raise-invariant-blame-failure (blame-swap blame) val + (raise-invariant-blame-failure (blame-swap blame) neg-party val (reverse args) (reverse (invariant-fields invariant))))) -(define (raise-invariant-blame-failure blame v vals field-names) +(define (raise-invariant-blame-failure blame neg-party v vals field-names) (raise-blame-error - blame - v + blame #:missing-party neg-party + v "#:inv does not hold~a" (apply string-append @@ -515,7 +521,7 @@ [field-name (in-list field-names)]) (format "\n ~a: ~e" field-name dep-arg))))) -(define (add-invariant-checks blame invariant chaperone-args) +(define (add-invariant-checks blame neg-party invariant chaperone-args) (let loop ([invariant-field-sels/muts (for/list ([sel (in-list (invariant-sels invariant))] [mut (in-list (invariant-muts invariant))] @@ -531,7 +537,7 @@ (define mut (cdr sel/mut)) (list mut (λ (stct field-v) - (check-invariant/mut blame invariant stct sel field-v) + (check-invariant/mut blame neg-party invariant stct sel field-v) field-v))))] [else (define fn (car chaperone-args)) @@ -548,7 +554,7 @@ [which (list* fn (λ (stct field-v) - (check-invariant/mut blame invariant stct sel field-v) + (check-invariant/mut blame neg-party invariant stct sel field-v) (proc stct field-v)) (loop (remove-ith invariant-field-sels/muts which) (cddr chaperone-args)))] @@ -565,7 +571,8 @@ (cdr l) (cons (car l) (remove-ith (cdr l) (- i 1))))])) -(define (build-dep-on-state-proj orig-subcontracts this-subcontract strct projs blames blame val) +(define (build-dep-on-state-proj orig-subcontracts this-subcontract strct projs + blames blame neg-party val) (let loop ([subcontracts orig-subcontracts] [blames blames] [projs projs] @@ -582,7 +589,7 @@ (define the-ctc (coerce-contract 'struct/dc (apply (dep-dep-proc this-subcontract) dep-args))) (check-flat/chaperone the-ctc subcontract) - (((contract-projection the-ctc) blame) val)] + (((get/build-late-neg-projection the-ctc) blame) val neg-party)] [else (define indy-blame (car blames)) (define proj (car projs)) @@ -591,7 +598,7 @@ (coerce-contract 'struct/dc (apply (dep-dep-proc subcontract) dep-args)))) - (define dep-ctc-blame-proj (and dep-ctc (contract-projection dep-ctc))) + (define dep-ctc-blame-proj (and dep-ctc (get/build-late-neg-projection dep-ctc))) (when (dep? subcontract) (check-flat/chaperone dep-ctc subcontract)) @@ -599,8 +606,10 @@ (define new-dep-args (if (and (subcontract? subcontract) (subcontract-depended-on? subcontract)) (cons (if dep-ctc-blame-proj - ((dep-ctc-blame-proj indy-blame) ((subcontract-ref subcontract) strct)) - (proj ((subcontract-ref subcontract) strct))) + ((dep-ctc-blame-proj indy-blame) + ((subcontract-ref subcontract) strct) + neg-party) + (proj ((subcontract-ref subcontract) strct) neg-party)) dep-args) dep-args)) (loop (cdr subcontracts) @@ -644,8 +653,8 @@ (immutable? that-subcontract)) (and (lazy-immutable? this-subcontract) (lazy-immutable? that-subcontract))) - (contract-stronger? (indep-ctc this-subcontract) - (indep-ctc that-subcontract)))] + (contract-struct-stronger? (indep-ctc this-subcontract) + (indep-ctc that-subcontract)))] [(and (dep? this-subcontract) (dep? that-subcontract)) (and (or (dep-mutable? this-subcontract) @@ -678,36 +687,33 @@ (define-struct (struct/dc base-struct/dc) () #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:name struct/dc-name - #:first-order struct/dc-first-order - #:projection struct/dc-proj - #:stronger struct/dc-stronger? - #:generate struct/dc-generate - #:exercise struct/dc-exercise))) + (build-chaperone-contract-property + #:name struct/dc-name + #:first-order struct/dc-first-order + #:late-neg-projection struct/dc-late-neg-proj + #:stronger struct/dc-stronger? + #:generate struct/dc-generate + #:exercise struct/dc-exercise)) (define-struct (flat-struct/dc base-struct/dc) () #:property prop:flat-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-flat-contract-property - #:name struct/dc-name - #:first-order struct/dc-flat-first-order - #:projection struct/dc-proj - #:stronger struct/dc-stronger? - #:generate struct/dc-generate - #:exercise struct/dc-exercise))) + (build-flat-contract-property + #:name struct/dc-name + #:first-order struct/dc-flat-first-order + #:late-neg-projection struct/dc-late-neg-proj + #:stronger struct/dc-stronger? + #:generate struct/dc-generate + #:exercise struct/dc-exercise)) (define-struct (impersonator-struct/dc base-struct/dc) () #:property prop:contract - (parameterize ([skip-projection-wrapper? #t]) - (build-contract-property - #:name struct/dc-name - #:first-order struct/dc-first-order - #:projection struct/dc-proj - #:stronger struct/dc-stronger? - #:generate struct/dc-generate - #:exercise struct/dc-exercise))) + (build-contract-property + #:name struct/dc-name + #:first-order struct/dc-first-order + #:late-neg-projection struct/dc-late-neg-proj + #:stronger struct/dc-stronger? + #:generate struct/dc-generate + #:exercise struct/dc-exercise)) (define (build-struct/dc subcontracts constructor pred struct-name here name-info struct/c?) (for ([subcontract (in-list subcontracts)]) @@ -1412,24 +1418,28 @@ #:exp ;; if this is #t, when we have to avoid putting the property on here. (if (null? s-chap-code) - #`(if (pred? #,(opt/info-val opt/info)) - (begin - #,@s-fo-code - #,(opt/info-val opt/info)) - (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)) - #`(if (and (stronger-prop-pred? #,(opt/info-val opt/info)) - (let ([v (stronger-prop-get #,(opt/info-val opt/info))]) - (and (eq? (vector-ref v index) free-var) ...))) - #,(opt/info-val opt/info) - (if (pred? #,(opt/info-val opt/info)) - (begin - #,@s-fo-code - (chaperone-struct - #,(opt/info-val opt/info) - #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here - stronger-prop-desc - (vector free-var ...))) - (struct/dc-error #,(opt/info-blame opt/info) #,(opt/info-val opt/info) 'struct-name)))) + #`(with-contract-continuation-mark + #,(opt/info-blame opt/info) + (if (pred? #,(opt/info-val opt/info)) + (begin + #,@s-fo-code + #,(opt/info-val opt/info)) + (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name))) + #`(with-contract-continuation-mark + #,(opt/info-blame opt/info) + (if (and (stronger-prop-pred? #,(opt/info-val opt/info)) + (let ([v (stronger-prop-get #,(opt/info-val opt/info))]) + (and (eq? (vector-ref v index) free-var) ...))) + #,(opt/info-val opt/info) + (if (pred? #,(opt/info-val opt/info)) + (begin + #,@s-fo-code + (chaperone-struct + #,(opt/info-val opt/info) + #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here + stronger-prop-desc + (vector free-var ...))) + (struct/dc-error #,(opt/info-blame opt/info) #,(opt/info-val opt/info) 'struct-name))))) #:lifts s-lifts #:superlifts @@ -1446,7 +1456,8 @@ (blame-add-context blame (format "the ~a field of" fld))) (define (struct/dc-error blame obj what) - (raise-blame-error blame obj + (raise-blame-error blame + obj '(expected: "a struct of type ~a") what)) diff --git a/racket/collects/racket/contract/private/struct-prop.rkt b/racket/collects/racket/contract/private/struct-prop.rkt index 52ee2345b9..b468aa215f 100644 --- a/racket/collects/racket/contract/private/struct-prop.rkt +++ b/racket/collects/racket/contract/private/struct-prop.rkt @@ -1,27 +1,26 @@ #lang racket/base (require "guts.rkt" "blame.rkt" - "prop.rkt" - "misc.rkt") + "prop.rkt") (provide (rename-out [struct-type-property/c* struct-type-property/c])) -(define (get-stpc-proj stpc) - (define get-val-proj - (contract-projection +(define (get-stpc-late-neg-proj stpc) + (define get-late-neg-proj + (get/build-late-neg-projection (struct-type-property/c-value-contract stpc))) (λ (input-blame) (define blame (blame-add-context input-blame "the struct property value of" #:swap? #t)) - (define val-proj (get-val-proj blame)) - (λ (x) + (define late-neg-proj (get-late-neg-proj blame)) + (λ (x neg-party) (unless (struct-type-property? x) - (raise-blame-error input-blame x + (raise-blame-error input-blame x #:neg-party '(expected "struct-type-property" given: "~e") x)) (define-values (nprop _pred _acc) (make-struct-type-property (wrap-name x) (lambda (val _info) - (val-proj val)) + (late-neg-proj val neg-party)) (list (cons x values)))) nprop))) @@ -37,7 +36,7 @@ 'struct-type-property/c (struct-type-property/c-value-contract c))) #:first-order (lambda (c) struct-type-property?) - #:projection get-stpc-proj)) + #:late-neg-projection get-stpc-late-neg-proj)) (define struct-type-property/c* (let ([struct-type-property/c diff --git a/racket/collects/racket/contract/private/types.rkt b/racket/collects/racket/contract/private/types.rkt new file mode 100644 index 0000000000..d625f2da65 --- /dev/null +++ b/racket/collects/racket/contract/private/types.rkt @@ -0,0 +1,10 @@ +#lang racket/base +(provide types) +(define types + (hash '(real-and/c-name racket/contract/private/misc) + '(->* () #:rest Contract Contract) + + '(or/c-name racket/contract/private/orc) + '(->* () #:rest Contract Contract))) + +;; cast : alpha ( ctc) -> beta \ No newline at end of file diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index f5db23de87..f0bcf66865 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -62,10 +62,15 @@ (fail val '(expected "an mutable vector" given: "~e" val)))] [else (void)]) (when first-order? - (for ([e (in-vector val)] - [n (in-naturals)]) - (unless (contract-first-order-passes? elem-ctc e) - (fail val '(expected: "~s for element ~s" given: "~e") (contract-name elem-ctc) n e)))) + (let loop ([n 0]) + (cond + [(= n (vector-length val)) + (void)] + [else + (define e (vector-ref val n)) + (unless (contract-first-order-passes? elem-ctc e) + (fail val '(expected: "~s for element ~s" given: "~e") (contract-name elem-ctc) n e)) + (contract-first-order-try-less-hard (loop (+ n 1)))]))) #t))) (define (check-late-neg-vectorof c) @@ -109,12 +114,12 @@ (cond [(and (equal? this-immutable #t) (equal? that-immutable #t)) - (contract-stronger? this-elem that-elem)] + (contract-struct-stronger? this-elem that-elem)] [else (and (or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) - (contract-stronger? this-elem that-elem) - (contract-stronger? that-elem this-elem))])] + (contract-struct-stronger? this-elem that-elem) + (contract-struct-stronger? that-elem this-elem))])] [else #f])) (define-struct (flat-vectorof base-vectorof) () @@ -134,20 +139,7 @@ (for ([x (in-vector val)]) (vfp+blame x neg-party)) val))) - #:stronger vectorof-stronger - #:projection - (λ (ctc) - (define check (check-vectorof ctc)) - (λ (blame) - (define raise-blame (λ (val . args) (apply raise-blame-error blame val args))) - (define ele-blame (blame-add-element-of-context blame)) - (λ (val) - (check val raise-blame #f) - (let* ([elem-ctc (base-vectorof-elem ctc)] - [p ((contract-projection elem-ctc) ele-blame)]) - (for ([e (in-vector val)]) - (p e))) - val))))) + #:stronger vectorof-stronger)) (define (blame-add-element-of-context blame #:swap? [swap? #f]) (blame-add-context blame "an element of" #:swap? swap?)) @@ -165,66 +157,51 @@ (define elem-neg-proj (vfp neg-blame)) (define checked-ref (λ (neg-party) (λ (vec i val) - (with-continuation-mark contract-continuation-mark-key + (with-contract-continuation-mark (cons pos-blame neg-party) (elem-pos-proj val neg-party))))) (define checked-set (λ (neg-party) (λ (vec i val) - (with-continuation-mark contract-continuation-mark-key + (with-contract-continuation-mark (cons neg-blame neg-party) (elem-neg-proj val neg-party))))) - - (λ (val neg-party) - (define (raise-blame val . args) - (apply raise-blame-error blame #:missing-party neg-party val args)) - (check val raise-blame #f) - (if (and (immutable? val) (not (chaperone? val))) - (apply vector-immutable - (for/list ([e (in-vector val)]) - (elem-pos-proj e neg-party))) - (chaperone-or-impersonate-vector - val - (checked-ref neg-party) - (checked-set neg-party) - impersonator-prop:contracted ctc - impersonator-prop:blame (blame-add-missing-party blame neg-party))))))) + (cond + [(flat-contract? elem-ctc) + (define p? (flat-contract-predicate elem-ctc)) + (λ (val neg-party) + (define (raise-blame val . args) + (apply raise-blame-error blame #:missing-party neg-party val args)) + (check val raise-blame #f) + (if (and (immutable? val) (not (chaperone? val))) + (begin (for ([e (in-vector val)]) + (unless (p? e) + (elem-pos-proj e neg-party))) + val) + (chaperone-or-impersonate-vector + val + (checked-ref neg-party) + (checked-set neg-party) + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party))))] + [else + (λ (val neg-party) + (define (raise-blame val . args) + (apply raise-blame-error blame #:missing-party neg-party val args)) + (check val raise-blame #f) + (if (and (immutable? val) (not (chaperone? val))) + (vector->immutable-vector + (for/vector #:length (vector-length val) ([e (in-vector val)]) + (elem-pos-proj e neg-party))) + (chaperone-or-impersonate-vector + val + (checked-ref neg-party) + (checked-set neg-party) + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party))))])))) (define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get) (make-impersonator-property 'prop:neg-blame-party)) -(define (vectorof-ho-projection vector-wrapper) - (λ (ctc) - (let ([elem-ctc (base-vectorof-elem ctc)] - [immutable (base-vectorof-immutable ctc)] - [check (check-vectorof ctc)]) - (λ (blame) - (let ([elem-pos-proj ((contract-projection elem-ctc) - (blame-add-element-of-context blame))] - [elem-neg-proj ((contract-projection elem-ctc) - (blame-add-element-of-context blame #:swap? #t))]) - (define checked-ref (λ (vec i val) - (with-continuation-mark - contract-continuation-mark-key blame - (elem-pos-proj val)))) - (define checked-set (λ (vec i val) - (with-continuation-mark - contract-continuation-mark-key blame - (elem-neg-proj val)))) - (define raise-blame (λ (val . args) - (apply raise-blame-error blame val args))) - (λ (val) - (check val raise-blame #f) - (if (and (immutable? val) (not (chaperone? val))) - (apply vector-immutable - (for/list ([e (in-vector val)]) - (elem-pos-proj e))) - (vector-wrapper - val - checked-ref - checked-set - impersonator-prop:contracted ctc - impersonator-prop:blame blame)))))))) - (define-struct (chaperone-vectorof base-vectorof) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract @@ -232,8 +209,7 @@ #:name vectorof-name #:first-order vectorof-first-order #:stronger vectorof-stronger - #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector) - #:projection (vectorof-ho-projection chaperone-vector))) + #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector))) (define-struct (impersonator-vectorof base-vectorof) () #:property prop:custom-write custom-write-property-proc @@ -242,8 +218,7 @@ #:name vectorof-name #:first-order vectorof-first-order #:stronger vectorof-stronger - #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector) - #:projection (vectorof-ho-projection impersonate-vector))) + #:late-neg-projection (vectorof-late-neg-ho-projection impersonate-vector))) (define-syntax (wrap-vectorof stx) (syntax-case stx () @@ -296,26 +271,28 @@ (list '#:immutable immutable) null))))) -(define (check-vector/c ctc val blame) +(define (check-vector/c ctc val blame neg-party) (define elem-ctcs (base-vector/c-elems ctc)) (define immutable (base-vector/c-immutable ctc)) (unless (vector? val) - (raise-blame-error blame val '(expected: "a vector" given: "~e") val)) + (raise-blame-error blame #:missing-party neg-party val + '(expected: "a vector" given: "~e") val)) (cond [(eq? immutable #t) (unless (immutable? val) - (raise-blame-error blame val + (raise-blame-error blame #:missing-party neg-party val '(expected: "an immutable vector" given: "~e") val))] [(eq? immutable #f) (when (immutable? val) - (raise-blame-error blame val + (raise-blame-error blame #:missing-party neg-party val '(expected: "a mutable vector" given: "~e") val))] [else (void)]) (define elem-count (length elem-ctcs)) (unless (= (vector-length val) elem-count) - (raise-blame-error blame val '(expected: "a vector of ~a element~a" given: "~e") + (raise-blame-error blame #:missing-party neg-party val + '(expected: "a vector of ~a element~a" given: "~e") elem-count (if (= elem-count 1) "" "s") val))) @@ -348,14 +325,14 @@ (and (= (length this-elems) (length that-elems)) (for/and ([this-elem (in-list this-elems)] [that-elem (in-list that-elems)]) - (contract-stronger? this-elem that-elem)))] + (contract-struct-stronger? this-elem that-elem)))] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) (and (= (length this-elems) (length that-elems)) (for/and ([this-elem (in-list this-elems)] [that-elem (in-list that-elems)]) - (and (contract-stronger? this-elem that-elem) - (contract-stronger? that-elem this-elem))))] + (and (contract-struct-stronger? this-elem that-elem) + (contract-struct-stronger? that-elem this-elem))))] [else #f])] [(base-vectorof? that) (define that-elem (base-vectorof-elem that)) @@ -364,12 +341,12 @@ [(and (equal? this-immutable #t) (equal? that-immutable #t)) (for/and ([this-elem (in-list this-elems)]) - (contract-stronger? this-elem that-elem))] + (contract-struct-stronger? this-elem that-elem))] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) (for/and ([this-elem (in-list this-elems)]) - (and (contract-stronger? this-elem that-elem) - (contract-stronger? that-elem this-elem)))] + (and (contract-struct-stronger? this-elem that-elem) + (contract-struct-stronger? that-elem this-elem)))] [else #f])] [else #f])) @@ -380,21 +357,24 @@ #:name vector/c-name #:first-order vector/c-first-order #:stronger vector/c-stronger - #:projection + #:late-neg-projection (λ (ctc) (λ (blame) (define blame+ctxt (blame-add-element-of-context blame)) - (λ (val) - (with-continuation-mark - contract-continuation-mark-key blame + (define val+np-acceptors + (for/list ([c (in-list (base-vector/c-elems ctc))]) + ((get/build-late-neg-projection c) blame+ctxt))) + (λ (val neg-party) + (with-contract-continuation-mark + (cons blame neg-party) (begin - (check-vector/c ctc val blame) + (check-vector/c ctc val blame neg-party) (for ([e (in-vector val)] - [c (in-list (base-vector/c-elems ctc))]) - (((contract-projection c) blame+ctxt) e)) + [p (in-list val+np-acceptors)]) + (p e neg-party)) val))))))) -(define (vector/c-ho-projection vector-wrapper) +(define (vector/c-ho-late-neg-projection vector-wrapper) (λ (ctc) (let ([elem-ctcs (base-vector/c-elems ctc)] [immutable (base-vector/c-immutable ctc)]) @@ -402,31 +382,31 @@ (let ([elem-pos-projs (for/vector #:length (length elem-ctcs) ([c (in-list elem-ctcs)] [i (in-naturals)]) - ((contract-projection c) + ((get/build-late-neg-projection c) (blame-add-context blame (format "the ~a element of" (n->th i)))))] [elem-neg-projs (for/vector #:length (length elem-ctcs) ([c (in-list elem-ctcs)] [i (in-naturals)]) - ((contract-projection c) + ((get/build-late-neg-projection c) (blame-add-context blame (format "the ~a element of" (n->th i)) #:swap? #t)))]) - (λ (val) - (check-vector/c ctc val blame) + (λ (val neg-party) + (check-vector/c ctc val blame neg-party) (if (and (immutable? val) (not (chaperone? val))) (apply vector-immutable (for/list ([e (in-vector val)] [i (in-naturals)]) - ((vector-ref elem-pos-projs i) e))) + ((vector-ref elem-pos-projs i) e neg-party))) (vector-wrapper val (λ (vec i val) - (with-continuation-mark - contract-continuation-mark-key blame - ((vector-ref elem-pos-projs i) val))) + (with-contract-continuation-mark + (cons blame neg-party) + ((vector-ref elem-pos-projs i) val neg-party))) (λ (vec i val) - (with-continuation-mark - contract-continuation-mark-key blame - ((vector-ref elem-neg-projs i) val))) + (with-contract-continuation-mark + (cons blame neg-party) + ((vector-ref elem-neg-projs i) val neg-party))) impersonator-prop:contracted ctc impersonator-prop:blame blame)))))))) @@ -437,7 +417,7 @@ #:name vector/c-name #:first-order vector/c-first-order #:stronger vector/c-stronger - #:projection (vector/c-ho-projection chaperone-vector))) + #:late-neg-projection (vector/c-ho-late-neg-projection chaperone-vector))) (define-struct (impersonator-vector/c base-vector/c) () #:property prop:custom-write custom-write-property-proc @@ -446,7 +426,7 @@ #:name vector/c-name #:first-order vector/c-first-order #:stronger vector/c-stronger - #:projection (vector/c-ho-projection impersonate-vector))) + #:late-neg-projection (vector/c-ho-late-neg-projection impersonate-vector))) (define-syntax (wrap-vector/c stx) (syntax-case stx () diff --git a/racket/collects/racket/file.rkt b/racket/collects/racket/file.rkt index 206c85fdc4..ffc28d1df6 100644 --- a/racket/collects/racket/file.rkt +++ b/racket/collects/racket/file.rkt @@ -213,7 +213,7 @@ (delete-file path))) (let ([bp (current-break-parameterization)] [tmp-path (parameterize ([current-security-guard (or guard (current-security-guard))]) - (make-temporary-file "tmp~a" #f (path-only path)))] + (make-temporary-file "tmp~a" #f (or (path-only path) (current-directory))))] [ok? #f]) (dynamic-wind void @@ -244,11 +244,14 @@ (parameterize ([read-case-sensitive #f] [read-square-bracket-as-paren #t] [read-curly-brace-as-paren #t] + [read-square-bracket-with-tag #f] + [read-curly-brace-with-tag #f] [read-accept-box #t] [read-accept-compiled #f] [read-accept-bar-quote #t] [read-accept-graph #t] [read-decimal-as-inexact #t] + [read-cdot #f] [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t] @@ -636,24 +639,37 @@ (define (to-path s) (if (path? s) s (string->path s))) (if path (do-path (to-path path) init) (do-paths (directory-list) init))) -(define (find-files f [path #f] #:follow-links? [follow-links? #t]) +(define (find-files f [path #f] + #:follow-links? [follow-links? #t] + #:skip-filtered-directory? [skip-filtered-directory? #f]) (reverse - (fold-files (lambda (path kind acc) (if (f path) (cons path acc) acc)) + (fold-files (lambda (path kind acc) (if (f path) + (cons path acc) + (if (and skip-filtered-directory? + (eq? kind 'dir)) + (values acc #f) + acc))) null path follow-links?))) -(define (pathlist-closure paths #:follow-links? [follow-links? #f]) +(define (pathlist-closure paths + #:follow-links? [follow-links? #f] + #:path-filter [path-filter #f]) (let loop ([paths (map (lambda (p) (simplify-path - (if (and follow-links? - (link-exists? p)) - (let ([p2 (resolve-path p)]) - (if (relative-path? p2) - (let-values ([(base name dir?) (split-path p)]) - (build-path base p2)) - p2)) - p) + (let loop ([p p]) + (if (and follow-links? + (link-exists? p)) + (let ([p2 (resolve-path p)]) + (if (relative-path? p2) + (let-values ([(base name dir?) (split-path p)]) + (loop ((if dir? path->directory-path values) + (if (path? base) + (build-path base p2) + p2)))) + (loop p2))) + p)) #f)) paths)] [r '()]) @@ -666,7 +682,10 @@ [(file-exists? (car paths)) (list (car paths))] [(directory-exists? (car paths)) - (find-files void (car paths) #:follow-links? follow-links?)] + (find-files (or path-filter void) + (path->directory-path (car paths)) + #:skip-filtered-directory? #t + #:follow-links? follow-links?)] [else (error 'pathlist-closure "file/directory not found: ~a" (car paths))])]) diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index af8e535ab8..fbc9e01944 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -271,8 +271,7 @@ (define/with-syntax pred predicate) (define/with-syntax [ctc-id ...] (generate-temporaries #'(ctc-expr ...))) - (define/with-syntax [proj-id ...] - (generate-temporaries #'(ctc-expr ...))) + (define/with-syntax (late-neg-proj-id ...) (generate-temporaries #'(ctc-expr ...))) #'(let* ([ctc-id ctc-expr] ...) (make-generics-contract 'gen-name @@ -280,19 +279,21 @@ pred '(method-id ...) (list ctc-id ...) - (lambda (b x mode) - (redirect-generics/derived - original - mode - gen-name ref-gen-id - x - [method-id - (lambda (m) - (define b2 - (blame-add-context b (format "method ~a" 'method-id))) - (((contract-projection ctc-id) b2) m))] - ... - null)))))])) + (λ (mode late-neg-proj-id ...) + (λ (x neg-party) + (redirect-generics/derived + original + mode + gen-name ref-gen-id + x + [method-id + (lambda (m) + (late-neg-proj-id m neg-party))] + ... + null))))))])) + +(define (blame-add-method-context blame method-id) + (blame-add-context blame (format "method ~a" method-id))) (define (make-generics-contract ifc pfx pred mths ctcs proc) (define chaperoning? @@ -320,22 +321,26 @@ (define (generics-contract-first-order ctc) (generics-contract-predicate ctc)) -(define (generics-contract-projection mode) +(define (generics-late-neg-contract-projection mode) (lambda (c) - (lambda (b) - (lambda (x) - ((generics-contract-redirect c) b x mode))))) + (define mk-late-neg-projs (map contract-late-neg-projection (generics-contract-contracts c))) + (lambda (blame) + (define late-neg-projs + (for/list ([m (in-list (generics-contract-methods c))] + [mk-late-neg-proj (in-list mk-late-neg-projs)]) + (mk-late-neg-proj (blame-add-method-context blame m)))) + (apply (generics-contract-redirect c) mode late-neg-projs)))) (struct chaperone-generics-contract generics-contract [] #:property prop:chaperone-contract (build-chaperone-contract-property #:name generics-contract-name #:first-order generics-contract-first-order - #:projection (generics-contract-projection #t))) + #:late-neg-projection (generics-late-neg-contract-projection #t))) (struct impersonator-generics-contract generics-contract [] #:property prop:contract (build-contract-property #:name generics-contract-name #:first-order generics-contract-first-order - #:projection (generics-contract-projection #f))) + #:late-neg-projection (generics-late-neg-contract-projection #f))) diff --git a/racket/collects/racket/list.rkt b/racket/collects/racket/list.rkt index 1717f6f57c..89f5906154 100644 --- a/racket/collects/racket/list.rkt +++ b/racket/collects/racket/list.rkt @@ -45,6 +45,8 @@ append-map filter-not shuffle + combinations + in-combinations permutations in-permutations argmin @@ -588,6 +590,84 @@ (vector-set! a j x)) (vector->list a)) +(define (combinations l [k #f]) + (for/list ([x (in-combinations l k)]) x)) + +;; Generate combinations of the list `l`. +;; - If `k` is a natural number, generate all combinations of size `k`. +;; - If `k` is #f, generate all combinations of any size (powerset of `l`). +(define (in-combinations l [k #f]) + (unless (list? l) + (raise-argument-error 'in-combinations "list?" 0 l)) + (when (and k (not (exact-nonnegative-integer? k))) + (raise-argument-error 'in-combinations "exact-nonnegative-integer?" 1 k)) + (define v (list->vector l)) + (define N (vector-length v)) + (define N-1 (- N 1)) + (define gen-combinations + (cond + [(not k) + ;; Enumerate all binary numbers [1..2**N]. + ;; Produce the combination with elements in `v` at the same + ;; positions as the 1's in the binary number. + (define limit (expt 2 N)) + (define curr-box (box 0)) + (lambda () + (let ([curr (unbox curr-box)]) + (if (< curr limit) + (begin0 + (for/fold ([acc '()]) + ([i (in-range N-1 -1 -1)]) + (if (bitwise-bit-set? curr i) + (cons (vector-ref v i) acc) + acc)) + (set-box! curr-box (+ curr 1))) + #f)))] + [(< N k) + (lambda () #f)] + [else + ;; Keep a vector `k*` that contains `k` indices + ;; Use `k*` to generate combinations + (define k* #f) ; (U #f (Vectorof Index)) + (define k-1 (- k 1)) + ;; `k*-incr` tries to increment the positions in `k*`. + ;; On success, can use `k*` to build a combination. + ;; Returns #f on failure. + (define (k*-incr) + (cond + [(not k*) + ;; 1. Initialize the vector `k*` to the first {0..k-1} indices + (set! k* (build-vector k (lambda (i) i)))] + [(zero? k) + ;; (Cannot increment a zero vector) + #f] + [else + (or + ;; 2. Try incrementing the leftmost index that is + ;; at least 2 less than the following index in `k*`. + (for/or ([i (in-range 0 k-1)]) + (let ([k*_i (vector-ref k* i)] + [k*_i+1 (vector-ref k* (+ i 1))]) + (and (< k*_i (- k*_i+1 1)) + (vector-set! k* i (+ k*_i 1))))) + ;; 3. Increment the rightmost index, up to a max of `N-1`. + ;; Also replace the first `k-1` indices to `[0..k-2]` + (let ([k*_last (vector-ref k* k-1)]) + (if (< k*_last N-1) + (begin + (vector-set! k* k-1 (+ k*_last 1)) + (for ([i (in-range k-1)]) + (vector-set! k* i i))) + #f)))])) + (define (k*->combination) + ;; Get the `k` elements indexed by `k*` + (for/fold ([acc '()]) + ([i (in-range k-1 -1 -1)]) + (cons (vector-ref v (vector-ref k* i)) acc))) + (lambda () + (and (k*-incr) (k*->combination)))])) + (in-producer gen-combinations #f)) + ;; This implements an algorithm known as "Ord-Smith". (It is described in a ;; paper called "Permutation Generation Methods" by Robert Sedgewlck, listed as ;; Algorithm 8.) It has a number of good properties: it is very fast, returns diff --git a/racket/collects/racket/match/define-forms.rkt b/racket/collects/racket/match/define-forms.rkt index 2189982368..a3e438461b 100644 --- a/racket/collects/racket/match/define-forms.rkt +++ b/racket/collects/racket/match/define-forms.rkt @@ -55,8 +55,9 @@ (syntax-parse stx [(_ arg:expr (~and cl0 [(pats ...) rhs ...]) clauses ...) (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))]) - #`(let-values ([(ids ...) arg]) - (match*/derived (ids ...) #,stx cl0 clauses ...)))])) + (quasisyntax/loc stx + (let-values ([(ids ...) arg]) + (match*/derived (ids ...) #,stx cl0 clauses ...))))])) (define-syntax (match-lambda stx) (syntax-parse stx @@ -89,20 +90,23 @@ [rhs (syntax->list #'(rhss ...))]) (define ids (generate-temporaries pats)) (values ids #`[#,ids #,rhs]))) - #`(let-values #,let-clauses + (quasisyntax/loc stx + (let-values #,let-clauses (match*/derived #,(append* idss) #,stx - [(patss ... ...) (let () body1 body ...)]))])) + [(patss ... ...) (let () body1 body ...)])))])) (define-syntax (match-let*-values stx) (syntax-parse stx [(_ () body1 body ...) - #'(let () body1 body ...)] + (syntax/loc stx (let () body1 body ...))] [(_ ([(pats ...) rhs] rest-pats ...) body1 body ...) (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))]) - #`(let-values ([(ids ...) rhs]) + (quasisyntax/loc stx + (let-values ([(ids ...) rhs]) (match*/derived (ids ...) #,stx - [(pats ...) #,(syntax/loc stx (match-let*-values (rest-pats ...) - body1 body ...))])))])) + [(pats ...) #,(syntax/loc stx + (match-let*-values (rest-pats ...) + body1 body ...))]))))])) ;; there's lots of duplication here to handle named let ;; some factoring out would do a lot of good @@ -111,12 +115,14 @@ [(_ nm:id (~and clauses ([pat init-exp:expr] ...)) body1 body ...) (with-syntax* ([vars (generate-temporaries #'(pat ...))] - [loop-body #`(match*/derived vars #,stx - [(pat ...) (let () body1 body ...)])]) - #'(letrec ([nm (lambda vars loop-body)]) - (nm init-exp ...)))] + [loop-body (quasisyntax/loc stx + (match*/derived vars #,stx + [(pat ...) (let () body1 body ...)]))]) + (syntax/loc stx + (letrec ([nm (lambda vars loop-body)]) + (nm init-exp ...))))] [(_ ([pat init-exp:expr] ...) body1 body ...) - #`(match-let-values ([(pat) init-exp] ...) body1 body ...)])) + (syntax/loc stx (match-let-values ([(pat) init-exp] ...) body1 body ...))])) (define-syntax-rule (match-let* ([pat exp] ...) body1 body ...) (match-let*-values ([(pat) exp] ...) body1 body ...)) diff --git a/racket/collects/racket/match/gen-match.rkt b/racket/collects/racket/match/gen-match.rkt index 5e9b2d9be9..c395db09b4 100644 --- a/racket/collects/racket/match/gen-match.rkt +++ b/racket/collects/racket/match/gen-match.rkt @@ -2,7 +2,7 @@ (require "patterns.rkt" "compiler.rkt" syntax/stx syntax/parse racket/syntax - (for-template racket/base (only-in "runtime.rkt" match:error fail))) + (for-template racket/base (only-in "runtime.rkt" match:error fail syntax-srclocs))) (provide go go/one) @@ -33,17 +33,13 @@ (syntax-e #'fname)] [_ 'match])) (define len (length (syntax->list es))) - (define srcloc-list (list #`(quote #,(syntax-source stx)) - #`(quote #,(syntax-line stx)) - #`(quote #,(syntax-column stx)) - #`(quote #,(syntax-position stx)) - #`(quote #,(syntax-span stx)))) + (define srcloc-stx (datum->syntax #f 'srcloc stx)) (define/with-syntax (xs ...) (generate-temporaries es)) (define/with-syntax (exprs ...) es) (define/with-syntax outer-fail (generate-temporary #'fail)) (define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))) (define/with-syntax raise-error - (quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name))) + (quasisyntax/loc stx (match:error orig-expr (syntax-srclocs (quote-syntax #,srcloc-stx)) 'form-name))) (define parsed-clauses (for/list ([clause (syntax->list clauses)] [pats (syntax->list #'(pats ...))] diff --git a/racket/collects/racket/match/parse-helper.rkt b/racket/collects/racket/match/parse-helper.rkt index 3b5508f870..5614f36a04 100644 --- a/racket/collects/racket/match/parse-helper.rkt +++ b/racket/collects/racket/match/parse-helper.rkt @@ -125,13 +125,27 @@ => (lambda (ps) (unless (= (length ps) (length acc)) - (raise-syntax-error - 'match - (format "~a structure ~a: expected ~a but got ~a" - "wrong number for fields for" - (syntax->datum struct-name) (length acc) - (length ps)) - stx pats)) + (when (< (length acc) (length ps)) + (raise-syntax-error + 'match + (format "~a structure ~a: expected ~a but got ~a" + "excess number of fields for" + (syntax->datum struct-name) (length acc) + (length ps)) + stx pats)) + (when (> (length acc) (length ps)) + (raise-syntax-error + 'match + (format "~a structure ~a: expected ~a but got ~a; ~a ~a" + "insufficient number of fields for" + (syntax->datum struct-name) (length acc) + (length ps) + "missing fields" + (list-tail + (for/list [(i (in-list acc))] + (symbol->string (syntax->datum i))) + (length ps))) + stx pats))) (map parse ps))] [else (raise-syntax-error 'match diff --git a/racket/collects/racket/match/runtime.rkt b/racket/collects/racket/match/runtime.rkt index fad9d05615..59a13b73b8 100644 --- a/racket/collects/racket/match/runtime.rkt +++ b/racket/collects/racket/match/runtime.rkt @@ -9,7 +9,8 @@ fail matchable? match-prompt-tag - mlist? mlist->list) + mlist? mlist->list + syntax-srclocs) (define match-prompt-tag (make-continuation-prompt-tag 'match)) @@ -58,3 +59,10 @@ (cond [(null? l) null] [else (cons (mcar l) (mlist->list (mcdr l)))])) + +(define (syntax-srclocs stx) + (list (srcloc (syntax-source stx) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx)))) diff --git a/racket/collects/racket/place.rkt b/racket/collects/racket/place.rkt index e62cb8e71b..b5886c63b6 100644 --- a/racket/collects/racket/place.rkt +++ b/racket/collects/racket/place.rkt @@ -10,6 +10,8 @@ racket/place/private/th-place racket/place/private/prop racket/private/streams + racket/match + racket/runtime-path (for-syntax racket/base @@ -185,7 +187,7 @@ (syntax-case stx () [(who ch body1 body ...) (if (eq? (syntax-local-context) 'module-begin) - ;; when a `place' form is the only thing in a module mody: + ;; when a `place' form is the only thing in a module body: #`(begin #,stx) ;; normal case: (let () @@ -199,10 +201,14 @@ (string->symbol (format "place-body-~a" place-body-counter)))) (with-syntax ([internal-def-name - (syntax-local-lift-module #`(module* #,module-name-stx #f - (provide main) - (define (main ch) - body1 body ...)))] + (syntax-local-lift-module + #`(module* #,module-name-stx #f + (provide main) + (define (main ch) + body1 body ...) + ;; The existence of this submodule makes the + ;; enclosing submodule preserved by `raco exe`: + (module declare-preserve-for-embedding '#%kernel)))] [in _in] [out _out] [err _err] @@ -233,12 +239,17 @@ (when (and (symbol? name) (not (module-predefined? `(quote ,name)))) (error who "the enclosing module's resolved name is not a path or predefined")) - (start-place-func who `(submod ,(if (symbol? name) `(quote ,name) name) ,submod-name) 'main in out err)) + (define submod-ref + (match name + [(? symbol?) `(submod (quote ,name) ,submod-name)] + [(? path?) `(submod ,name ,submod-name)] + [`(,p ,s ...) `(submod ,(if (symbol? p) `(quote ,p) p) ,@s ,submod-name)])) + (start-place-func who submod-ref 'main in out err)) (define-syntax (place/context stx) (syntax-parse stx [(_ ch:id body:expr ...) - (define b #'(let () body ...)) + (define b #'(lambda (ch) body ...)) (define/with-syntax b* (local-expand b 'expression null)) (define/with-syntax (fvs ...) (free-vars #'b*)) (define/with-syntax (i ...) (for/list ([(v i) (in-indexed (syntax->list #'(fvs ...)))]) i)) @@ -246,7 +257,7 @@ #'(let () (define p (place ch (let* ([v (place-channel-get ch)] [fvs (vector-ref v i)] ...) - b*))) + (b* ch)))) (define vec (vector fvs ...)) (for ([e (in-vector vec)] [n (in-list (syntax->list (quote-syntax (fvs ...))))]) diff --git a/racket/collects/racket/private/class-c-new.rkt b/racket/collects/racket/private/class-c-new.rkt index 4835068886..abcb0e5549 100644 --- a/racket/collects/racket/private/class-c-new.rkt +++ b/racket/collects/racket/private/class-c-new.rkt @@ -160,7 +160,7 @@ (ext-class/c-contract-opaque? this) (ext-class/c-contract-name this))) (λ (neg-party) - (((class/c-proj ctc) (blame-add-missing-party blame neg-party)) cls))] + (((class/c-late-neg-proj ctc) blame) cls neg-party))] [else (build-neg-acceptor-proc this maybe-err blame cls #f '() (make-hasheq) (make-hasheq))])] @@ -176,7 +176,8 @@ (define mth->idx (class-method-ht cls)) (define mtd-vec (class-methods cls)) - (define internal-proj (internal-class/c-proj (ext-class/c-contract-internal-ctc this))) + (define internal-late-neg-proj + (internal-class/c-late-neg-proj (ext-class/c-contract-internal-ctc this))) ;; The #f may survive if the method is just-check-existence or ;; if the contract doesn't mention the method (and it isn't opaque) @@ -330,8 +331,7 @@ ;; on the class only when it is ;; time to instantiate it; not here (define class+one-property/adjusted - (chaperone-struct ((internal-proj (blame-add-missing-party blame neg-party)) - cls) + (chaperone-struct ((internal-late-neg-proj blame) cls neg-party) set-class-orig-cls! (λ (a b) b) impersonator-prop:wrapped-class-info the-info)) diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt index cb2a2be7f7..22e31cf62d 100644 --- a/racket/collects/racket/private/class-c-old.rkt +++ b/racket/collects/racket/private/class-c-old.rkt @@ -10,7 +10,7 @@ "../contract/combinator.rkt" (only-in "../contract/private/arrow.rkt" making-a-method method-contract?)) -(provide make-class/c class/c-proj +(provide make-class/c class/c-late-neg-proj blame-add-method-context blame-add-field-context blame-add-init-context class/c ->m ->*m ->dm case->m object/c instanceof/c make-wrapper-object @@ -18,7 +18,7 @@ (for-syntax parse-class/c-specs) (struct-out internal-class/c) just-check-existence just-check-existence? - build-internal-class/c internal-class/c-proj + build-internal-class/c internal-class/c-late-neg-proj class/c-internal-name-clauses dynamic-object/c) @@ -143,31 +143,31 @@ #t) -(define (class/c-proj ctc) - (define ep (class/c-external-proj ctc)) - (define ip (internal-class/c-proj (class/c-internal ctc))) +(define (class/c-late-neg-proj ctc) + (define ep (class/c-external-late-neg-proj ctc)) + (define ip (internal-class/c-late-neg-proj (class/c-internal ctc))) (λ (blame) (define eb (ep blame)) (define ib (ip blame)) - (λ (val) - (ib (eb val))))) + (λ (val neg-party) + (ib (eb val neg-party) neg-party)))) -(define (class/c-external-proj ctc) +(define (class/c-external-late-neg-proj ctc) (define ctc-methods (class/c-methods ctc)) (λ (blame) (define public-method-projections (for/list ([name (in-list ctc-methods)] [c (in-list (class/c-method-contracts ctc))]) (and c - ((contract-projection c) (blame-add-method-context blame name))))) + ((contract-late-neg-projection c) (blame-add-method-context blame name))))) (define external-field-projections (for/list ([f (in-list (class/c-fields ctc))] [c (in-list (class/c-field-contracts ctc))]) (and c - (let ([p-pos ((contract-projection c) + (let ([p-pos ((contract-late-neg-projection c) (blame-add-field-context blame f #:swap? #f))] - [p-neg ((contract-projection c) + [p-neg ((contract-late-neg-projection c) (blame-add-field-context blame f #:swap? #t))]) (cons p-pos p-neg))))) @@ -176,12 +176,14 @@ (for/list ([init (in-list (class/c-inits ctc))] [ctc (in-list (class/c-init-contracts ctc))]) (if ctc - (list init ((contract-projection ctc) + (list init ((contract-late-neg-projection ctc) (blame-add-init-context blame init))) (list init #f)))) - (λ (cls) - (class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args))) + (λ (cls neg-party) + (class/c-check-first-order + ctc cls + (λ args (apply raise-blame-error blame #:missing-party neg-party cls args))) (let* ([name (class-name cls)] [never-wrapped? (eq? (class-orig-cls cls) cls)] ;; Only add a new slot if we're not projecting an already contracted class. @@ -296,7 +298,9 @@ ;; we're passing through a contract boundary, so the positive blame (aka ;; value server) is taking responsibility for any interface-contracted ;; methods) - (define info (replace-ictc-blame (cadr entry) #f (blame-positive blame))) + (define info (replace-ictc-blame + (cadr entry) #f + (blame-positive (blame-add-missing-party blame neg-party)))) (vector-set! methods i (concretize-ictc-method m (car entry) info))))) ;; Now apply projections (for ([m (in-list ctc-methods)] @@ -304,7 +308,7 @@ (when p (define i (hash-ref method-ht m)) (define mp (vector-ref methods i)) - (vector-set! methods i (make-method (p mp) m))))) + (vector-set! methods i (make-method (p mp neg-party) m))))) ;; Handle external field contracts (unless no-field-ctcs? @@ -314,7 +318,7 @@ (define fi (hash-ref field-ht f)) (define p-pos (car p-pr)) (define p-neg (cdr p-pr)) - (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))) + (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg neg-party))))) ;; Unlike the others, we always want to do this, even if there are no init contracts, ;; since we still need to handle either calling the previous class/c's init or @@ -351,7 +355,7 @@ (loop (cdr init-args) (cdr inits/c) (cons (cons (car init-arg) (if p - (p (cdr init-arg)) + (p (cdr init-arg) neg-party) (cdr init-arg))) handled-args)))] [else (loop (cdr init-args) @@ -376,7 +380,7 @@ (copy-seals cls c))))) -(define (internal-class/c-proj internal-ctc) +(define (internal-class/c-late-neg-proj internal-ctc) (define dynamic-features (append (internal-class/c-overrides internal-ctc) (internal-class/c-augments internal-ctc) @@ -393,26 +397,27 @@ (for/list ([name (in-list (internal-class/c-supers internal-ctc))] [c (in-list (internal-class/c-super-contracts internal-ctc))]) (and c - ((contract-projection c) (blame-add-method-context blame name))))) + ((contract-late-neg-projection c) (blame-add-method-context blame name))))) (define inner-projections (for/list ([name (in-list (internal-class/c-inners internal-ctc))] [c (in-list (internal-class/c-inner-contracts internal-ctc))]) (and c - ((contract-projection c) (blame-add-method-context bswap name))))) + ((contract-late-neg-projection c) (blame-add-method-context bswap name))))) (define internal-field-projections (for/list ([f (in-list (internal-class/c-inherit-fields internal-ctc))] [c (in-list (internal-class/c-inherit-field-contracts internal-ctc))]) (and c - (let ([p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bswap)]) + (let* ([blame-acceptor (contract-late-neg-projection c)] + [p-pos (blame-acceptor blame)] + [p-neg (blame-acceptor bswap)]) (cons p-pos p-neg))))) (define override-projections (for/list ([m (in-list (internal-class/c-overrides internal-ctc))] [c (in-list (internal-class/c-override-contracts internal-ctc))]) (and c - ((contract-projection c) (blame-add-method-context bswap m))))) + ((contract-late-neg-projection c) (blame-add-method-context bswap m))))) (define augment/augride-projections (for/list ([m (in-list (append (internal-class/c-augments internal-ctc) @@ -420,17 +425,19 @@ [c (in-list (append (internal-class/c-augment-contracts internal-ctc) (internal-class/c-augride-contracts internal-ctc)))]) (and c - ((contract-projection c) (blame-add-method-context blame m))))) + ((contract-late-neg-projection c) (blame-add-method-context blame m))))) (define inherit-projections (for/list ([m (in-list (internal-class/c-inherits internal-ctc))] [c (in-list (internal-class/c-inherit-contracts internal-ctc))]) (and c - ((contract-projection c) (blame-add-method-context blame m))))) - (λ (cls) + ((contract-late-neg-projection c) (blame-add-method-context blame m))))) + (λ (cls neg-party) (internal-class/c-check-first-order internal-ctc cls - (λ args (apply raise-blame-error blame cls args))) + (λ args (apply raise-blame-error + #:missing-party neg-party + blame cls args))) (let* ([name (class-name cls)] [never-wrapped? (eq? (class-orig-cls cls) cls)] @@ -563,7 +570,7 @@ (when p (define i (hash-ref method-ht m)) (define mp (vector-ref super-methods i)) - (vector-set! super-methods i (make-method (p mp) m))))) + (vector-set! super-methods i (make-method (p mp neg-party) m))))) ;; Add inner projections (unless (null? (internal-class/c-inners internal-ctc)) @@ -573,7 +580,7 @@ (when p (define i (hash-ref method-ht m)) (define old-proj (vector-ref inner-projs i)) - (vector-set! inner-projs i (λ (v) (old-proj (p v))))))) + (vector-set! inner-projs i (λ (v) (old-proj (p v neg-party))))))) ;; Handle external field contracts (unless no-field-ctcs? @@ -583,7 +590,7 @@ (define fi (hash-ref field-ht f)) (define p-pos (car p-pr)) (define p-neg (cdr p-pr)) - (hash-set! field-ht f (field-info-extend-internal fi p-pos p-neg))))) + (hash-set! field-ht f (field-info-extend-internal fi p-pos p-neg neg-party))))) ;; Now the trickiest of them all, internal dynamic dispatch. ;; First we update any dynamic indexes, as applicable. @@ -628,7 +635,7 @@ [old-idx (vector-ref old-idxs i)] [proj-vec (vector-ref dynamic-projs i)] [old-proj (vector-ref proj-vec old-idx)]) - (vector-set! proj-vec old-idx (λ (v) (old-proj (p v)))))))) + (vector-set! proj-vec old-idx (λ (v) (old-proj (p v neg-party)))))))) ;; For augment and augride contracts, we both update the projection ;; and go ahead and apply the projection to the last slot (which will @@ -645,9 +652,9 @@ [proj-vec (vector-ref dynamic-projs i)] [int-vec (vector-ref int-methods i)] [old-proj (vector-ref proj-vec old-idx)]) - (vector-set! proj-vec old-idx (λ (v) (p (old-proj v)))) + (vector-set! proj-vec old-idx (λ (v) (p (old-proj v) neg-party))) (vector-set! int-vec new-idx - (make-method (p (vector-ref int-vec new-idx)) m)))))) + (make-method (p (vector-ref int-vec new-idx) neg-party) m)))))) ;; Now (that things have been extended appropriately) we handle ;; inherits. @@ -659,7 +666,7 @@ [new-idx (vector-ref dynamic-idxs i)] [int-vec (vector-ref int-methods i)]) (vector-set! int-vec new-idx - (make-method (p (vector-ref int-vec new-idx)) m))))))) + (make-method (p (vector-ref int-vec new-idx) neg-party) m))))))) ;; Unlike the others, we always want to do this, even if there are no init contracts, ;; since we still need to handle either calling the previous class/c's init or @@ -943,7 +950,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection class/c-proj + #:late-neg-projection class/c-late-neg-proj #:name build-class/c-name #:stronger class/c-stronger #:first-order @@ -1207,23 +1214,26 @@ #:key (compose symbol->string car))) (values (map car sorted) (map cdr sorted))) -(define (instanceof/c-proj ctc) +(define (instanceof/c-late-neg-proj ctc) (define proj (if (base-instanceof/c? ctc) - (contract-projection (base-instanceof/c-class-ctc ctc)) - (object/c-class-proj ctc))) + (contract-late-neg-projection (base-instanceof/c-class-ctc ctc)) + (object/c-late-neg-class-proj ctc))) (λ (blame) (define p (proj (blame-add-context blame #f))) - (λ (val) + (λ (val neg-party) (unless (object? val) - (raise-blame-error blame val '(expected: "an object" given: "~e") val)) + (raise-blame-error blame #:missing-party neg-party + val '(expected: "an object" given: "~e") val)) (when (base-object/c? ctc) (check-object-contract val (base-object/c-methods ctc) (base-object/c-fields ctc) - (λ args (apply raise-blame-error blame val args)))) + (λ args (apply raise-blame-error blame #:missing-party neg-party + val args)))) (define original-obj (if (has-original-object? val) (original-object val) val)) - (define new-cls (p (object-ref val))) + (define new-cls (p (object-ref val) neg-party)) + (define p-closed-over-neg-party (λ (v) (p v neg-party))) (cond [(impersonator-prop:has-wrapped-class-neg-party? new-cls) (define the-info (impersonator-prop:get-wrapped-class-info new-cls)) @@ -1266,7 +1276,7 @@ '()))) (define all-new-projs - (cons p + (cons p-closed-over-neg-party (if (has-impersonator-prop:instanceof/c-projs? val) (get-impersonator-prop:instanceof/c-projs val) '()))) @@ -1375,7 +1385,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection instanceof/c-proj + #:late-neg-projection instanceof/c-late-neg-proj #:name (λ (ctc) (build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc))) @@ -1411,15 +1421,15 @@ method-names (coerce-contracts 'dynamic-object/c method-contracts) field-names (coerce-contracts 'dynamic-object/c field-contracts))) -(define (object/c-class-proj ctc) +(define (object/c-late-neg-class-proj ctc) (define methods (base-object/c-methods ctc)) (define method-contracts (base-object/c-method-contracts ctc)) (define fields (base-object/c-fields ctc)) (define field-contracts (base-object/c-field-contracts ctc)) (λ (blame) - (λ (val) + (λ (val neg-party) (make-wrapper-class - val blame + val blame neg-party methods method-contracts fields field-contracts)))) (define (check-object-contract obj methods fields fail) @@ -1477,7 +1487,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection instanceof/c-proj + #:late-neg-projection instanceof/c-late-neg-proj #:name (λ (ctc) (let* ([pair-ids-ctcs @@ -1515,21 +1525,21 @@ (let bindings (make-base-object/c methods method-ctcs fields field-ctcs)))))])) -;; make-wrapper-object: contract object blame +;; make-wrapper-object: contract object blame neg-party ;; (listof symbol) (listof contract?) (listof symbol) (listof contract?) ;; -> wrapped object -(define (make-wrapper-object ctc obj blame methods method-contracts fields field-contracts) +(define (make-wrapper-object ctc obj blame neg-party methods method-contracts fields field-contracts) (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args))) (let ([original-obj (if (has-original-object? obj) (original-object obj) obj)] [new-cls (make-wrapper-class (object-ref obj) ;; TODO: object-ref audit - blame + blame neg-party methods method-contracts fields field-contracts)]) (impersonate-struct obj object-ref (λ (o c) new-cls) ;; TODO: object-ref audit impersonator-prop:contracted ctc impersonator-prop:original-object original-obj))) -(define (make-wrapper-class cls blame methods method-contracts fields field-contracts) +(define (make-wrapper-class cls blame neg-party methods method-contracts fields field-contracts) (let* ([name (class-name cls)] [method-width (class-method-width cls)] [method-ht (class-method-ht cls)] @@ -1625,9 +1635,10 @@ [c (in-list method-contracts)]) (when c (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) (blame-add-context blame (format "the ~a method in" m) - #:important m))]) - (vector-set! meths i (make-method (p (vector-ref meths i)) m)))))) + [p ((contract-late-neg-projection c) + (blame-add-context blame (format "the ~a method in" m) + #:important m))]) + (vector-set! meths i (make-method (p (vector-ref meths i) neg-party) m)))))) ;; Handle external field contracts (unless (null? fields) @@ -1635,8 +1646,9 @@ [c (in-list field-contracts)]) (unless (just-check-existence? c) (define fi (hash-ref field-ht f)) - (define p-pos ((contract-projection c) (blame-add-field-context blame f #:swap? #f))) - (define p-neg ((contract-projection c) (blame-add-field-context blame f #:swap? #t))) - (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))) + (define prj (contract-late-neg-projection c)) + (define p-pos (prj (blame-add-field-context blame f #:swap? #f))) + (define p-neg (prj (blame-add-field-context blame f #:swap? #t))) + (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg neg-party))))) (copy-seals cls c))) diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt index 083f7c9589..0c53c99176 100644 --- a/racket/collects/racket/private/class-internal.rkt +++ b/racket/collects/racket/private/class-internal.rkt @@ -19,6 +19,7 @@ syntax/flatten-begin syntax/private/boundmap syntax/parse + syntax/intdef "classidmap.rkt")) (define insp (current-inspector)) ; for all opaque structures @@ -291,21 +292,21 @@ [field-set! (make-struct-field-mutator (class-field-set! cls) rpos)]) (vector field-ref field-set! field-ref field-set!))) -(define (field-info-extend-internal fi ppos pneg) +(define (field-info-extend-internal fi ppos pneg neg-party) (let* ([old-ref (unsafe-vector-ref fi 0)] [old-set! (unsafe-vector-ref fi 1)]) - (vector (λ (o) (ppos (old-ref o))) - (λ (o v) (old-set! o (pneg v))) + (vector (λ (o) (ppos (old-ref o) neg-party)) + (λ (o v) (old-set! o (pneg v neg-party))) (unsafe-vector-ref fi 2) (unsafe-vector-ref fi 3)))) -(define (field-info-extend-external fi ppos pneg) +(define (field-info-extend-external fi ppos pneg neg-party) (let* ([old-ref (unsafe-vector-ref fi 2)] [old-set! (unsafe-vector-ref fi 3)]) (vector (unsafe-vector-ref fi 0) (unsafe-vector-ref fi 1) - (λ (o) (ppos (old-ref o))) - (λ (o v) (old-set! o (pneg v)))))) + (λ (o) (ppos (old-ref o) neg-party)) + (λ (o v) (old-set! o (pneg v neg-party)))))) (define (field-info-internal-ref fi) (unsafe-vector-ref fi 0)) (define (field-info-internal-set! fi) (unsafe-vector-ref fi 1)) @@ -958,23 +959,25 @@ ;; of a class). It doesn't use syntax-track-origin because there is ;; no residual code that it would make sense to be the result of expanding ;; those away. So, instead we only look at a few properties (as below). + ;; Also, add 'disappeared-binding properties from `ctx`. (define (add-decl-props stx) - (for/fold ([stx stx]) - ([decl (in-list (append inspect-decls decls))]) - (define (copy-prop src dest stx) - (syntax-property - stx - dest - (cons (syntax-property decl src) - (syntax-property stx dest)))) - (copy-prop - 'origin 'disappeared-use + (internal-definition-context-track + def-ctx + (for/fold ([stx stx]) + ([decl (in-list (append inspect-decls decls))]) + (define (copy-prop src dest stx) + (syntax-property + stx + dest + (cons (syntax-property decl src) + (syntax-property stx dest)))) (copy-prop - 'disappeared-use 'disappeared-use + 'origin 'disappeared-use (copy-prop - 'disappeared-binding 'disappeared-binding - stx))))) - + 'disappeared-use 'disappeared-use + (copy-prop + 'disappeared-binding 'disappeared-binding + stx)))))) ;; At most one inspect: (unless (or (null? inspect-decls) (null? (cdr inspect-decls))) diff --git a/racket/collects/racket/private/define-struct.rkt b/racket/collects/racket/private/define-struct.rkt index b5c7bb727e..9a8a80be04 100644 --- a/racket/collects/racket/private/define-struct.rkt +++ b/racket/collects/racket/private/define-struct.rkt @@ -323,7 +323,7 @@ (when (lookup config '#:constructor-name) (bad "multiple" "#:constructor-name or #:extra-constructor-name" "s" (car p))) (unless (identifier? (cadr p)) - (bad "need an identifier after" (car p) (cadr p))) + (bad "need an identifier after" (car p) "" (cadr p))) (loop (cddr p) (extend-config (extend-config config '#:constructor-name (cadr p)) '#:only-constructor? diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index 340c4a6bd2..d3fb990084 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/racket/collects/racket/private/generic.rkt @@ -231,8 +231,8 @@ id)) (unless (pair? matches) (wrong-syntax sig-stx - "did not find ~a among ~a to ~s" - "the generic name" + "did not find ~a \"~a\" among ~a to ~s" + "the generic name" (syntax-e self-id) "the required, by-position arguments" (syntax-e name-stx))) (when (pair? (cdr matches)) diff --git a/racket/collects/racket/private/kw.rkt b/racket/collects/racket/private/kw.rkt index 98a85577f3..14eef699e8 100644 --- a/racket/collects/racket/private/kw.rkt +++ b/racket/collects/racket/private/kw.rkt @@ -1611,16 +1611,15 @@ (lambda results (let* ([len (length results)] [alen (length rest)]) - (unless (<= (+ alen 1) len (+ alen 2)) + (when (< len (+ alen 1)) (raise-arguments-error '|keyword procedure chaperone| "wrong number of results from wrapper procedure" "expected minimum number of results" (+ alen 1) - "expected maximum number of results" (+ alen 2) "received number of results" len "wrapper procedure" wrap-proc)) - (let ([extra? (= len (+ alen 2))]) - (let ([new-args ((if extra? cadr car) results)]) + (let ([num-extra (- len (+ alen 1))]) + (let ([new-args (list-ref results num-extra)]) (unless (and (list? new-args) (= (length new-args) (length args))) (raise-arguments-error @@ -1629,7 +1628,7 @@ "expected a list of keyword-argument values as first result~a from wrapper procedure" (if (= len alen) "" - " (after the result-wrapper procedure)")) + " (after the result-wrapper procedure or mark specifications)")) "first result" new-args "wrapper procedure" wrap-proc)) (for-each @@ -1646,9 +1645,13 @@ kws new-args args)) - (if extra? - (apply values (car results) kws (cdr results)) - (apply values kws results))))))] + (case num-extra + [(0) (apply values kws results)] + [(1) (apply values (car results) kws (cdr results))] + [else (apply values (let loop ([results results] [c num-extra]) + (if (zero? c) + (cons kws results) + (cons (car results) (loop (cdr results) (sub1 c))))))])))))] ;; The following case exists only to make sure that the arity of ;; any procedure passed to `make-keyword-args' is covered ;; by this procedure's arity. diff --git a/racket/collects/racket/private/name.rkt b/racket/collects/racket/private/name.rkt index 26c5b98609..9a9ccec647 100644 --- a/racket/collects/racket/private/name.rkt +++ b/racket/collects/racket/private/name.rkt @@ -7,7 +7,8 @@ (case-lambda [(stx use-local?) (let-values ([(prop) (simplify-inferred-name (syntax-property stx 'inferred-name))]) - (or (and (symbol? prop) + (or (and prop + (not (void? prop)) prop) (let ([n (and use-local? (not (void? prop)) diff --git a/racket/collects/racket/private/pre-base.rkt b/racket/collects/racket/private/pre-base.rkt index e695d4bf08..f8a5474981 100644 --- a/racket/collects/racket/private/pre-base.rkt +++ b/racket/collects/racket/private/pre-base.rkt @@ -17,6 +17,7 @@ "member.rkt" "kernstruct.rkt" "norm-arity.rkt" + "performance-hint.rkt" "top-int.rkt" '#%builtin ; so it's attached (for-syntax "kw.rkt" @@ -97,6 +98,51 @@ (define-values (double-flonum?) ; for symmetry with single-flonum? (lambda (x) (flonum? x))) + (define-values (enforce-random-int-range) + (lambda (x) + (unless (and (exact-positive-integer? x) + (<= x 4294967087)) + (raise-argument-error 'random "(integer-in 1 4294967087)" x)))) + (define-values (enforce-greater) + (lambda (x y) + (unless (> y x) + (raise-argument-error + 'random + (string-append "integer greater than " (number->string x)) + y)))) + (begin-encourage-inline + (define-values (-random) ; more featureful than #%kernel's `random` + (let ([random ; to get the right name + (case-lambda + [() (random)] ; no args, random float + [(x) ; one arg, either random float with prng, or random integer + ;; can just pass through to #%kernel's `random`, which will do the + ;; necessary checking + (random x)] + [(x y) + ;; two args, either max and prng, or min and max + (cond [(exact-positive-integer? y) ; min and max case + (enforce-random-int-range x) + (enforce-random-int-range y) + (enforce-greater x y) + (+ x (random (- y x)))] + [(pseudo-random-generator? y) ; int and prng case + (enforce-random-int-range x) + (random x y)] + [else + (raise-argument-error + 'random + "(or/c (integer-in 1 4294967087) pseudo-random-generator?)" + y)])] + [(min max prng) ; three args: min, max, and prng + (enforce-random-int-range min) + (enforce-random-int-range max) + (enforce-greater min max) + (unless (pseudo-random-generator? prng) + (raise-argument-error 'random "pseudo-random-generator?" prng)) + (+ min (random (- max min) prng))])]) + random))) + (define-values (new:collection-path) (let ([collection-path (new-lambda (collection #:fail [fail (lambda (s) @@ -184,7 +230,8 @@ chaperone-procedure impersonate-procedure chaperone-procedure* impersonate-procedure* assq assv assoc - prop:incomplete-arity prop:method-arity-error) + prop:incomplete-arity prop:method-arity-error + random) (all-from "reqprov.rkt") (all-from-except "for.rkt" define-in-vector-like @@ -207,4 +254,5 @@ define-struct/derived struct-field-index struct-copy - double-flonum?)) + double-flonum? + (rename -random random))) diff --git a/racket/collects/racket/private/set-types.rkt b/racket/collects/racket/private/set-types.rkt index dbb587617f..cce77ae187 100644 --- a/racket/collects/racket/private/set-types.rkt +++ b/racket/collects/racket/private/set-types.rkt @@ -28,7 +28,10 @@ make-custom-set-types make-custom-set make-weak-custom-set - make-mutable-custom-set) + make-mutable-custom-set + + chaperone-hash-set + impersonate-hash-set) (define (custom-set-empty? s) (dprintf "custom-set-empty?\n") @@ -335,6 +338,191 @@ [(hash-weak? table) (weak-custom-set (custom-set-spec s) table)] [else (mutable-custom-set (custom-set-spec s) table)])) +(define (chaperone-hash-set s inject-proc add-proc shrink-proc extract-proc . clear-proc+props) + (define-values (clear-proc equal-key-proc prop-args) + (check-chap/imp-args #f s inject-proc add-proc shrink-proc extract-proc clear-proc+props)) + (define (check-it who original new) + (unless (chaperone-of? new original) + (error 'chaperone-hash-set + "~s did not return a chaperone of ~e, got ~e" + who original new)) + new) + + (add-impersonator-properties + (if inject-proc + (chap-or-imp-hash-set s + chaperone-hash + (λ (ele) (check-it 'in-proc ele (inject-proc s ele))) + (λ (ele) (check-it 'add-proc ele (add-proc s ele))) + (λ (ele) (check-it 'shrink-proc ele (shrink-proc s ele))) + (λ (ele) (check-it 'extract-proc ele (extract-proc s ele))) + (and clear-proc (λ () (clear-proc s))) + (λ (ele) (equal-key-proc s ele))) + s) + prop-args)) + +(define (impersonate-hash-set s inject-proc add-proc shrink-proc extract-proc . clear-proc+props) + (define-values (clear-proc equal-key-proc prop-args) + (check-chap/imp-args #t s inject-proc add-proc shrink-proc extract-proc clear-proc+props)) + (add-impersonator-properties + (if inject-proc + (chap-or-imp-hash-set s + impersonate-hash + (λ (ele) (inject-proc s ele)) + (λ (ele) (add-proc s ele)) + (λ (ele) (shrink-proc s ele)) + (λ (ele) (extract-proc s ele)) + (and clear-proc (λ () (clear-proc s))) + (λ (ele) (equal-key-proc s ele))) + s) + prop-args)) + +(define (chap-or-imp-hash-set s c-or-i-hash + inject-proc add-proc shrink-proc extract-proc + clear-proc equal-key-proc) + (update-custom-set-table + s + (cond + [(custom-set-spec s) + (define rewrap (custom-spec-wrap (custom-set-spec s))) + (c-or-i-hash + (custom-set-table s) + (λ (hash key) (values (rewrap (inject-proc (custom-elem-contents key))) + (λ (hash key val) val))) + (λ (hash key val) (values (rewrap (add-proc (custom-elem-contents key))) val)) + (λ (hash key) (rewrap (shrink-proc (custom-elem-contents key)))) + (λ (hash key) (rewrap (extract-proc (custom-elem-contents key)))) + (λ (hash) (clear-proc)) + (λ (hash key) (rewrap (equal-key-proc (custom-elem-contents key)))))] + [else + (c-or-i-hash + (custom-set-table s) + (λ (hash key) (values (inject-proc key) (λ (hash key val) val))) + (λ (hash key val) (values (add-proc key) val)) + (λ (hash key) (shrink-proc key)) + (λ (hash key) (extract-proc key)) + (λ (hash) (clear-proc)) + (λ (hash key) (equal-key-proc key)))]))) + +(define (add-impersonator-properties without-props prop-args) + (cond + [(null? prop-args) without-props] + [(immutable-custom-set? without-props) + (apply chaperone-struct without-props struct:immutable-custom-set prop-args)] + [(weak-custom-set? without-props) + (apply chaperone-struct without-props struct:weak-custom-set prop-args)] + [else + (apply chaperone-struct without-props struct:mutable-custom-set prop-args)])) + +(define (check-chap/imp-args impersonate? s + inject-proc add-proc shrink-proc extract-proc + clear-proc+equal-key-proc+props) + (define who (if impersonate? 'impersonate-hash-set 'chaperone-hash-set)) + (unless (if impersonate? + (or (set-mutable? s) (set-weak? s)) + (or (set? s) (set-mutable? s) (set-weak? s))) + (apply raise-argument-error + who + (format "~s" + (if impersonate? + '(or/c set-mutable? set-weak?) + '(or/c set? set-mutable? set-weak?))) + 0 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)) + (unless (or (not inject-proc) + (and (procedure? inject-proc) + (procedure-arity-includes? inject-proc 2))) + (apply raise-argument-error + who + "(or/c #f (procedure-arity-includes/c 2))" + 1 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)) + (unless (or (not add-proc) + (and (procedure? add-proc) + (procedure-arity-includes? add-proc 2))) + (apply raise-argument-error + who + "(or/c #f (procedure-arity-includes/c 2))" + 2 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)) + (unless (or (not shrink-proc) + (and (procedure? shrink-proc) + (procedure-arity-includes? shrink-proc 2))) + (apply raise-argument-error + who + "(or/c #f (procedure-arity-includes/c 2))" + 3 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)) + (unless (or (not extract-proc) + (and (procedure? extract-proc) + (procedure-arity-includes? extract-proc 2))) + (apply raise-argument-error + who + "(or/c #f (procedure-arity-includes/c 2))" + 4 s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)) + (unless (null? clear-proc+equal-key-proc+props) + (unless (or (not (car clear-proc+equal-key-proc+props)) + (and (procedure? (car clear-proc+equal-key-proc+props)) + (procedure-arity-includes? (car clear-proc+equal-key-proc+props) 1)) + (impersonator-property? (car clear-proc+equal-key-proc+props))) + (apply raise-argument-error + who + (format "~s" `(or/c #f + (procedure-arity-includes/c 1) + impersonator-property?)) + 5 + s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))) + (define-values (num-supplied-procs clear-proc equal-key-proc args) + (cond + [(null? clear-proc+equal-key-proc+props) (values 0 #f #f '())] + [(impersonator-property? (car clear-proc+equal-key-proc+props)) + (values 0 #f #f clear-proc+equal-key-proc+props)] + [else + (define clear-proc (car clear-proc+equal-key-proc+props)) + (define equal-key-proc+props (cdr clear-proc+equal-key-proc+props)) + (cond + [(null? equal-key-proc+props) (values 1 clear-proc #f '())] + [(impersonator-property? (car equal-key-proc+props)) + (values 1 clear-proc #f equal-key-proc+props)] + [else + (values 2 clear-proc (car equal-key-proc+props) (cdr equal-key-proc+props))])])) + (unless (or (not equal-key-proc) + (and (procedure? equal-key-proc) + (procedure-arity-includes? equal-key-proc 2))) + (apply raise-argument-error + who + "(or/c #f (procedure-arity-includes/c 1))" + (+ 4 num-supplied-procs) + s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props)) + (for ([ele (in-list args)] + [i (in-naturals)] + #:when (even? i)) + (unless (impersonator-property? ele) + (apply raise-argument-error + who + "impersonator-property?" + (+ i num-supplied-procs 4) + s inject-proc add-proc shrink-proc extract-proc clear-proc+equal-key-proc+props))) + (when (or (not inject-proc) (not add-proc) (not shrink-proc) (not extract-proc)) + (unless (and (not inject-proc) (not add-proc) (not shrink-proc) (not extract-proc) + (not equal-key-proc) (not clear-proc)) + (raise-arguments-error who + (string-append + "if one of inject-proc, add-proc, shrink-proc" + " or extract-proc is #f, they must all be and the" + " equal-key-proc and clear-proc must also be") + "inject-proc" inject-proc + "add-proc" add-proc + "shrink-proc" shrink-proc + "extract-proc" extract-proc + "equal-key-proc" equal-key-proc + "clear-proc" clear-proc))) + (unless inject-proc + (when (null? args) + (raise-arguments-error + who + "when inject-proc, add-proc, shrink-proc, and extract-proc are #f," + " at least one property must be supplied"))) + (values clear-proc + (or equal-key-proc (λ (s e) e)) + args)) + (define (set-check-compatible name s1 s2) (define spec (custom-set-spec s1)) (unless (and (custom-set? s2) @@ -388,7 +576,7 @@ (sequence-map custom-elem-contents keys) keys)) -(struct custom-elem [contents]) +(struct custom-elem [contents] #:transparent) (struct custom-spec [elem? wrap intern]) @@ -581,26 +769,26 @@ (struct wrapped-elem custom-elem [] #:methods gen:equal+hash [(define equal-proc - (if (procedure-arity-includes? =? 2) - (lambda (a b f) - (=? (custom-elem-contents a) - (custom-elem-contents b))) + (if (procedure-arity-includes? =? 3) (lambda (a b f) (=? (custom-elem-contents a) (custom-elem-contents b) - f)))) + f)) + (lambda (a b f) + (=? (custom-elem-contents a) + (custom-elem-contents b))))) (define hash-proc - (if (procedure-arity-includes? hc1 1) + (if (procedure-arity-includes? hc1 2) (lambda (a f) - (hc1 (custom-elem-contents a))) + (hc1 (custom-elem-contents a) f)) (lambda (a f) - (hc1 (custom-elem-contents a) f)))) + (hc1 (custom-elem-contents a))))) (define hash2-proc - (if (procedure-arity-includes? hc2 1) + (if (procedure-arity-includes? hc2 2) (lambda (a f) - (hc2 (custom-elem-contents a))) + (hc2 (custom-elem-contents a) f)) (lambda (a f) - (hc2 (custom-elem-contents a) f))))]) + (hc2 (custom-elem-contents a)))))]) (custom-spec elem? wrapped-elem (make-weak-hasheq))) (define (default-hc x f) 1) @@ -653,6 +841,8 @@ (define (immutable-custom-set-maker spec name) (define (proc [st '()]) + (unless (stream? st) + (raise-argument-error name "stream?" st)) (dprintf "~a\n" name) (define table (for/fold ([table (make-immutable-hash)]) ([x (in-stream st)]) @@ -663,6 +853,8 @@ (define (imperative-custom-set-maker spec name make-table make-set) (define (proc [st '()]) + (unless (stream? st) + (raise-argument-error name "stream?" st)) (dprintf "~a\n" name) (define table (make-table)) (for ([x (in-stream st)]) diff --git a/racket/collects/racket/private/stxparam.rkt b/racket/collects/racket/private/stxparam.rkt index f9af1c8e9b..93a943b9d2 100644 --- a/racket/collects/racket/private/stxparam.rkt +++ b/racket/collects/racket/private/stxparam.rkt @@ -12,7 +12,7 @@ (syntax-case stx () [(_ ([id val] ...) body ...) (let ([ids (syntax->list #'(id ...))]) - (with-syntax ([(gen-id ...) + (with-syntax ([((gen-id must-be-renamer?) ...) (map (lambda (id) (unless (identifier? id) (raise-syntax-error @@ -20,19 +20,18 @@ "not an identifier" stx id)) - (let* ([rt (syntax-local-value id (lambda () #f))] - [sp (if (set!-transformer? rt) - (set!-transformer-procedure rt) - rt)]) + (let ([sp (syntax-parameter-local-value id)]) (unless (syntax-parameter? sp) (raise-syntax-error #f "not bound as a syntax parameter" stx id)) - (syntax-local-get-shadower - (syntax-local-introduce (syntax-parameter-target sp)) - #t))) + (list + (syntax-local-get-shadower + (syntax-local-introduce (syntax-parameter-target sp)) + #t) + (rename-transformer-parameter? sp)))) ids)]) (let ([dup (check-duplicate-identifier ids)]) (when dup @@ -52,6 +51,10 @@ (list ids) #'())]) (syntax/loc stx - (let-syntaxes ([(gen-id) (convert-renamer val)] ...) + (let-syntaxes ([(gen-id) + (convert-renamer + (if must-be-renamer? (quote-syntax val) #f) + val)] + ...) orig ... body ...)))))]))) diff --git a/racket/collects/racket/private/stxparamkey.rkt b/racket/collects/racket/private/stxparamkey.rkt index 14884d6443..1faa3dc710 100644 --- a/racket/collects/racket/private/stxparamkey.rkt +++ b/racket/collects/racket/private/stxparamkey.rkt @@ -4,14 +4,69 @@ "stxcase.rkt" "stxloc.rkt" "with-stx.rkt") (-define-struct wrapped-renamer (renamer)) - (-define-struct parameter-binding (val param)) + + (define-values (struct:parameter-binding make-parameter-binding parameter-binding? parameter-binding-ref parameter-binding-set!) + (make-struct-type 'parameter-binding #f 2 0 #f null (current-inspector) #f '(0 1))) + (define parameter-binding-val (make-struct-field-accessor parameter-binding-ref 0)) + (define parameter-binding-param (make-struct-field-accessor parameter-binding-ref 1)) + + (define (parameter-binding-rt-target pbr) + (rename-transformer-target (wrapped-renamer-renamer (parameter-binding-val pbr)))) + (define-values (struct:parameter-binding-rt make-parameter-binding-rt parameter-binding-rt? parameter-binding-rt-ref parameter-binding-rt-set!) + (make-struct-type 'parameter-binding-rt struct:parameter-binding 0 0 #f (list (cons prop:rename-transformer parameter-binding-rt-target)) (current-inspector) #f)) + (define-values (struct:syntax-parameter make-syntax-parameter syntax-parameter? syntax-parameter-ref syntax-parameter-set!) - (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0)) + (make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0 '(0 1))) + + (define (rename-transformer-parameter-target rtp) + (define t (syntax-parameter-target rtp)) + ;; XXX (syntax-transforming?) is not always true when the + ;; prop:rename-transformer procedure is evaluated. I think this is + ;; because it used to test rename-transformer? + (define lt + (if (syntax-transforming?) + (syntax-local-get-shadower t #t) + t)) + (syntax-property lt 'not-free-identifier=? #t)) + + (define-values (struct:rename-transformer-parameter make-rename-transformer-parameter rename-transformer-parameter? rename-transformer-parameter-ref rename-transformer-parameter-set!) + (make-struct-type 'rename-transformer-parameter struct:syntax-parameter 0 0 #f (list (cons prop:rename-transformer rename-transformer-parameter-target)) (current-inspector) #f)) (define (syntax-parameter-target sp) (syntax-parameter-ref sp 1)) + ;; If it is a rename-transformer-parameter, then we need to get the + ;; parameter and not what it points to, otherwise, we can keep + ;; going. + (define (syntax-parameter-local-value id) + (let*-values + ([(rt* rt-target) + (syntax-local-value/immediate id (lambda () #f))] + [(rt) (if (syntax-parameter? rt*) + rt* + (or rt-target rt*))] + [(sp) (if (set!-transformer? rt) + (set!-transformer-procedure rt) + rt)]) + sp)) + + (define (syntax-parameter-local-value-pre id) + (define-values (rt* rt-target) (syntax-local-value/immediate id (λ () #f))) + (cond + [(not rt-target) + rt*] + [(syntax-parameter? rt*) + rt-target] + [(parameter-binding? rt*) + rt*] + [else + (syntax-parameter-local-value-pre rt-target)])) + + (define (syntax-parameter-local-value-for-parameter target) + (or (syntax-parameter-local-value-pre (syntax-local-get-shadower target #t)) + (syntax-parameter-local-value-pre target))) + (define (target-value target) (syntax-local-value (syntax-local-get-shadower target #t) (lambda () @@ -30,18 +85,23 @@ v)]) (if (wrapped-renamer? v) (wrapped-renamer-renamer v) - v))) + v))) (define (syntax-parameter-target-parameter target) - (let ([v (target-value target)]) + (let ([v (syntax-parameter-local-value-for-parameter target)]) (parameter-binding-param v))) - (define (convert-renamer v) - (make-parameter-binding + (define (convert-renamer must-be-renamer?-stx v) + (when must-be-renamer?-stx + (unless (rename-transformer? v) + (raise-syntax-error #f "rename-transformer-parameter must be bound to rename-transformer" must-be-renamer?-stx))) + ((if must-be-renamer?-stx + make-parameter-binding-rt + make-parameter-binding) (if (rename-transformer? v) (make-wrapped-renamer v) v) - ;; comile-time parameter needed for `splicing-syntax-parameterize': + ;; compile-time parameter needed for `splicing-syntax-parameterize': (make-parameter #f))) (define (apply-transformer v stx set!-stx) @@ -84,6 +144,9 @@ apply-transformer syntax-parameter? make-syntax-parameter + rename-transformer-parameter? + make-rename-transformer-parameter + syntax-parameter-local-value syntax-parameter-target syntax-parameter-target-value syntax-parameter-target-parameter)) diff --git a/racket/collects/racket/random.rkt b/racket/collects/racket/random.rkt index 2978444c9b..5d1c431e1f 100644 --- a/racket/collects/racket/random.rkt +++ b/racket/collects/racket/random.rkt @@ -1,7 +1,13 @@ #lang racket/base -(require "private/unix-rand.rkt" "private/windows-rand.rkt" racket/contract/base) -(provide (contract-out [crypto-random-bytes (-> exact-nonnegative-integer? bytes?)])) +(require "private/unix-rand.rkt" "private/windows-rand.rkt" + racket/contract/base racket/sequence racket/set) +(provide (contract-out [crypto-random-bytes (-> exact-nonnegative-integer? bytes?)] + [random-ref (->* (sequence?) (pseudo-random-generator?) any/c)] + [random-sample (->* (sequence? exact-nonnegative-integer?) + (pseudo-random-generator? + #:replacement? any/c) + (listof any/c))])) ; (: crypto-random-bytes (-> Positive-Integer Bytes)) ; returns n random bytes from the os. @@ -12,3 +18,46 @@ [else (raise (make-exn:fail:unsupported "not supported on the current platform" (current-continuation-marks)))])) + +(define (random-ref seq [prng (current-pseudo-random-generator)]) + (car (random-sample seq 1 prng))) + +(define (random-sample seq n [prng (current-pseudo-random-generator)] + #:replacement? [replacement? #t]) + ;; doing reservoir sampling, to do a single pass over the sequence + ;; (some sequences may not like multiple passes, e.g., ports) + (cond + [(zero? n) '()] + [(not replacement?) + ;; Based on: http://rosettacode.org/wiki/Knuth's_algorithm_S#Racket + (define not-there (gensym)) + (define samples (make-vector n not-there)) + (for ([elt seq] + [i (in-naturals)]) + (cond [(< i n) ; we're not full, sample for sure + (vector-set! samples i elt)] + [(< (random (add1 i) prng) n) ; we've already seen n items; replace one? + (vector-set! samples (random n prng) elt)])) + ;; did we get enough? + (unless (for/and ([s (in-vector samples)]) + (not (eq? s not-there))) + (raise-argument-error 'random-sample + "integer less than or equal to sequence length" + n)) + (vector->list samples)] + [else + ;; similar to above, except each sample is independent + (define samples #f) + (for ([elt seq] + [i (in-naturals)]) + (cond [(= i 0) ; initialize samples + (set! samples (make-vector n elt))] + [else ; independently, maybe replace + (for ([j (in-range n)]) + (when (zero? (random (add1 i) prng)) + (vector-set! samples j elt)))])) + (unless samples + (raise-argument-error 'random-sample + "non-empty sequence for n>0" + seq)) + (vector->list samples)])) diff --git a/racket/collects/racket/runtime-path.rkt b/racket/collects/racket/runtime-path.rkt index 5058e00fdf..98e71c34b5 100644 --- a/racket/collects/racket/runtime-path.rkt +++ b/racket/collects/racket/runtime-path.rkt @@ -161,7 +161,7 @@ (define-syntax (-define-runtime-path stx) (syntax-case stx () - [(_ orig-stx (id ...) expr to-list to-values need-dir?) + [(_ orig-stx (id ...) expr to-list to-values need-dir? runtime?-id) (let ([ids (syntax->list #'(id ...))]) (unless (memq (syntax-local-context) '(module module-begin top-level)) (raise-syntax-error #f "allowed only at the top level" #'orig-stx)) @@ -180,7 +180,7 @@ #'orig-stx))) #`(begin (define-values (id ...) - (let-values ([(id ...) expr]) + (let-values ([(id ...) (let ([runtime?-id #t]) expr)]) (let ([get-dir #,(if (syntax-e #'need-dir?) #`(lambda () (path-of @@ -195,24 +195,28 @@ (begin-for-syntax (register-ext-files (#%variable-reference) - (let-values ([(id ...) expr]) + (let-values ([(id ...) (let ([runtime?-id #f]) expr)]) (to-list id ...))))))])) (define-syntax (define-runtime-path stx) (syntax-case stx () - [(_ id expr) #`(-define-runtime-path #,stx (id) expr list values #t)])) + [(_ id expr) #`(-define-runtime-path #,stx (id) expr list values #t runtime?)] + [(_ id #:runtime?-id runtime?-id expr) #`(-define-runtime-path #,stx (id) expr list values #t runtime?-id)])) (define-syntax (define-runtime-paths stx) (syntax-case stx () - [(_ (id ...) expr) #`(-define-runtime-path #,stx (id ...) expr list values #t)])) + [(_ (id ...) expr) #`(-define-runtime-path #,stx (id ...) expr list values #t runtime?)] + [(_ (id ...) #:runtime?-id runtime?-id expr) #`(-define-runtime-path #,stx (id ...) expr list values #t runtime?-id)])) (define-syntax (define-runtime-path-list stx) (syntax-case stx () - [(_ id expr) #`(-define-runtime-path #,stx (id) expr values list #t)])) + [(_ id expr) #`(-define-runtime-path #,stx (id) expr values list #t runtime?)] + [(_ id #:runtime?-id runtime?-id expr) #`(-define-runtime-path #,stx (id) expr values list #t runtime?-id)])) (define-syntax (define-runtime-module-path-index stx) (syntax-case stx () - [(_ id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values #f)])) + [(_ id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values #f runtime?)] + [(_ id #:runtime?-id runtime?-id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values #f runtime?-id)])) (define-for-syntax required-module-paths (make-hash)) (define-syntax (runtime-require stx) diff --git a/racket/collects/racket/sequence.rkt b/racket/collects/racket/sequence.rkt index cd68cd305c..d8d1e26848 100644 --- a/racket/collects/racket/sequence.rkt +++ b/racket/collects/racket/sequence.rkt @@ -2,6 +2,8 @@ (require "stream.rkt" "private/sequence.rkt" + "fixnum.rkt" + "flonum.rkt" racket/contract/combinator racket/contract/base (for-syntax racket/base) @@ -41,8 +43,17 @@ (define (sequence-length s) (unless (sequence? s) (raise-argument-error 'sequence-length "sequence?" s)) - (for/fold ([c 0]) ([i (in-values*-sequence s)]) - (add1 c))) + (cond [(exact-nonnegative-integer? s) s] + [(list? s) (length s)] + [(vector? s) (vector-length s)] + [(flvector? s) (flvector-length s)] + [(fxvector? s) (fxvector-length s)] + [(string? s) (string-length s)] + [(bytes? s) (bytes-length s)] + [(hash? s) (hash-count s)] + [else + (for/fold ([c 0]) ([i (in-values*-sequence s)]) + (add1 c))])) (define (sequence-ref s i) (unless (sequence? s) (raise-argument-error 'sequence-ref "sequence?" s)) @@ -178,7 +189,7 @@ (coerce-contract 'sequence/c elem/c))) (define elem/mk-projs (for/list ([ctc (in-list ctcs)]) - (contract-projection ctc))) + (contract-late-neg-projection ctc))) (define n-cs (length elem/cs)) (make-contract #:name (apply build-compound-type-name 'sequence/c @@ -193,56 +204,92 @@ (if (vector? val) (= n-cs 1) #t) (if (list? val) (= n-cs 1) #t) (if (hash? val) (= n-cs 2) #t))) - #:projection + #:late-neg-projection (λ (orig-blame) (define blame (blame-add-context orig-blame "an element of")) (define ps (for/list ([mk-proj (in-list elem/mk-projs)]) (mk-proj blame))) - (λ (seq) - (unless (sequence? seq) - (raise-blame-error - orig-blame seq - '(expected: "a sequence" given: "~e") - seq)) - (define result-seq - (make-do-sequence - (lambda () - (let*-values ([(more? next) (sequence-generate seq)]) - (values - (lambda (idx) - (call-with-values - next - (lambda elems - (define n-elems (length elems)) - (unless (= n-elems n-cs) - (raise-blame-error - blame seq - '(expected: "a sequence of ~a values" given: "~a values\n values: ~e") - n-cs n-elems elems)) - (apply - values - (for/list ([elem (in-list elems)] - [p (in-list ps)]) - (p elem)))))) - add1 - 0 - (lambda (idx) - (define ans (more?)) - (when (and min-count (idx . < . min-count)) - (unless ans - (raise-blame-error - orig-blame - seq - '(expected: "a sequence that contains at least ~a values" given: "~e") - min-count - seq))) - ans) - (lambda elems #t) - (lambda (idx . elems) #t)))))) - (cond - [(list? seq) (sequence->list result-seq)] - [(stream? seq) (sequence->stream result-seq)] - [else result-seq]))))) + (cond + [(and (= n-cs 1) (not min-count)) + (define p (car ps)) + (λ (seq neg-party) + (unless (sequence? seq) + (raise-blame-error + orig-blame #:missing-party neg-party seq + '(expected: "a sequence" given: "~e") + seq)) + (define result-seq + (make-do-sequence + (lambda () + (let*-values ([(more? next) (sequence-generate seq)]) + (values + (lambda (idx) + (call-with-values + next + (case-lambda + [(elem) + (p elem neg-party)] + [elems + (define n-elems (length elems)) + (raise-blame-error + blame #:missing-party neg-party seq + '(expected: "a sequence of ~a values" given: "~a values\n values: ~e") + n-cs n-elems elems)]))) + add1 + 0 + (lambda (idx) (more?)) + (lambda elems #t) + (lambda (idx . elems) #t)))))) + (cond + [(list? seq) (sequence->list result-seq)] + [(stream? seq) (sequence->stream result-seq)] + [else result-seq]))] + [else + (λ (seq neg-party) + (unless (sequence? seq) + (raise-blame-error + orig-blame #:missing-party neg-party seq + '(expected: "a sequence" given: "~e") + seq)) + (define result-seq + (make-do-sequence + (lambda () + (let*-values ([(more? next) (sequence-generate seq)]) + (values + (lambda (idx) + (call-with-values + next + (lambda elems + (define n-elems (length elems)) + (unless (= n-elems n-cs) + (raise-blame-error + blame #:missing-party neg-party seq + '(expected: "a sequence of ~a values" given: "~a values\n values: ~e") + n-cs n-elems elems)) + (apply + values + (for/list ([elem (in-list elems)] + [p (in-list ps)]) + (p elem neg-party)))))) + add1 + 0 + (lambda (idx) + (define ans (more?)) + (when (and min-count (idx . < . min-count)) + (unless ans + (raise-blame-error + orig-blame #:missing-party neg-party + seq + '(expected: "a sequence that contains at least ~a values" given: "~e") + min-count + seq))) + ans) + (lambda elems #t) + (lambda (idx . elems) #t)))))) + (cond + [(list? seq) (sequence->list result-seq)] + [(stream? seq) (sequence->stream result-seq)] + [else result-seq]))])))) ;; additional sequence constructors diff --git a/racket/collects/racket/set.rkt b/racket/collects/racket/set.rkt index 2e2082d997..8df5a90110 100644 --- a/racket/collects/racket/set.rkt +++ b/racket/collects/racket/set.rkt @@ -2,18 +2,62 @@ (require racket/contract/base racket/contract/combinator - racket/private/set - racket/private/set-types + "private/set.rkt" + "private/set-types.rkt" racket/generic - racket/private/for) + racket/private/for + (for-syntax racket/base)) -(provide (all-from-out racket/private/set) - (all-from-out racket/private/set-types) +(provide gen:set generic-set? set-implements? + + set-empty? set-member? set-count + set=? subset? proper-subset? + set-map set-for-each + set-copy set-copy-clear + set->list set->stream set-first set-rest + set-add set-remove set-clear + set-union set-intersect set-subtract set-symmetric-difference + set-add! set-remove! set-clear! + set-union! set-intersect! set-subtract! set-symmetric-difference! + + in-set + set-implements/c + + set seteq seteqv + weak-set weak-seteq weak-seteqv + mutable-set mutable-seteq mutable-seteqv + list->set list->seteq list->seteqv + list->weak-set list->weak-seteq list->weak-seteqv + list->mutable-set list->mutable-seteq list->mutable-seteqv + set-eq? set-eqv? set-equal? + set-weak? set-mutable? set? + for/set for/seteq for/seteqv + for*/set for*/seteq for*/seteqv + for/weak-set for/weak-seteq for/weak-seteqv + for*/weak-set for*/weak-seteq for*/weak-seteqv + for/mutable-set for/mutable-seteq for/mutable-seteqv + for*/mutable-set for*/mutable-seteq for*/mutable-seteqv + + define-custom-set-types + make-custom-set-types + make-custom-set + make-weak-custom-set + make-mutable-custom-set + + chaperone-hash-set + impersonate-hash-set + set/c) -(define (set/c elem/c - #:cmp [cmp 'dont-care] - #:kind [kind 'immutable]) +(define/subexpression-pos-prop/name + real-set/c-name (set/c _elem/c + #:equal-key/c [_equal-key/c any/c] + #:cmp [cmp 'dont-care] + #:kind [kind 'immutable] + #:lazy? [_lazy? (lazy-default kind _elem/c)]) + (define elem/c (coerce-contract 'set/c _elem/c)) + (define equal-key/c (coerce-contract 'set/c _equal-key/c)) + (define lazy? (and _lazy? #t)) (define cmp/c (case cmp [(dont-care) any/c] @@ -21,8 +65,8 @@ [(eqv) set-eqv?] [(eq) set-eq?] [else (raise-arguments-error 'set/c - "invalid #:cmp argument" - "#:cmp argument" cmp)])) + "invalid #:cmp argument" + "#:cmp argument" cmp)])) (define kind/c (case kind [(dont-care) any/c] @@ -39,21 +83,28 @@ (raise-arguments-error 'set/c "element contract must be a flat contract for eqv? and eq?-based sets" - "element contract" (contract-name elem/c) + "element contract" elem/c "#:cmp option" cmp))] [else (unless (chaperone-contract? elem/c) (raise-argument-error 'set/c "chaperone-contract?" elem/c))]) (cond [(and (eq? kind 'immutable) - (flat-contract? elem/c)) - (flat-set-contract elem/c cmp kind)] + (not lazy?) + (flat-contract? elem/c) + (flat-contract? equal-key/c)) + (flat-set-contract elem/c equal-key/c cmp kind lazy?)] [(chaperone-contract? elem/c) - (chaperone-set-contract elem/c cmp kind)] + (chaperone-set-contract elem/c equal-key/c cmp kind lazy?)] [else - (impersonator-set-contract elem/c cmp kind)])) + (impersonator-set-contract elem/c equal-key/c cmp kind lazy?)])) -(struct set-contract [elem/c cmp kind]) +(struct set-contract [elem/c equal-key/c cmp kind lazy?] + #:property prop:custom-write contract-custom-write-property-proc) + +(define (lazy-default kind elem/c) + (not (and (equal? kind 'immutable) + (flat-contract? elem/c)))) (define (set-contract-name ctc) (define elem/c (set-contract-elem/c ctc)) @@ -65,7 +116,11 @@ `[#:cmp (quote ,cmp)]) ,@(if (eq? kind 'immutable) `[] - `[#:kind (quote ,kind)]))) + `[#:kind (quote ,kind)]) + ,@(if (equal? (set-contract-lazy? ctc) + (lazy-default kind elem/c)) + '() + `(#:lazy? ,(set-contract-lazy? ctc))))) (define (set-contract-first-order ctc) (define cmp (set-contract-cmp ctc)) @@ -86,94 +141,196 @@ (lambda (x) (and (generic-set? x) (cmp? x) (kind? x)))) -(define (set-contract-check cmp kind b x) +(define (set-contract-check cmp kind b neg-party x) (unless (generic-set? x) - (raise-blame-error b x "expected a set")) + (raise-blame-error b #:missing-party neg-party x "expected a set")) (case cmp [(equal) (unless (set-equal? x) - (raise-blame-error b x "expected an equal?-based set"))] + (raise-blame-error b #:missing-party neg-party x "expected an equal?-based set"))] [(eqv) (unless (set-eqv? x) - (raise-blame-error b x "expected an eqv?-based set"))] + (raise-blame-error b #:missing-party neg-party x "expected an eqv?-based set"))] [(eq) (unless (set-eq? x) - (raise-blame-error b x "expected an eq?-based set"))]) + (raise-blame-error b #:missing-party neg-party x "expected an eq?-based set"))]) (case kind [(mutable-or-weak) (unless (or (set-mutable? x) (set-weak? x)) - (raise-blame-error b x "expected a mutable or weak set"))] + (raise-blame-error b #:missing-party neg-party x "expected a mutable or weak set"))] [(mutable) (unless (set-mutable? x) - (raise-blame-error b x "expected a mutable set"))] + (raise-blame-error b #:missing-party neg-party x "expected a mutable set"))] [(weak) (unless (set-weak? x) - (raise-blame-error b x "expected a weak set"))] + (raise-blame-error b #:missing-party neg-party x "expected a weak set"))] [(immutable) (unless (set? x) - (raise-blame-error b x "expected an immutable set"))])) + (raise-blame-error b #:missing-party neg-party x "expected an immutable set"))])) -(define (set-contract-projection mode) +(define (set-contract-late-neg-projection chaperone-ctc?) (lambda (ctc) - (define elem/c (set-contract-elem/c ctc)) - (define cmp (set-contract-cmp ctc)) - (define kind (set-contract-kind ctc)) - (lambda (b) - (lambda (x) - (set-contract-check cmp kind b x) - (cond - [(list? x) - (define proj - ((contract-projection elem/c) - (blame-add-context b "an element of"))) - (map proj x)] - [else - (define (method sym c) - (lambda (x) - (define name (contract-name c)) - (define str (format "method ~a with contract ~.s" sym name)) - (define b2 (blame-add-context b str)) - (((contract-projection c) b2) x))) - (define-syntax-rule (redirect [id expr] ...) - (redirect-generics mode gen:set x [id (method 'id expr)] ...)) - (redirect - [set-member? (-> generic-set? elem/c boolean?)] - [set-empty? (or/c (-> generic-set? boolean?) #f)] - [set-count (or/c (-> generic-set? exact-nonnegative-integer?) #f)] - [set=? (or/c (-> generic-set? ctc boolean?) #f)] - [subset? (or/c (-> generic-set? ctc boolean?) #f)] - [proper-subset? (or/c (-> generic-set? ctc boolean?) #f)] - [set-map (or/c (-> generic-set? (-> elem/c any/c) list?) #f)] - [set-for-each (or/c (-> generic-set? (-> elem/c any) void?) #f)] - [set-copy (or/c (-> generic-set? generic-set?) #f)] - [in-set (or/c (-> generic-set? sequence?) #f)] - [set->list (or/c (-> generic-set? (listof elem/c)) #f)] - [set->stream (or/c (-> generic-set? stream?) #f)] - [set-first (or/c (-> generic-set? elem/c) #f)] - [set-rest (or/c (-> generic-set? ctc) #f)] - [set-add (or/c (-> generic-set? elem/c ctc) #f)] - [set-remove (or/c (-> generic-set? elem/c ctc) #f)] - [set-clear (or/c (-> generic-set? ctc) #f)] - [set-copy-clear (or/c (-> generic-set? generic-set?) #f)] - [set-union - (or/c (->* [generic-set?] [] #:rest (listof ctc) ctc) #f)] - [set-intersect - (or/c (->* [generic-set?] [] #:rest (listof ctc) ctc) #f)] - [set-subtract - (or/c (->* [generic-set?] [] #:rest (listof ctc) ctc) #f)] - [set-symmetric-difference - (or/c (->* [generic-set?] [] #:rest (listof ctc) ctc) #f)] - [set-add! (or/c (-> generic-set? elem/c void?) #f)] - [set-remove! (or/c (-> generic-set? elem/c void?) #f)] - [set-clear! (or/c (-> generic-set? void?) #f)] - [set-union! - (or/c (->* [generic-set?] [] #:rest (listof ctc) void?) #f)] - [set-intersect! - (or/c (->* [generic-set?] [] #:rest (listof ctc) void?) #f)] - [set-subtract! - (or/c (->* [generic-set?] [] #:rest (listof ctc) void?) #f)] - [set-symmetric-difference! - (or/c (->* [generic-set?] [] #:rest (listof ctc) void?) #f)])]))))) + (cond + [(allows-generic-sets? ctc) + (generic-set-late-neg-projection ctc chaperone-ctc?)] + [else + (hash-set-late-neg-projection ctc chaperone-ctc?)]))) + +(define (allows-generic-sets? ctc) + (and (equal? 'dont-care (set-contract-kind ctc)) + (equal? 'dont-care (set-contract-cmp ctc)))) + +(define (hash-set-late-neg-projection ctc chaperone-ctc?) + (define elem/c (set-contract-elem/c ctc)) + (define equal-key/c (set-contract-equal-key/c ctc)) + (define cmp (set-contract-cmp ctc)) + (define kind (set-contract-kind ctc)) + (define late-neg-ele-proj (contract-late-neg-projection elem/c)) + (define late-neg-equal-key-proj (contract-late-neg-projection equal-key/c)) + (define lazy? (set-contract-lazy? ctc)) + (λ (blame) + (define ele-neg-blame (blame-add-element-context blame #t)) + (define late-neg-pos-proj (late-neg-ele-proj (blame-add-element-context blame #f))) + (define late-neg-neg-proj (late-neg-ele-proj ele-neg-blame)) + (define late-neg-equal-key-pos-proj (late-neg-equal-key-proj ele-neg-blame)) + (cond + [lazy? + (λ (val neg-party) + (set-contract-check cmp kind blame neg-party val) + (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party)) + (cond + [(set? val) + (chaperone-hash-set + val + (λ (val ele) ele) + (λ (val ele) ele) + (λ (val ele) ele) + (λ (val ele) (late-neg-pos-proj ele neg-party)) + (λ (val) (void)) + (λ (val ele) (late-neg-equal-key-pos-proj ele neg-party)) + impersonator-prop:contracted ctc + impersonator-prop:blame (cons blame neg-party))] + [else + (chaperone-hash-set + val + (λ (val ele) ele) + (λ (val ele) (late-neg-neg-proj ele neg-party)) + (λ (val ele) ele) + (λ (val ele) (late-neg-pos-proj ele neg-party)) + (λ (val) (void)) + (λ (val ele) (late-neg-equal-key-pos-proj ele neg-party)) + impersonator-prop:contracted ctc + impersonator-prop:blame (cons blame neg-party))]))] + [else + (λ (val neg-party) + (set-contract-check cmp kind blame neg-party val) + (cond + [(set? val) + (chaperone-hash-set + (for/fold ([s (set-clear val)]) + ([e (in-set val)]) + (set-add s (late-neg-pos-proj e neg-party))) + #f #f #f + impersonator-prop:contracted ctc + impersonator-prop:blame (cons blame neg-party))] + [else + (for ([ele (in-list (set->list val))]) + (set-remove! val ele) + (set-add! val (late-neg-pos-proj ele neg-party))) + (chaperone-hash-set + val + (λ (val ele) ele) + (λ (val ele) (late-neg-neg-proj ele neg-party)) + (λ (val ele) ele) + (λ (val ele) (late-neg-pos-proj ele neg-party)) + (λ (val) (void)) + (λ (val ele) (late-neg-equal-key-pos-proj ele neg-party)) + impersonator-prop:contracted ctc + impersonator-prop:blame (cons blame neg-party))]))]))) + +(define (generic-set-late-neg-projection ctc chaperone-ctc?) + (define elem/c (set-contract-elem/c ctc)) + (define cmp (set-contract-cmp ctc)) + (define kind (set-contract-kind ctc)) + (define lazy? (set-contract-lazy? ctc)) + (lambda (blame) + (define (method sym c) + (define name (contract-name c)) + (define str (format "method ~a with contract ~.s" sym name)) + (define b2 (blame-add-context blame str)) + ((contract-late-neg-projection c) b2)) + (define-syntax (redirect stx) + (syntax-case stx () + [(_ [id expr] ...) + (with-syntax ([(proj-id ...) (generate-temporaries #'(id ...))]) + #'(let ([proj-id (method 'id expr)] ...) + (λ (x neg-party) + (redirect-generics chaperone-ctc? + gen:set x [id (λ (x) (proj-id x neg-party))] ...))))])) + (define me (if chaperone-contract? + (make-chaperone-contract + #:name (set-contract-name ctc) + #:stronger set-contract-stronger + #:late-neg-projection + (λ (blame) (λ (val neg-party) (do-redirect val neg-party)))) + (make-contract + #:name (set-contract-name ctc) + #:stronger set-contract-stronger + #:late-neg-projection + (λ (blame) (λ (val neg-party) (do-redirect val neg-party)))))) + (define do-redirect + (redirect + [set-member? (-> generic-set? elem/c boolean?)] + [set-empty? (or/c (-> generic-set? boolean?) #f)] + [set-count (or/c (-> generic-set? exact-nonnegative-integer?) #f)] + [set=? (or/c (-> generic-set? me boolean?) #f)] + [subset? (or/c (-> generic-set? me boolean?) #f)] + [proper-subset? (or/c (-> generic-set? me boolean?) #f)] + [set-map (or/c (-> generic-set? (-> elem/c any/c) list?) #f)] + [set-for-each (or/c (-> generic-set? (-> elem/c any) void?) #f)] + [set-copy (or/c (-> generic-set? generic-set?) #f)] + [in-set (or/c (-> generic-set? sequence?) #f)] + [set->list (or/c (-> generic-set? (listof elem/c)) #f)] + [set->stream (or/c (-> generic-set? stream?) #f)] + [set-first (or/c (-> generic-set? elem/c) #f)] + [set-rest (or/c (-> generic-set? me) #f)] + [set-add (or/c (-> generic-set? elem/c me) #f)] + [set-remove (or/c (-> generic-set? elem/c me) #f)] + [set-clear (or/c (-> generic-set? me) #f)] + [set-copy-clear (or/c (-> generic-set? generic-set?) #f)] + [set-union + (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] + [set-intersect + (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] + [set-subtract + (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] + [set-symmetric-difference + (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] + [set-add! (or/c (-> generic-set? elem/c void?) #f)] + [set-remove! (or/c (-> generic-set? elem/c void?) #f)] + [set-clear! (or/c (-> generic-set? void?) #f)] + [set-union! + (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] + [set-intersect! + (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] + [set-subtract! + (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] + [set-symmetric-difference! + (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)])) + (define proj + ((contract-late-neg-projection elem/c) (blame-add-element-context blame #f))) + (lambda (x neg-party) + (set-contract-check cmp kind blame neg-party x) + (cond + [(list? x) + (for/list ([e (in-list x)]) + (proj e neg-party))] + [else + (do-redirect x neg-party)])))) + + +(define (blame-add-element-context blame swap?) + (blame-add-context blame "an element of" #:swap? swap?)) (define (flat-set-contract-first-order ctc) (define set-passes? (set-contract-first-order ctc)) @@ -183,37 +340,46 @@ (for/and ([e (in-set x)]) (elem-passes? e))))) -(define (flat-set-contract-projection ctc) +;; since the equal-key/c must be a flat contract +;; in order for the entire set/c to be a flat contract, +;; then we know that it doesn't have any negative blame +;; and thus can never fail; so this projection ignores it. +(define (flat-set-contract-late-neg-projection ctc) (define elem/c (set-contract-elem/c ctc)) (define cmp (set-contract-cmp ctc)) (define kind (set-contract-kind ctc)) + (define mk-elem/c-proj (contract-late-neg-projection elem/c)) (lambda (b) - (lambda (x) - (set-contract-check cmp kind b x) - (define proj - ((contract-projection elem/c) - (blame-add-context b "an element of"))) + (define proj (mk-elem/c-proj (blame-add-context b "an element of"))) + (lambda (x neg-party) + (set-contract-check cmp kind b neg-party x) (for ([e (in-set x)]) - (proj e)) + (proj e neg-party)) x))) +(define (set-contract-stronger this that) + #f) + (struct flat-set-contract set-contract [] #:property prop:flat-contract (build-flat-contract-property #:name set-contract-name + #:stronger set-contract-stronger #:first-order flat-set-contract-first-order - #:projection flat-set-contract-projection)) + #:late-neg-projection flat-set-contract-late-neg-projection)) (struct chaperone-set-contract set-contract [] #:property prop:chaperone-contract (build-chaperone-contract-property #:name set-contract-name + #:stronger set-contract-stronger #:first-order set-contract-first-order - #:projection (set-contract-projection #t))) + #:late-neg-projection (set-contract-late-neg-projection #t))) (struct impersonator-set-contract set-contract [] #:property prop:contract (build-contract-property #:name set-contract-name + #:stronger set-contract-stronger #:first-order set-contract-first-order - #:projection (set-contract-projection #f))) + #:late-neg-projection (set-contract-late-neg-projection #f))) diff --git a/racket/collects/racket/splicing.rkt b/racket/collects/racket/splicing.rkt index b911623deb..5096983a64 100644 --- a/racket/collects/racket/splicing.rkt +++ b/racket/collects/racket/splicing.rkt @@ -350,10 +350,7 @@ 'transparent)])) (define-for-syntax (parameter-of id) - (let* ([rt (syntax-local-value id)] - [sp (if (set!-transformer? rt) - (set!-transformer-procedure rt) - rt)]) + (let ([sp (syntax-parameter-local-value id)]) (syntax-parameter-target-parameter (syntax-parameter-target sp)))) diff --git a/racket/collects/racket/stream.rkt b/racket/collects/racket/stream.rkt index 18d0b17bf7..a2d9220c78 100644 --- a/racket/collects/racket/stream.rkt +++ b/racket/collects/racket/stream.rkt @@ -240,45 +240,46 @@ (define (add-stream-context blame) (blame-add-context blame "a value generated by")) -(define (check-stream/c ctc val blame) - (unless (stream? val) - (raise-blame-error blame val '(expected "a stream" given: "~e") val))) - (define (stream/c-stronger? a b) (contract-stronger? (base-stream/c-content a) (base-stream/c-content b))) -; streams are lazy, so we need to contract the rest of the stream lazily (which can be a list) -(define (contract-stream-rest v ctc blame) +(define ((late-neg-projection impersonate/chaperone-stream) ctc) (define elem-ctc (base-stream/c-content ctc)) - (define new-ctc (if (list? v) (listof elem-ctc) ctc)) - (((contract-projection new-ctc) blame) v)) - -(define ((ho-projection impersonate/chaperone-stream) ctc) - (let ([elem-ctc (base-stream/c-content ctc)]) - (λ (blame) - (define stream-blame (add-stream-context blame)) - (define pos-elem-proj ((contract-projection elem-ctc) stream-blame)) - (λ (val) - (check-stream/c ctc val stream-blame) - (if (list? val) - (contract-stream-rest val ctc stream-blame) - (impersonate/chaperone-stream - val - (λ (v) (pos-elem-proj v)) - (λ (v) (contract-stream-rest v ctc stream-blame)) - impersonator-prop:contracted ctc - impersonator-prop:blame stream-blame)))))) + (define listof-elem-ctc (listof elem-ctc)) + (define elem-ctc-late-neg (get/build-late-neg-projection elem-ctc)) + (define listof-elem-ctc-late-neg (get/build-late-neg-projection listof-elem-ctc)) + (λ (blame) + (define stream-blame (add-stream-context blame)) + (define elem-ctc-late-neg-acceptor (elem-ctc-late-neg stream-blame)) + (define listof-elem-ctc-neg-acceptor (listof-elem-ctc-late-neg stream-blame)) + (define (stream/c-late-neg-proj-val-acceptor val neg-party) + (unless (stream? val) + (raise-blame-error blame #:missing-party neg-party + val '(expected "a stream" given: "~e") val)) + (if (list? val) + (listof-elem-ctc-neg-acceptor val neg-party) + (impersonate/chaperone-stream + val + (λ (v) (elem-ctc-late-neg-acceptor v neg-party)) + (λ (v) + (if (list? v) + (listof-elem-ctc-neg-acceptor v neg-party) + (stream/c-late-neg-proj-val-acceptor v neg-party))) + impersonator-prop:contracted ctc + impersonator-prop:blame stream-blame))) + stream/c-late-neg-proj-val-acceptor)) (struct base-stream/c (content)) (struct chaperone-stream/c base-stream/c () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (build-chaperone-contract-property - #:name stream/c-name - #:first-order stream? - #:stronger stream/c-stronger? - #:projection (ho-projection chaperone-stream))) + (parameterize ([skip-projection-wrapper? #t]) + (build-chaperone-contract-property + #:name stream/c-name + #:first-order stream? + #:stronger stream/c-stronger? + #:late-neg-projection (late-neg-projection chaperone-stream)))) (struct impersonator-stream/c base-stream/c () #:property prop:custom-write custom-write-property-proc @@ -287,7 +288,7 @@ #:name stream/c-name #:first-order stream? #:stronger stream/c-stronger? - #:projection (ho-projection impersonate-stream))) + #:late-neg-projection (late-neg-projection impersonate-stream))) (define (stream/c elem) (define ctc (coerce-contract 'stream/c elem)) diff --git a/racket/collects/racket/string.rkt b/racket/collects/racket/string.rkt index d4f51511f6..33df306f0f 100644 --- a/racket/collects/racket/string.rkt +++ b/racket/collects/racket/string.rkt @@ -173,7 +173,7 @@ (unless (string? str) (raise-argument-error 'string-contains? "string?" str)) (unless (string? sub) - (raise-argument-error 'string-prefix? "string?" sub)) + (raise-argument-error 'string-contains? "string?" sub)) (define L1 (string-length str)) (define L2 (string-length sub)) (define d (- L1 L2)) diff --git a/racket/collects/racket/stxparam.rkt b/racket/collects/racket/stxparam.rkt index ab198b4f06..cf3c561a07 100644 --- a/racket/collects/racket/stxparam.rkt +++ b/racket/collects/racket/stxparam.rkt @@ -10,6 +10,7 @@ "private/stxloc.rkt" "private/stxparamkey.rkt")) (#%provide define-syntax-parameter + define-rename-transformer-parameter syntax-parameterize (for-syntax syntax-parameter-value make-parameter-rename-transformer)) @@ -18,16 +19,28 @@ (syntax-case stx () [(_ id init-val) (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) - #'(begin - (define-syntax gen-id (convert-renamer init-val)) - (define-syntax id - (let ([gen-id #'gen-id]) - (make-set!-transformer - (make-syntax-parameter - (lambda (stx) - (let ([v (syntax-parameter-target-value gen-id)]) - (apply-transformer v stx #'set!))) - gen-id))))))])) + #'(begin + (define-syntax gen-id (convert-renamer #f init-val)) + (define-syntax id + (let ([gen-id #'gen-id]) + (make-set!-transformer + (make-syntax-parameter + (lambda (stx) + (let ([v (syntax-parameter-target-value gen-id)]) + (apply-transformer v stx #'set!))) + gen-id))))))])) + + (define-syntax (define-rename-transformer-parameter stx) + (syntax-case stx () + [(_ id init-val) + (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) + #'(begin + (define-syntax gen-id (convert-renamer #'init-val init-val)) + (define-syntax id + (let ([gen-id #'gen-id]) + (make-rename-transformer-parameter + #f + gen-id)))))])) (define-syntax (syntax-parameterize stx) (do-syntax-parameterize stx #'let-syntaxes #f #f))) diff --git a/racket/collects/racket/unit.rkt b/racket/collects/racket/unit.rkt index 3bf4e8b180..6ac935188d 100644 --- a/racket/collects/racket/unit.rkt +++ b/racket/collects/racket/unit.rkt @@ -12,6 +12,7 @@ racket/struct-info syntax/stx syntax/location + syntax/intdef "private/unit-contract-syntax.rkt" "private/unit-compiletime.rkt" "private/unit-syntax.rkt")) @@ -1203,7 +1204,9 @@ (apply append (map do-one ids tmps))))] [else (list defn-or-expr)])) expanded-body))]) - #'(block defn-or-expr ...)))))))) + (internal-definition-context-track + def-ctx + #'(block defn-or-expr ...))))))))) (define-for-syntax (redirect-imports/exports import?) (lambda (table-stx diff --git a/racket/collects/setup/cross-system.rkt b/racket/collects/setup/cross-system.rkt index 1b1c565c25..0da414457e 100644 --- a/racket/collects/setup/cross-system.rkt +++ b/racket/collects/setup/cross-system.rkt @@ -15,9 +15,11 @@ (define ht (and lib-dir (let ([f (build-path lib-dir "system.rktd")]) (and (file-exists? f) - (let ([ht (call-with-input-file* - f - read)]) + (let ([ht (call-with-default-reading-parameterization + (lambda () + (call-with-input-file* + f + read)))]) (and (hash? ht) (for/and ([sym (in-list (list* 'library-subpath diff --git a/racket/collects/setup/path-relativize.rkt b/racket/collects/setup/path-relativize.rkt index ade83d09ac..1a05be5a7b 100644 --- a/racket/collects/setup/path-relativize.rkt +++ b/racket/collects/setup/path-relativize.rkt @@ -44,7 +44,8 @@ ;; `path1', but that messes up the xform compilation somehow, by ;; having # vaules written into dep files. [(null? path) path0] - [(equal? (car path) (car root)) (loop (cdr path) (cdr root))] + [(equal? (normal-case-path (car path)) (normal-case-path (car root))) + (loop (cdr path) (cdr root))] [else path0]))) (define root-or-orig diff --git a/racket/collects/setup/private/pkg-deps.rkt b/racket/collects/setup/private/pkg-deps.rkt index 09138ab566..3c897ad0ce 100644 --- a/racket/collects/setup/private/pkg-deps.rkt +++ b/racket/collects/setup/private/pkg-deps.rkt @@ -368,10 +368,12 @@ (define in-mod `(lib ,(string-join (append (map path-element->string coll-path) (list base)) "/"))) + (define zo-path (build-path dir zo-f)) (define mod-code (call-with-input-file* - (build-path dir zo-f) + zo-path (lambda (i) - (parameterize ([read-accept-compiled #t]) + (parameterize ([read-accept-compiled #t] + [read-on-demand-source zo-path]) (read i))))) ;; Recur to cover submodules: (let loop ([mod-code mod-code]) diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt index ac28c34d29..5041272932 100644 --- a/racket/collects/setup/setup-core.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -293,18 +293,16 @@ (setup-printf "WARNING" "ignoring `compile-subcollections' entry in info ~a" path-name)) - ;; this check is also done in compiler/compiler, in compile-directory - (and (not (eq? 'all (omitted-paths path getinfo omit-root))) - (make-cc collection path - (if name - (format "~a (~a)" path-name name) - path-name) - info - parent - omit-root - info-root info-path info-path-mode - shadowing-policy - main?))) + (make-cc collection path + (if name + (format "~a (~a)" path-name name) + path-name) + info + parent + omit-root + info-root info-path info-path-mode + shadowing-policy + main?)) (define ((warning-handler v) exn) (setup-printf "WARNING" "~a" (exn->string exn)) @@ -525,11 +523,14 @@ ;; note: omit can be 'all, if this happens then this collection ;; should not have been included, but we might jump in if a ;; command-line argument specified a coll/subcoll - (define omit (append - (if make-docs? - null - (list (string->path "scribblings"))) - (omitted-paths ccp getinfo (cc-omit-root cc)))) + (define omit (let ([omit (omitted-paths ccp getinfo (cc-omit-root cc))]) + (if (eq? omit 'all) + 'all + (append + (if make-docs? + null + (list (string->path "scribblings"))) + omit)))) (define-values [dirs files] (if (eq? 'all omit) (values null null) @@ -542,12 +543,13 @@ (define srcs (append (filter has-module-suffix? files) - (if make-docs? - (filter (lambda (p) (not (member p omit))) - (map (lambda (s) (if (string? s) (string->path s) s)) - (map car (call-info info 'scribblings - (lambda () null) (lambda (x) #f))))) - null) + (if (and make-docs? + (not (eq? omit 'all))) + (filter (lambda (p) (not (member p omit))) + (map (lambda (s) (if (string? s) (string->path s) s)) + (map car (call-info info 'scribblings + (lambda () null) (lambda (x) #f))))) + null) (map (lambda (s) (if (string? s) (string->path s) s)) (call-info info 'compile-include-files (lambda () null) void)))) (list cc srcs children-ccs)) @@ -589,7 +591,7 @@ nothing-else-to-do? (not (make-tidy))) (setup-printf #f "nothing to do") - (exit 1)) + (exit 0)) (define (cc->name cc) (string-join (map path->string (cc-collection cc)) "/")) (define (cc->cc+name+id cc) @@ -663,9 +665,9 @@ ;; let `collection-path' complain about the name, if that's the problem: (with-handlers ([exn? (compose1 raise-user-error exn-message)]) (apply collection-path elems)) - ;; otherwise, it's probably a collection with nothing to compile + ;; otherwise, it's probably a collection with nothing to compile; ;; spell the name - (setup-printf "WARNING" + (setup-printf "warning" "nothing to compile in a given collection path: \"~a\"" (string-join sc "/"))) ccs) diff --git a/racket/collects/setup/unixstyle-install.rkt b/racket/collects/setup/unixstyle-install.rkt index 5a94021a42..b1230670c1 100644 --- a/racket/collects/setup/unixstyle-install.rkt +++ b/racket/collects/setup/unixstyle-install.rkt @@ -281,10 +281,10 @@ ;; Assume anything after a space is the argument spec: (let ([m (regexp-match #rx"Exec=([^ ]*)(.*)" l)]) (format "Exec=~a~a" - (fixup-path bindir (cadr m)) + (fixup-path (dir: 'bin) (cadr m)) (caddr m)))] [(regexp-match? #rx"^Icon=" l) - (format "Icon=~a" (fixup-path sharerktdir (substring l 5)))] + (format "Icon=~a" (fixup-path (dir: 'sharerkt) (substring l 5)))] [else l]))) (unless (equal? ls new-ls) (call-with-output-file (build-path appsdir d) diff --git a/racket/collects/syntax/free-vars.rkt b/racket/collects/syntax/free-vars.rkt index 9ced2c1e71..4a29674ac2 100644 --- a/racket/collects/syntax/free-vars.rkt +++ b/racket/collects/syntax/free-vars.rkt @@ -43,23 +43,35 @@ [(null? f) null] [(syntax? f) (loop (syntax-e f))]))) -;; free-vars : expr-stx -> (listof id) +;; free-vars : expr-stx [inspector?] [#:module-bound? any/c] -> (listof id) ;; Returns a list of free lambda- and let-bound identifiers in a ;; given epression. The expression must be fully expanded. -(define (free-vars e [code-insp - (variable-reference->module-declaration-inspector - (#%variable-reference))]) - ;; It would be nicers to have a functional mapping: +;; If `module-bound?` is true, also return module-bound variables. +(define (free-vars e + [code-insp + (variable-reference->module-declaration-inspector + (#%variable-reference))] + #:module-bound? [module-bound? #f]) + (define (submodule-error e) + (error 'free-vars "submodules not supported: ~a" e)) + ;; It would be nicer to have a functional mapping: (define bindings (make-bound-identifier-mapping)) (merge (let free-vars ([e e]) (kernel-syntax-case (syntax-disarm e code-insp) #f - [id - (identifier? #'id) - (if (and (eq? 'lexical (identifier-binding #'id)) - (not (bound-identifier-mapping-get bindings #'id (lambda () #f)))) - (list #'id) - null)] + [id + (identifier? #'id) + (let ([b (identifier-binding #'id)]) + (cond [(and (eq? 'lexical b) + (not (bound-identifier-mapping-get bindings #'id (lambda () #f)))) + (list #'id)] + [(and module-bound? ; do we count module-bound vars too? + ;; we're in an expression context, so any module-bound + ;; variable is free + (list? b)) + (list #'id)] + [else + null]))] [(#%top . id) null] [(quote q) null] [(quote-syntax . _) null] @@ -89,5 +101,9 @@ (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%expression #'#%variable-reference #'with-continuation-mark)) (map free-vars (syntax->list #'(expr ...)))] + [(module . _) + (submodule-error e)] + [(module* . _) + (submodule-error e)] [(kw . _) (error 'free-vars "unknown core form: ~a" (syntax->datum #'kw))])))) diff --git a/racket/collects/syntax/id-set.rkt b/racket/collects/syntax/id-set.rkt index b5ea39c9c2..3ed3f2768d 100644 --- a/racket/collects/syntax/id-set.rkt +++ b/racket/collects/syntax/id-set.rkt @@ -106,40 +106,40 @@ (and (set-passes? s) (for/and ([e (in-set s)]) (elem-passes? e))))) -(define (flat-id-set-contract-projection ctc) +(define (flat-id-set-late-neg-contract-projection ctc) (define elem/c (id-set-contract-elem/c ctc)) (define idsettype (id-set-contract-idsettype ctc)) (define mutability (id-set-contract-mutability ctc)) (lambda (b) (define proj - ((contract-projection elem/c) (blame-add-context b "an element of"))) - (lambda (s) - (id-set-contract-check idsettype mutability b s) - (for ([e (in-set s)]) (proj e)) + ((contract-late-neg-projection elem/c) (blame-add-context b "an element of"))) + (lambda (s neg-party) + (id-set-contract-check idsettype mutability b s neg-party) + (for ([e (in-set s)]) (proj e neg-party)) s))) -(define (id-set-contract-projection ctc) +(define (id-set-late-neg-contract-projection ctc) (define elem/c (id-set-contract-elem/c ctc)) (define idsettype (id-set-contract-idsettype ctc)) (define mutability (id-set-contract-mutability ctc)) (lambda (b) (define neg-proj - ((contract-projection elem/c) (blame-add-context b "an element of" #:swap? #t))) - (lambda (s) - (id-set-contract-check idsettype mutability b s) + ((contract-late-neg-projection elem/c) (blame-add-context b "an element of" #:swap? #t))) + (lambda (s neg-party) + (id-set-contract-check idsettype mutability b s neg-party) (cond [(immutable-free-id-set? s) (chaperone-immutable-free-id-set - s (free-id-table/c neg-proj any/c #:immutable #t))] + s (free-id-table/c (λ (v) (neg-proj v neg-party)) any/c #:immutable #t))] [(mutable-free-id-set? s) (chaperone-mutable-free-id-set - s (free-id-table/c neg-proj any/c #:immutable #f))] + s (free-id-table/c (λ (v) (neg-proj v neg-party)) any/c #:immutable #f))] [(immutable-bound-id-set? s) (chaperone-immutable-bound-id-set - s (bound-id-table/c neg-proj any/c #:immutable #t))] + s (bound-id-table/c (λ (v) (neg-proj v neg-party)) any/c #:immutable #t))] [(mutable-bound-id-set? s) (chaperone-mutable-bound-id-set - s (bound-id-table/c neg-proj any/c #:immutable #f))])))) + s (bound-id-table/c (λ (v) (neg-proj v neg-party)) any/c #:immutable #f))])))) (struct flat-id-set-contract id-set-contract [] @@ -147,14 +147,14 @@ (build-flat-contract-property #:name id-set-contract-name #:first-order flat-id-set-contract-first-order - #:projection flat-id-set-contract-projection)) + #:late-neg-projection flat-id-set-late-neg-contract-projection)) (struct chaperone-id-set-contract id-set-contract [] #:property prop:chaperone-contract (build-chaperone-contract-property #:name id-set-contract-name #:first-order id-set-contract-first-order - #:projection id-set-contract-projection)) + #:late-neg-projection id-set-late-neg-contract-projection)) (define-syntax (provide-contracted-id-set-fns stx) (syntax-parse stx diff --git a/racket/collects/syntax/id-table.rkt b/racket/collects/syntax/id-table.rkt index ef62869be1..1a70a3986c 100644 --- a/racket/collects/syntax/id-table.rkt +++ b/racket/collects/syntax/id-table.rkt @@ -56,7 +56,7 @@ (let () (define (proj acc location swap) (lambda (ctc blame) - ((contract-projection (acc ctc)) + ((contract-late-neg-projection (acc ctc)) (blame-add-context blame location #:swap? swap)))) (values (proj base-id-table/c-dom "the keys of" #f) @@ -96,51 +96,53 @@ (and (contract-first-order-passes? dom-ctc k) (contract-first-order-passes? rng-ctc v)))))) - (define (check-id-table/c ctc val blame) + (define (check-id-table/c ctc val blame neg-party) (define immutable (base-id-table/c-immutable ctc)) (case immutable [(#t) (unless (immutable-idtbl? val) - (raise-blame-error blame val + (raise-blame-error blame val #:missing-party neg-party '(expected "an immutable ~a," given: "~e") 'idtbl val))] [(#f) (unless (mutable-idtbl? val) - (raise-blame-error blame val + (raise-blame-error blame val #:missing-party neg-party '(expected "a mutable ~a," given: "~e") 'idtbl val))] [(dont-care) (unless (idtbl? val) - (raise-blame-error blame val + (raise-blame-error blame val #:missing-party neg-party '(expected "a ~a," given: "~e") 'idtbl val))])) - (define (fo-projection ctc) + (define (late-neg-fo-projection ctc) (λ (blame) (define dom-proj (id-table/c-dom-pos-proj ctc blame)) (define rng-proj (id-table/c-rng-pos-proj ctc blame)) - (λ (val) - (check-id-table/c ctc val blame) + (λ (val neg-party) + (check-id-table/c ctc val blame neg-party) (for ([(k v) (in-dict val)]) - (dom-proj k) - (rng-proj v)) + (dom-proj k neg-party) + (rng-proj v neg-party)) val))) - (define (ho-projection ctc) + (define (late-neg-ho-projection ctc) (lambda (blame) (define pos-dom-proj (id-table/c-dom-pos-proj ctc blame)) (define neg-dom-proj (id-table/c-dom-neg-proj ctc blame)) (define pos-rng-proj (id-table/c-rng-pos-proj ctc blame)) (define neg-rng-proj (id-table/c-rng-neg-proj ctc blame)) - (lambda (tbl) - (check-id-table/c ctc tbl blame) + (lambda (tbl neg-party) + (check-id-table/c ctc tbl blame neg-party) ;;TODO for immutable hash tables optimize this chaperone to a flat ;;check if possible (if (immutable-idtbl? tbl) - (chaperone-immutable-id-table tbl pos-dom-proj pos-rng-proj + (chaperone-immutable-id-table tbl + (λ (val) (pos-dom-proj val neg-party)) + (λ (val) (pos-rng-proj val neg-party)) impersonator-prop:contracted ctc) (chaperone-mutable-id-table tbl - neg-dom-proj - pos-dom-proj - neg-rng-proj - pos-rng-proj + (λ (val) (neg-dom-proj val neg-party)) + (λ (val) (pos-dom-proj val neg-party)) + (λ (val) (neg-rng-proj val neg-party)) + (λ (val) (pos-rng-proj val neg-party)) impersonator-prop:contracted ctc))))) (struct flat-id-table/c base-id-table/c () @@ -149,7 +151,7 @@ (build-flat-contract-property #:name id-table/c-name #:first-order id-table/c-first-order - #:projection fo-projection)) + #:late-neg-projection late-neg-fo-projection)) (struct chaperone-id-table/c base-id-table/c () #:omit-define-syntaxes @@ -157,7 +159,7 @@ (build-chaperone-contract-property #:name id-table/c-name #:first-order id-table/c-first-order - #:projection ho-projection)) + #:late-neg-projection late-neg-ho-projection)) ;; Note: impersonator contracts not currently supported. (struct impersonator-id-table/c base-id-table/c () @@ -166,7 +168,7 @@ (build-contract-property #:name id-table/c-name #:first-order id-table/c-first-order - #:projection ho-projection)) + #:late-neg-projection late-neg-ho-projection)) (define (id-table/c key/c value/c #:immutable [immutable 'dont-care]) (define key/ctc (coerce-contract idtbl/c-symbol key/c)) @@ -197,9 +199,12 @@ idtbl-set! idtbl-set idtbl-remove! idtbl-remove idtbl-set/constructor idtbl-remove/constructor + idtbl-set* idtbl-set*/constructor idtbl-set*! idtbl-ref! + idtbl-update idtbl-update/constructor idtbl-update! idtbl-count idtbl-iterate-first idtbl-iterate-next idtbl-iterate-key idtbl-iterate-value + idtbl-keys idtbl-values in-idtbl idtbl-map idtbl-for-each idtbl-mutable-methods idtbl-immutable-methods idtbl/c)) @@ -231,6 +236,13 @@ (idtbl-set/constructor d id v immutable-idtbl)) (define (idtbl-remove d id) (idtbl-remove/constructor d id immutable-idtbl)) + (define (idtbl-set* d . rst) + (apply idtbl-set*/constructor d immutable-idtbl rst)) + (define not-given (gensym 'not-given)) + (define (idtbl-update d id updater [default not-given]) + (if (eq? default not-given) + (idtbl-update/constructor d id updater immutable-idtbl) + (idtbl-update/constructor d id updater immutable-idtbl default))) (define idtbl-immutable-methods (vector-immutable idtbl-ref #f @@ -278,6 +290,28 @@ (-> mutable-idtbl? identifier? void?)] [idtbl-remove (-> immutable-idtbl? identifier? immutable-idtbl?)] + [idtbl-set* + (->* [immutable-idtbl?] + #:rest (flat-rec-contract key-value-pairs + (or/c null + (cons/c identifier? (cons/c any/c key-value-pairs)))) + immutable-idtbl?)] + [idtbl-set*! + (->* [mutable-idtbl?] + #:rest (flat-rec-contract key-value-pairs + (or/c null + (cons/c identifier? (cons/c any/c key-value-pairs)))) + void?)] + [idtbl-ref! + (-> mutable-idtbl? identifier? any/c any)] + [idtbl-update + (->* [immutable-idtbl? identifier? (-> any/c any/c)] + [any/c] + immutable-idtbl?)] + [idtbl-update! + (->* [mutable-idtbl? identifier? (-> any/c any/c)] + [any/c] + void?)] [idtbl-count (-> idtbl? exact-nonnegative-integer?)] [idtbl-iterate-first @@ -288,6 +322,12 @@ (-> idtbl? id-table-iter? identifier?)] [idtbl-iterate-value (-> idtbl? id-table-iter? any)] + [idtbl-keys + (-> idtbl? (listof identifier?))] + [idtbl-values + (-> idtbl? list?)] + [in-idtbl + (-> idtbl? sequence?)] [idtbl-map (-> idtbl? (-> identifier? any/c any) list?)] [idtbl-for-each diff --git a/racket/collects/syntax/intdef.rkt b/racket/collects/syntax/intdef.rkt new file mode 100644 index 0000000000..1c97e9ad61 --- /dev/null +++ b/racket/collects/syntax/intdef.rkt @@ -0,0 +1,14 @@ +(module intdef '#%kernel + (#%provide internal-definition-context-track) + + (define-values (internal-definition-context-track) + (lambda (intdef stx) + (if (internal-definition-context? intdef) + (if (syntax? stx) + (let-values ([(ids) (internal-definition-context-binding-identifiers intdef)]) + (if (null? ids) + stx + (let-values ([(v) (syntax-property stx 'disappeared-binding)]) + (syntax-property stx 'disappeared-binding (if v (cons ids v) ids))))) + (raise-argument-error 'internal-definition-context-track "syntax?" 1 intdef stx)) + (raise-argument-error 'internal-definition-context-track "internal-definition-context?" 0 intdef stx))))) diff --git a/racket/collects/syntax/parse/experimental/provide.rkt b/racket/collects/syntax/parse/experimental/provide.rkt index 848a2fec7c..25829ec138 100644 --- a/racket/collects/syntax/parse/experimental/provide.rkt +++ b/racket/collects/syntax/parse/experimental/provide.rkt @@ -150,7 +150,7 @@ (if (flat-contract? ctc) (flat-named-contract name (flat-contract-predicate ctc)) (let* ([ctc-fo (contract-first-order ctc)] - [proj (contract-projection ctc)]) + [late-neg-proj (contract-late-neg-projection ctc)]) (make-contract #:name name - #:projection proj + #:late-neg-projection late-neg-proj #:first-order ctc-fo))))) diff --git a/racket/collects/syntax/parse/experimental/reflect.rkt b/racket/collects/syntax/parse/experimental/reflect.rkt index e0c6f76b53..6d16e87522 100644 --- a/racket/collects/syntax/parse/experimental/reflect.rkt +++ b/racket/collects/syntax/parse/experimental/reflect.rkt @@ -125,20 +125,20 @@ (#: any/c ...) #:rest list? (or/c reified-syntax-class? reified-splicing-syntax-class/c)) - #:projection + #:late-neg-projection (lambda (blame) (let ([check-reified - ((contract-projection + ((contract-late-neg-projection (or/c reified-syntax-class? reified-splicing-syntax-class?)) (blame-swap blame))]) - (lambda (f) + (lambda (f neg-party) (if (and (procedure? f) (procedure-arity-includes? f 1)) (make-keyword-procedure (lambda (kws kwargs r . args) - (keyword-apply f kws kwargs (check-reified r) args))) + (keyword-apply f kws kwargs (check-reified r neg-party) args))) (raise-blame-error - blame + blame #:missing-party neg-party f "expected a procedure of at least one argument, given ~e" f))))) diff --git a/racket/collects/syntax/private/id-table.rkt b/racket/collects/syntax/private/id-table.rkt index f1d7fb9a42..b7c0ad745c 100644 --- a/racket/collects/syntax/private/id-table.rkt +++ b/racket/collects/syntax/private/id-table.rkt @@ -136,6 +136,47 @@ The {key,value}-{in-out} functions should all return a chaperone of their argume (hash-remove (id-table-hash d) sym)) phase))) +(define (id-table-set*! who d identifier->symbol identifier=? . rst) + (let loop ([rst rst]) + (cond [(null? rst) (void)] + [else + (id-table-set! + who d + (car rst) (cadr rst) + identifier->symbol identifier=?) + (loop (cddr rst))]))) + +(define (id-table-set*/constructor who d constructor identifier->symbol identifier=? . rst) + (let loop ([d d] [rst rst]) + (if (null? rst) + d + (loop (id-table-set/constructor + who d + (car rst) (cadr rst) + constructor identifier->symbol identifier=?) + (cddr rst))))) + +(define missing (gensym 'missing)) +(define (id-table-ref! who d id default identifier->symbol identifier=?) + (define entry (id-table-ref who d id missing identifier->symbol identifier=?)) + (cond [(eq? entry missing) + (id-table-set! who d id default identifier->symbol identifier=?) + default] + [else entry])) + +(define (id-table-update/constructor who d id updater default constructor identifier->symbol identifier=?) + (define entry + (id-table-ref who d id default identifier->symbol identifier=?)) + (id-table-set/constructor + who d id + (updater entry) + constructor identifier->symbol identifier=?)) + +(define (id-table-update! who d id updater default identifier->symbol identifier=?) + (define entry + (id-table-ref who d id default identifier->symbol identifier=?)) + (id-table-set! who d id (updater entry) identifier->symbol identifier=?)) + (define (id-table-count d) (for/sum ([(k v) (in-hash (id-table-hash d))]) (length v))) @@ -214,6 +255,35 @@ Notes (FIXME?): ;; ======== +(define (id-table-keys who d) + (let do-keys ([pos (id-table-iterate-first d)]) + (if (not pos) + null + (cons (id-table-iterate-key who d pos) + (do-keys (id-table-iterate-next who d pos)))))) + +(define (id-table-values who d identifier->symbol identifier=?) + (let do-values ([pos (id-table-iterate-first d)]) + (if (not pos) + null + (cons (id-table-iterate-value who d pos identifier->symbol identifier=?) + (do-values (id-table-iterate-next who d pos)))))) + +(define (in-id-table who d identifier->symbol identifier=?) + (make-do-sequence + (λ () + (values + (λ (pos) + (values + (id-table-iterate-key who d pos) + (id-table-iterate-value who d pos identifier->symbol identifier=?))) + (λ (pos) (id-table-iterate-next who d pos)) + (id-table-iterate-first d) + values + #f #f)))) + +;; ======== + (define (alist-set identifier=? phase l0 id v) ;; To minimize allocation ;; - add new pairs to front @@ -283,9 +353,12 @@ Notes (FIXME?): idtbl-set! idtbl-set idtbl-remove! idtbl-remove idtbl-set/constructor idtbl-remove/constructor + idtbl-set* idtbl-set*/constructor idtbl-set*! idtbl-ref! + idtbl-update idtbl-update/constructor idtbl-update! idtbl-count idtbl-iterate-first idtbl-iterate-next idtbl-iterate-key idtbl-iterate-value + idtbl-keys idtbl-values in-idtbl idtbl-map idtbl-for-each idtbl-mutable-methods idtbl-immutable-methods)) #'(begin @@ -317,6 +390,16 @@ Notes (FIXME?): (id-table-remove/constructor 'idtbl-remove d id constructor identifier->symbol identifier=?)) (define (idtbl-remove d id) (idtbl-remove/constructor d id immutable-idtbl)) + (define (idtbl-set*/constructor d constructor . rst) + (apply id-table-set*/constructor 'idtbl-set* d constructor identifier->symbol identifier=? rst)) + (define (idtbl-set*! d . rst) + (apply id-table-set*! 'idtbl-set*! d identifier->symbol identifier=? rst)) + (define (idtbl-ref! d id default) + (id-table-ref! 'idtbl-ref! d id default identifier->symbol identifier=?)) + (define (idtbl-update/constructor d id updater constructor [default not-given]) + (id-table-update/constructor 'idtbl-update d id updater default constructor identifier->symbol identifier=?)) + (define (idtbl-update! d id updater [default not-given]) + (id-table-update! 'idtbl-update! d id updater default identifier->symbol identifier=?)) (define (idtbl-count d) (id-table-count d)) (define (idtbl-for-each d p) @@ -331,6 +414,12 @@ Notes (FIXME?): (id-table-iterate-key 'idtbl-iterate-key d pos)) (define (idtbl-iterate-value d pos) (id-table-iterate-value 'idtbl-iterate-value d pos identifier->symbol identifier=?)) + (define (idtbl-keys d) + (id-table-keys 'idtbl-keys d)) + (define (idtbl-values d) + (id-table-values 'idtbl-values d identifier->symbol identifier=?)) + (define (in-idtbl d) + (in-id-table 'in-idtbl d identifier->symbol identifier=?)) (define idtbl-mutable-methods (vector-immutable idtbl-ref @@ -381,6 +470,9 @@ Notes (FIXME?): idtbl-set idtbl-remove! idtbl-remove + idtbl-set*! + idtbl-ref! + idtbl-update! idtbl-count idtbl-iterate-first idtbl-iterate-next @@ -388,10 +480,15 @@ Notes (FIXME?): idtbl-iterate-value idtbl-map idtbl-for-each + idtbl-keys + idtbl-values + in-idtbl ;; just for use/extension by syntax/id-table idtbl-set/constructor + idtbl-set*/constructor idtbl-remove/constructor + idtbl-update/constructor idtbl-mutable-methods mutable-idtbl immutable-idtbl)))])) diff --git a/racket/collects/version/utils.rkt b/racket/collects/version/utils.rkt index 001e2e2b68..c69f5572d7 100644 --- a/racket/collects/version/utils.rkt +++ b/racket/collects/version/utils.rkt @@ -1,7 +1,5 @@ #lang racket/base - -(provide valid-version? version->list versioninteger) +(require (for-syntax racket/base)) (define rx:version ;; (this restricts the last component to be below 999 too, which is @@ -13,10 +11,21 @@ (define (valid-version? s) (and (string? s) (regexp-match? rx:version s))) -;; the following functions assume valid version string inputs +(define-syntax (define/version-inputs stx) + (syntax-case stx () + [(_ (f x ...) body ...) + #'(define (f x ...) + (check-version-inputs 'f (list x ...)) + body ...)])) +(define (check-version-inputs fn args) + (for ([arg (in-list args)] + [i (in-naturals)]) + (unless (valid-version? arg) + (apply raise-argument-error fn "valid-version?" i args)))) + ;; returns a list of 4 integers (see src/racket/src/schvers.h) -(define (version->list str) +(define/version-inputs (version->list str) (define ver (map string->number (regexp-split #rx"[.]" str))) (case (length ver) [(2) (append ver '(0 0))] @@ -24,17 +33,20 @@ [(4) ver] [else (error 'version->list "bad version: ~e" str)])) -(define (versionlist a)] [b (version->list b)]) (cond [(null? a) #f] [(< (car a) (car b)) #t] [(> (car a) (car b)) #f] [else (loop (cdr a) (cdr b))]))) -(define (version<=? a b) - (or (equal? a b) (versionlist v)) (or ((list-ref l 1) . >= . 90) ((list-ref l 2) . >= . 900) @@ -69,3 +81,81 @@ (and v (valid-version? v) (foldl (λ (ver mul acc) (+ ver (* mul acc))) 0 (version->list v) '(0 100 1000 1000)))) + +(define-syntax-rule + (provide+save-in-list exported-functions (x p?) ...) + (begin + (provide x ...) + (module+ test (define exported-functions (list (cons x p?) ...))))) + +(provide+save-in-list + exported-functions + (valid-version? boolean?) + (version->list (λ (x) (and (list? x) (= (length x) 4) (andmap integer? x)))) + (versioninteger (λ (x) (or (integer? x) (not x))))) + +(module+ test + (require racket/list) + + (define (random-argument) + (case (random 10) + [(1) + ;; random string of digits, periods lowercase letters, and greek letters + (define candidates + (append (build-list 10 (λ (x) (integer->char (+ x (char->integer #\a))))) + (build-list 10 (λ (x) (integer->char (+ x (char->integer #\0))))) + (build-list 10 (λ (x) (integer->char (+ x (char->integer #\α))))) + '(#\.))) + (apply + string + (for/list ([i (in-range (random 100))]) + (list-ref candidates (random (length candidates)))))] + [(0) + ;; kind of versionish (periods and digits in 100 chars) + (apply + string + (for/list ([i (in-range (random 100))]) + (case (random 4) + [(0) #\.] + [else (integer->char (+ (random 10) (char->integer #\0)))])))] + [else + ;; much closer to a version; + ;; at most 6 fields of digits that are + ;; between 1 and 4 chars in length + (apply + string-append + (add-between + (for/list ([i (in-range (+ 1 (random 5)))]) + (apply + string + (for/list ([i (in-range (random 4))]) + (integer->char (+ (random 10) (char->integer #\0)))))) + "."))])) + + (define (trial f+p) + (define f (car f+p)) + (define p (cdr f+p)) + (define args (for/list ([i (in-range (procedure-arity f))]) + (random-argument))) + (define (check-exn exn) + (define m (regexp-match #rx"^([^:]*):" (exn-message exn))) + (if (equal? (string->symbol (list-ref m 1)) + (object-name f)) + #f + args)) + (with-handlers ([exn:fail? check-exn]) + (if (p (apply f args)) + #f + args))) + + (time + (let/ec give-up + (for ([f+p (in-list exported-functions)]) + (for ([_ (in-range 100)]) + (define trial-result (trial f+p)) + (when trial-result + (eprintf "failed: ~s\n" (cons (object-name (car f+p)) trial-result)) + (give-up))))))) diff --git a/racket/collects/xml/private/structures.rkt b/racket/collects/xml/private/structures.rkt index cbd46deda3..9fc8985447 100644 --- a/racket/collects/xml/private/structures.rkt +++ b/racket/collects/xml/private/structures.rkt @@ -43,16 +43,16 @@ (define permissive/c (make-contract #:name 'permissive/c - #:projection + #:late-neg-projection (lambda (blame) - (lambda (v) + (lambda (v neg-party) (if (permissive-xexprs) v (raise-blame-error - blame v "not in permissive mode")))) + blame #:missing-party neg-party + v "not in permissive mode")))) #:first-order - (lambda (v) - (permissive-xexprs)))) + (lambda (v) #t))) ; content? : TST -> Bool (define content/c diff --git a/racket/collects/xml/private/xexpr-core.rkt b/racket/collects/xml/private/xexpr-core.rkt index c2211213ed..66c883f1b2 100644 --- a/racket/collects/xml/private/xexpr-core.rkt +++ b/racket/collects/xml/private/xexpr-core.rkt @@ -42,14 +42,14 @@ (define xexpr/c (make-flat-contract - #:name 'xexpr? - #:projection + #:name 'xexpr/c + #:late-neg-projection (lambda (blame) - (lambda (val) + (lambda (val neg-party) (with-handlers ([exn:invalid-xexpr? (lambda (exn) (raise-blame-error - blame + blame #:missing-party neg-party val "Not an Xexpr. ~a\n\nContext:\n~a" (exn-message exn) diff --git a/racket/collects/xml/private/xexpr.rkt b/racket/collects/xml/private/xexpr.rkt index 5dbad64766..940deeee64 100644 --- a/racket/collects/xml/private/xexpr.rkt +++ b/racket/collects/xml/private/xexpr.rkt @@ -78,7 +78,7 @@ ;; xexpr->string : Xexpression -> String (define (xexpr->string xexpr) (let ([port (open-output-string)]) - (write-xml/content (xexpr->xml xexpr) port) + (write-xexpr xexpr port) (get-output-string port))) (define (string->xexpr str) diff --git a/racket/src/configure b/racket/src/configure index dbc52ea48d..86e48fb970 100755 --- a/racket/src/configure +++ b/racket/src/configure @@ -4792,6 +4792,11 @@ fi PREFLAGS="$PREFLAGS -DOS_X -D_DARWIN_UNLIMITED_SELECT" try_kqueue_syscall=yes + # Although select() generally works as well as poll() on OS X, + # getdtablesize() appears not to be constant within a process, + # and that breaks static allocation of fd_sets + try_poll_syscall=yes + # ".a" is typically not useful, since we always build a ".dylib": if test "${enable_libs}" == "" ; then INSTALL_LIBS_ENABLE=no-install @@ -5793,6 +5798,32 @@ if test "${has_builtin_popcount}" = "yes" ; then $as_echo "#define MZ_HAS_BUILTIN_POPCOUNT 1" >>confdefs.h +fi + + msg="for __builtin_clz" +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $msg" >&5 +$as_echo_n "checking $msg... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + int main(int argc, char **argv) { + unsigned int i = argc; + return __builtin_clz(i); + } +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + has_builtin_clz=yes +else + has_builtin_clz=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $has_builtin_clz" >&5 +$as_echo "$has_builtin_clz" >&6; } +if test "${has_builtin_clz}" = "yes" ; then + +$as_echo "#define MZ_HAS_BUILTIN_CLZ 1" >>confdefs.h + fi if test "${enable_backtrace}" = "yes" ; then @@ -6583,6 +6614,11 @@ $as_echo "#define MZ_NO_EXTFLONUMS 1" >>confdefs.h fi fi +if test "${enable_extflonum}" = "yes" ; then + $as_echo "#define MZ_INSIST_EXTFLONUMS 1" >>confdefs.h + +fi + ############## libffi ################ # Depends on pthread on some platforms diff --git a/racket/src/mac/osx_appl.rkt b/racket/src/mac/osx_appl.rkt index e9f83c924e..4230d0e2c1 100644 --- a/racket/src/mac/osx_appl.rkt +++ b/racket/src/mac/osx_appl.rkt @@ -112,7 +112,8 @@ (assoc-pair "CFBundleShortVersionString" ,(version)) (assoc-pair "NSPrincipalClass" "NSApplicationMain") - (assoc-pair "NSHighResolutionCapable" (true)))) + (assoc-pair "NSHighResolutionCapable" (true)) + (assoc-pair "NSSupportsAutomaticGraphicsSwitching" (true)))) (create-app (build-path (current-directory) (if for-3m? 'up 'same)) (string-append "GRacket" suffix) diff --git a/racket/src/native-libs/README.txt b/racket/src/native-libs/README.txt index 6d8a2d0aa8..8d174f7e68 100644 --- a/racket/src/native-libs/README.txt +++ b/racket/src/native-libs/README.txt @@ -123,7 +123,7 @@ Build Steps (assuming no version changes) where contains the package "source" directories, such as "draw-win32-i386". The is normally a - checkout of "https://github.com/plt/libs.git". + checkout of "https://github.com/racket/libs.git". Details ------- diff --git a/racket/src/native-libs/build-all.rkt b/racket/src/native-libs/build-all.rkt index d13ff7ec50..5ba42c0682 100644 --- a/racket/src/native-libs/build-all.rkt +++ b/racket/src/native-libs/build-all.rkt @@ -18,11 +18,11 @@ (cond [(or win? linux?) '("sqlite" - "openssl" "zlib")] [else null]) - '("expat" + '("openssl" + "expat" "gettext") (cond [linux? diff --git a/racket/src/native-libs/build.rkt b/racket/src/native-libs/build.rkt index 506ea17b63..29dcc51512 100644 --- a/racket/src/native-libs/build.rkt +++ b/racket/src/native-libs/build.rkt @@ -116,6 +116,9 @@ ;; Avoid CGFontGetGlyphPath: (define-runtime-path cairo-cgfontgetglpyh-patch "patches/cgfontgetglyph.patch") +;; Patch to avoid writing to a global constant: +(define-runtime-path cairo-allclipmodifybug-patch "patches/allclipmodifybug.patch") + ;; Hack to workaround broken Courier New in Mac OS X 10.{7.8}: (define-runtime-path courier-new-patch "patches/courier-new.patch") @@ -125,6 +128,9 @@ ;; Support registration of extra font families: (define-runtime-path coretext-fontreg-patch "patches/coretext-fontreg.patch") +;; Avoid crash when CTFontCollectionCreateMatchingFontDescriptors fails: +(define-runtime-path coretext-nullarray "patches/coretext-nullarray.patch") + ;; Enable "symbol" fonts, and fix off-by-one: (define-runtime-path win32text-patch "patches/win32text.patch") @@ -308,21 +314,33 @@ (~a "cd " (build-path dest "bin") " && mv libsqlite3-0.dll sqlite3.dll")))] [("openssl") - (nonmac-only) + (define make + (if linux? + (~a "make SHARED_LDFLAGS=" "-Wl,-rpath," dest "/lib") + "make")) (config #:configure-exe (find-executable-path "sh") - #:configure (if win? - (list "./Configure" - (~a "--cross-compile-prefix=" win-prefix "-") - #f ; other flags here - (~a "mingw" (if m32? "" "64")) - "shared") - (list "./Configure" - #f - "shared" - "linux-x86_64")) - #:make (if linux? - (~a "make SHARED_LDFLAGS=" "-Wl,-rpath," dest "/lib") - "make"))] + #:configure (cond + [win? + (list "./Configure" + (~a "--cross-compile-prefix=" win-prefix "-") + #f ; other flags here + (~a "mingw" (if m32? "" "64")) + "shared")] + [mac? + (list "./Configure" + #f + "shared" + (cond + [ppc? "darwin-ppc-cc"] + [m32? "darwin-i386-cc"] + [else "darwin64-x86_64-cc"]))] + [else + (list "./Configure" + #f + "shared" + "linux-x86_64")]) + #:make make + #:make-install (~a make " install_sw"))] [("expat") (config)] [("gettext") (config #:depends (if win? '("libiconv") '()) #:configure '("--enable-languages=c") @@ -419,6 +437,7 @@ null) #:patches (list cairo-coretext-patch cairo-cgfontgetglpyh-patch + cairo-allclipmodifybug-patch courier-new-patch win32cairofallback-patch))] [("harfbuzz") (config #:depends '("fontconfig" "freetype" "cairo") @@ -437,6 +456,7 @@ "--with-dynamic-modules=no")) #:patches (list coretext-patch coretext-fontreg-patch + coretext-nullarray win32text-patch))] [("gmp") (config #:patches (if gcc-4.0? (list gmp-weak-patch) null) #:configure (append diff --git a/racket/src/native-libs/install.rkt b/racket/src/native-libs/install.rkt index 728d9e72ad..5f7ce5657d 100644 --- a/racket/src/native-libs/install.rkt +++ b/racket/src/native-libs/install.rkt @@ -39,6 +39,10 @@ "zlib1" "libpangowin32-1.0.0")) +(define nonwin-libs + '("libcrypto.1.0.0" + "libssl.1.0.0")) + (define linux-libs (append '("libXau.6" @@ -49,9 +53,7 @@ "libXext.6" "libXrender.1" "fonts") - '("libcrypto.1.0.0" - "libssl.1.0.0" - "libz.1" + '("libz.1" "libsqlite3.0") '("libgtk-x11-2.0.0" "libgdk-x11-2.0.0" @@ -262,7 +264,7 @@ #:exists 'truncate (lambda (o) (displayln pkg-name o) - (displayln "Copyright (c) 2010-2015 PLT Design Inc." o) + (displayln "Copyright (c) 2010-2016 PLT Design Inc." o) (newline o) (displayln "This package is distributed under the GNU Lesser General Public" o) (displayln "License (LGPL). This means that you can link this package into" o) @@ -323,13 +325,15 @@ (define (install-mac) (define (fixup p p-new) (printf "Fixing ~s\n" p-new) + (unless (memq 'write (file-or-directory-permissions p-new)) + (file-or-directory-permissions p-new #o744)) (system (format "install_name_tool -id ~a ~a" (file-name-from-path p-new) p-new)) (for-each (lambda (s) (system (format "install_name_tool -change ~a @loader_path/~a ~a" (format "~a/~a.dylib" from s) (format "~a.dylib" s) p-new))) - libs) + (append libs nonwin-libs)) (system (format "strip -S ~a" p-new))) (define platform (~a (if m32? @@ -337,7 +341,7 @@ "x86_64") "-macosx")) - (install platform platform "dylib" fixup libs)) + (install platform platform "dylib" fixup (append libs nonwin-libs))) (define (install-win) (define exe-prefix (if m32? @@ -398,6 +402,7 @@ (install platform platform add-so fixup (append (remove* linux-remove-libs libs) + nonwin-libs linux-libs))) (cond diff --git a/racket/src/native-libs/patches/allclipmodifybug.patch b/racket/src/native-libs/patches/allclipmodifybug.patch new file mode 100644 index 0000000000..3824c8fef3 --- /dev/null +++ b/racket/src/native-libs/patches/allclipmodifybug.patch @@ -0,0 +1,17 @@ +diff -u -r old/cairo-1.12.16/src/cairo-clip-boxes.c new/cairo-1.12.16/src/cairo-clip-boxes.c +--- old/cairo-1.12.16/src/cairo-clip-boxes.c 2015-11-06 15:46:30.000000000 -0700 ++++ new/cairo-1.12.16/src/cairo-clip-boxes.c 2015-11-06 15:47:36.000000000 -0700 +@@ -172,8 +172,11 @@ + if (clip->path == NULL) { + clip->extents = *r; + } else { +- if (! _cairo_rectangle_intersect (&clip->extents, r)) ++ if (! _cairo_rectangle_intersect (&clip->extents, r)) { + clip = _cairo_clip_set_all_clipped (clip); ++ /* return so that there's no attempt to modify `clip`: */ ++ return clip; ++ } + } + if (clip->path == NULL) + clip->is_region = _cairo_box_is_pixel_aligned (box); +Only in new/cairo-1.12.16/src: cairo-clip-boxes.c~ diff --git a/racket/src/native-libs/patches/cgfontgetglyph.patch b/racket/src/native-libs/patches/cgfontgetglyph.patch index bde65a327e..c936bb52f4 100644 --- a/racket/src/native-libs/patches/cgfontgetglyph.patch +++ b/racket/src/native-libs/patches/cgfontgetglyph.patch @@ -1,6 +1,6 @@ -diff -u -r old/cairo-1.12.16/src/cairo-quartz-font.c new/cairo-1.12.16/src/cairo-quartz-font.c ---- old/cairo-1.12.16/src/cairo-quartz-font.c 2015-09-06 17:07:39.000000000 -0600 -+++ new/cairo-1.12.16/src/cairo-quartz-font.c 2015-09-06 17:09:06.000000000 -0600 +diff -r -u old/cairo-1.12.16/src/cairo-quartz-font.c new/cairo-1.12.16/src/cairo-quartz-font.c +--- old/cairo-1.12.16/src/cairo-quartz-font.c 2015-11-04 15:21:19.000000000 -0700 ++++ new/cairo-1.12.16/src/cairo-quartz-font.c 2015-11-04 15:21:37.000000000 -0700 @@ -81,9 +81,6 @@ static void (*CGContextSetAllowsFontSmoothingPtr) (CGContextRef, bool) = NULL; static bool (*CGContextGetAllowsFontSmoothingPtr) (CGContextRef) = NULL; @@ -27,22 +27,50 @@ diff -u -r old/cairo-1.12.16/src/cairo-quartz-font.c new/cairo-1.12.16/src/cairo (CGFontGetHMetricsPtr || (CGFontGetAscentPtr && CGFontGetDescentPtr && CGFontGetLeadingPtr))) _cairo_quartz_font_symbols_present = TRUE; -@@ -592,6 +587,7 @@ +@@ -592,6 +587,8 @@ CGGlyph glyph = _cairo_quartz_scaled_glyph_index (scaled_glyph); CGAffineTransform textMatrix; CGPathRef glyphPath; + CTFontRef ctFont; ++ int empty_path; cairo_path_fixed_t *path; if (glyph == INVALID_GLYPH) { -@@ -606,7 +602,9 @@ +@@ -606,19 +603,32 @@ -font->base.scale.yy, 0, 0); - glyphPath = CGFontGetGlyphPathPtr (font_face->cgFont, &textMatrix, 0, glyph); +- if (!glyphPath) + ctFont = CTFontCreateWithGraphicsFont (font_face->cgFont, 1.0, NULL, NULL); + glyphPath = CTFontCreatePathForGlyph (ctFont, glyph, &textMatrix); ++ empty_path = 0; ++ if (!glyphPath) { ++ /* an empty glyph path may just reflect whitespace; check bounding rects */ ++ CGRect r; ++ r = CTFontGetBoundingRectsForGlyphs(ctFont, kCTFontHorizontalOrientation, &glyph, NULL, 1); ++ if (memcmp(&CGRectNull, &r, sizeof(CGRect))) ++ empty_path = 1; ++ } + CFRelease (ctFont); - if (!glyphPath) ++ if (!glyphPath && !empty_path) return CAIRO_INT_STATUS_UNSUPPORTED; + path = _cairo_path_fixed_create (); + if (!path) { +- CGPathRelease (glyphPath); ++ if (glyphPath) ++ CGPathRelease (glyphPath); + return _cairo_error(CAIRO_STATUS_NO_MEMORY); + } + +- CGPathApply (glyphPath, path, _cairo_quartz_path_apply_func); ++ if (glyphPath) ++ CGPathApply (glyphPath, path, _cairo_quartz_path_apply_func); + +- CGPathRelease (glyphPath); ++ if (glyphPath) ++ CGPathRelease (glyphPath); + + _cairo_scaled_glyph_set_path (scaled_glyph, &font->base, path); + diff --git a/racket/src/native-libs/patches/coretext-nullarray.patch b/racket/src/native-libs/patches/coretext-nullarray.patch new file mode 100644 index 0000000000..da247c600b --- /dev/null +++ b/racket/src/native-libs/patches/coretext-nullarray.patch @@ -0,0 +1,21 @@ +diff -r -u old/pango-1.36.6/pango/pangocoretext-fontmap.c new/pango-1.36.6/pango/pangocoretext-fontmap.c +--- old/pango-1.36.6/pango/pangocoretext-fontmap.c 2015-11-07 08:15:41.000000000 -0700 ++++ new/pango-1.36.6/pango/pangocoretext-fontmap.c 2015-11-07 08:16:56.000000000 -0700 +@@ -649,7 +649,7 @@ + + italic_faces = g_hash_table_new (g_direct_hash, g_direct_equal); + +- count = CFArrayGetCount (ctfaces); ++ count = (ctfaces ? CFArrayGetCount (ctfaces) : 0); + for (i = 0; i < count; i++) + { + PangoCoreTextFace *face; +@@ -669,7 +669,7 @@ + + CFRelease (font_descriptors); + CFRelease (attributes); +- CFRelease (ctfaces); ++ if (ctfaces) CFRelease (ctfaces); + + /* For all fonts for which a non-synthetic italic variant does + * not exist on the system, we create synthesized versions here. diff --git a/racket/src/pkgs-config.rkt b/racket/src/pkgs-config.rkt index d7401fa91b..84549ee756 100644 --- a/racket/src/pkgs-config.rkt +++ b/racket/src/pkgs-config.rkt @@ -34,8 +34,9 @@ ((length l) . >= . 1) (equal? (car l) catalog-relative-path-str))) (define has-src-catalog? - (member (if src-catalog-is-default? #f src-catalog) - l)) + (or (and src-catalog-is-default? + (member #f l)) + (member src-catalog l))) (unless (and starts-as-expected? has-src-catalog?) (error 'pkgs-catalog diff --git a/racket/src/racket/cmdline.inc b/racket/src/racket/cmdline.inc index 0d56b56019..a532da07f5 100644 --- a/racket/src/racket/cmdline.inc +++ b/racket/src/racket/cmdline.inc @@ -106,8 +106,6 @@ static void (*console_printf)(char *str, ...); # define PRINTF console_printf #endif -MZ_EXTERN void scheme_set_dll_path(wchar_t *s); - static void record_dll_path(void) { if (_dlldir[_dlldir_offset] != '<') { @@ -1544,6 +1542,24 @@ static int run_from_cmd_line(int argc, char *_argv[], if (getenv("PLTDISABLEGC")) { scheme_enable_garbage_collection(0); } + { + char *s; + s = getenv("PLT_INCREMENTAL_GC"); + if (s) { + if ((s[0] == '0') || (s[0] == 'n') || (s[0] == 'N')) + scheme_incremental_garbage_collection(0); + else if ((s[0] == '1') || (s[0] == 'y') || (s[0] == 'Y')) + scheme_incremental_garbage_collection(1); + else { + PRINTF("%s: unrecognized value for PLT_INCREMENTAL_GC;\n" + " a value that starts \"1\", \"y\", or \"Y\" permanently enables incremental mode,\n" + " and a value that starts \"0\", \"n\", or \"N\" disables incremental mode,\n" + " and the default enables incremental mode as requested via `collect-garbage'\n" + " unrecognized value: %s\n", + prog, s); + } + } + } #endif scheme_set_logging_spec(syslog_level, stderr_level); diff --git a/racket/src/racket/configure.ac b/racket/src/racket/configure.ac index 46b76c953f..e37b39ec5a 100644 --- a/racket/src/racket/configure.ac +++ b/racket/src/racket/configure.ac @@ -873,6 +873,11 @@ case "$host_os" in PREFLAGS="$PREFLAGS -DOS_X -D_DARWIN_UNLIMITED_SELECT" try_kqueue_syscall=yes + # Although select() generally works as well as poll() on OS X, + # getdtablesize() appears not to be constant within a process, + # and that breaks static allocation of fd_sets + try_poll_syscall=yes + # ".a" is typically not useful, since we always build a ".dylib": if test "${enable_libs}" == "" ; then INSTALL_LIBS_ENABLE=no-install @@ -1276,6 +1281,18 @@ if test "${has_builtin_popcount}" = "yes" ; then AC_DEFINE(MZ_HAS_BUILTIN_POPCOUNT,1,[Has __builtin_popcount]) fi +[ msg="for __builtin_clz" ] +AC_MSG_CHECKING($msg) +AC_LINK_IFELSE([AC_LANG_SOURCE([ + int main(int argc, char **argv) { + unsigned int i = argc; + return __builtin_clz(i); + }])], has_builtin_clz=yes, has_builtin_clz=no) +AC_MSG_RESULT($has_builtin_clz) +if test "${has_builtin_clz}" = "yes" ; then + AC_DEFINE(MZ_HAS_BUILTIN_CLZ,1,[Has __builtin_clz]) +fi + if test "${enable_backtrace}" = "yes" ; then GC2OPTIONS="$GC2OPTIONS -DMZ_GC_BACKTRACE" fi @@ -1475,6 +1492,10 @@ if test "${enable_extflonum}" = "default" ; then fi fi +if test "${enable_extflonum}" = "yes" ; then + AC_DEFINE(MZ_INSIST_EXTFLONUMS) +fi + ############## libffi ################ # Depends on pthread on some platforms diff --git a/racket/src/racket/dynsrc/mzdyn.c b/racket/src/racket/dynsrc/mzdyn.c index b0edc8e823..3261033ba6 100644 --- a/racket/src/racket/dynsrc/mzdyn.c +++ b/racket/src/racket/dynsrc/mzdyn.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995 Matthew Flatt All rights reserved. diff --git a/racket/src/racket/gc2/backtrace.c b/racket/src/racket/gc2/backtrace.c index 0d57afc930..0be2659c1c 100644 --- a/racket/src/racket/gc2/backtrace.c +++ b/racket/src/racket/gc2/backtrace.c @@ -12,7 +12,6 @@ trace_page_type TRACE_PAGE_TAGGED TRACE_PAGE_ARRAY - TRACE_PAGE_TAGGED_ARRAY TRACE_PAGE_ATOMIC TRACE_PAGE_PAIR TRACE_PAGE_MALLOCFREE @@ -73,8 +72,6 @@ static void *print_out_pointer(const char *prefix, void *p, what = NULL; } else if (trace_page_type(page) == TRACE_PAGE_ARRAY) { what = "ARRAY"; - } else if (trace_page_type(page) == TRACE_PAGE_TAGGED_ARRAY) { - what = "TARRAY"; } else if (trace_page_type(page) == TRACE_PAGE_ATOMIC) { what = "ATOMIC"; } else if (trace_page_type(page) == TRACE_PAGE_MALLOCFREE) { diff --git a/racket/src/racket/gc2/fnls.c b/racket/src/racket/gc2/fnls.c index 1eb83396f2..c7ce9b0b9b 100644 --- a/racket/src/racket/gc2/fnls.c +++ b/racket/src/racket/gc2/fnls.c @@ -23,39 +23,28 @@ #undef splay_insert #undef splay_delete -static void remove_finalizer(Fnl *fnl, int gen0, GCTYPE *gc) +static void remove_finalizer(Fnl *fnl, int lvl, GCTYPE *gc) { if (fnl->prev) fnl->prev->next = fnl->next; - else { - if (gen0) - gc->gen0_finalizers = fnl->next; - else - gc->finalizers = fnl->next; - } + else + gc->finalizers[lvl] = fnl->next; if (fnl->next) fnl->next->prev = fnl->prev; - if (gen0) - gc->splayed_gen0_finalizers = fnl_splay_delete((intptr_t)fnl->p, gc->splayed_gen0_finalizers); - else - gc->splayed_finalizers = fnl_splay_delete((intptr_t)fnl->p, gc->splayed_finalizers); + gc->splayed_finalizers[lvl] = fnl_splay_delete((intptr_t)fnl->p, gc->splayed_finalizers[lvl]); } -static void add_finalizer(Fnl *fnl, int gen0, GCTYPE *gc) +static void add_finalizer(Fnl *fnl, int lvl, GCTYPE *gc) { - fnl->next = (gen0 ? gc->gen0_finalizers : gc->finalizers); + fnl->next = gc->finalizers[lvl]; + fnl->prev = NULL; if (fnl->next) fnl->next->prev = fnl; - if (gen0) { - gc->gen0_finalizers = fnl; - gc->splayed_gen0_finalizers = fnl_splay_insert((intptr_t)fnl->p, fnl, gc->splayed_gen0_finalizers); - } else { - gc->finalizers = fnl; - gc->splayed_finalizers = fnl_splay_insert((intptr_t)fnl->p, fnl, gc->splayed_finalizers); - } + gc->finalizers[lvl] = fnl; + gc->splayed_finalizers[lvl] = fnl_splay_insert((intptr_t)fnl->p, fnl, gc->splayed_finalizers[lvl]); } void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *data), @@ -64,6 +53,7 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d { GCTYPE *gc = GC_get_GC(); Fnl *fnl; + int lvl; if (!is_finalizable_page(gc, p)) { /* Never collected. Don't finalize it. */ @@ -72,17 +62,18 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d return; } - gc->splayed_gen0_finalizers = fnl_splay((intptr_t)p, gc->splayed_gen0_finalizers); - fnl = gc->splayed_gen0_finalizers; - if (!fnl || (fnl->p != p)) { - gc->splayed_finalizers = fnl_splay((intptr_t)p, gc->splayed_finalizers); - fnl = gc->splayed_finalizers; - if (!fnl || (fnl->p != p)) + for (lvl = 0; lvl < NUM_FNL_LEVELS; lvl++) { + gc->splayed_finalizers[lvl] = fnl_splay((intptr_t)p, gc->splayed_finalizers[lvl]); + fnl = gc->splayed_finalizers[lvl]; + if (!fnl || (fnl->p != p)) { fnl = NULL; - else { - /* since we're mutating this finalizer, move it to the gen0 list and tree */ - remove_finalizer(fnl, 0, gc); - add_finalizer(fnl, 1, gc); + } else { + if (lvl > FNL_LEVEL_GEN_0) { + /* since we're mutating this finalizer, move it to the gen0 set */ + remove_finalizer(fnl, lvl, gc); + add_finalizer(fnl, FNL_LEVEL_GEN_0, gc); + } + break; } } @@ -95,7 +86,7 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d fnl->eager_level = level; } else { /* remove finalizer */ - remove_finalizer(fnl, 1, gc); + remove_finalizer(fnl, FNL_LEVEL_GEN_0, gc); --gc->num_fnls; } return; @@ -143,7 +134,7 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d } #endif - add_finalizer(fnl, 1, gc); + add_finalizer(fnl, FNL_LEVEL_GEN_0, gc); gc->num_fnls++; } @@ -151,14 +142,16 @@ static void merge_finalizer_trees(GCTYPE *gc) /* For a full GC, move all finalizers to the gen0 list */ { Fnl *fnl, *next; + int lvl; - for (fnl = gc->finalizers; fnl; fnl = next) { - next = fnl->next; - add_finalizer(fnl, 1, gc); + for (lvl = FNL_LEVEL_GEN_1; lvl < NUM_FNL_LEVELS; lvl++) { + for (fnl = gc->finalizers[lvl]; fnl; fnl = next) { + next = fnl->next; + add_finalizer(fnl, FNL_LEVEL_GEN_0, gc); + } + gc->finalizers[lvl] = NULL; + gc->splayed_finalizers[lvl] = NULL; } - - gc->finalizers = NULL; - gc->splayed_finalizers = NULL; } static void reset_finalizer_tree(GCTYPE *gc) @@ -168,9 +161,30 @@ static void reset_finalizer_tree(GCTYPE *gc) { Fnl *fnl, *next; - fnl = gc->gen0_finalizers; - gc->gen0_finalizers = NULL; - gc->splayed_gen0_finalizers = NULL; + if (gc->gc_full) { + GC_ASSERT(!gc->finalizers[FNL_LEVEL_INC_1]); + GC_ASSERT(!gc->splayed_finalizers[FNL_LEVEL_INC_1]); + GC_ASSERT(!gc->finalizers[FNL_LEVEL_INC_2]); + GC_ASSERT(!gc->splayed_finalizers[FNL_LEVEL_INC_2]); + if (gc->finished_incremental) { + fnl = gc->finalizers[FNL_LEVEL_GEN_1]; + for (; fnl; fnl = next) { + next = fnl->next; + add_finalizer(fnl, FNL_LEVEL_INC_3, gc); + } + gc->finalizers[FNL_LEVEL_GEN_1] = gc->finalizers[FNL_LEVEL_INC_3]; + gc->splayed_finalizers[FNL_LEVEL_GEN_1] = gc->splayed_finalizers[FNL_LEVEL_INC_3]; + gc->finalizers[FNL_LEVEL_INC_3] = NULL; + gc->splayed_finalizers[FNL_LEVEL_INC_3] = NULL; + } else { + GC_ASSERT(!gc->finalizers[FNL_LEVEL_INC_3]); + GC_ASSERT(!gc->splayed_finalizers[FNL_LEVEL_INC_3]); + } + } + + fnl = gc->finalizers[FNL_LEVEL_GEN_0]; + gc->finalizers[FNL_LEVEL_GEN_0] = NULL; + gc->splayed_finalizers[FNL_LEVEL_GEN_0] = NULL; for (; fnl; fnl = next) { next = fnl->next; @@ -182,9 +196,8 @@ static void reset_finalizer_tree(GCTYPE *gc) || is_in_generation_half(gc, fnl->f) || is_in_generation_half(gc, fnl->p) || is_in_generation_half(gc, fnl->data)) - add_finalizer(fnl, 1, gc); + add_finalizer(fnl, FNL_LEVEL_GEN_0, gc); else - add_finalizer(fnl, 0, gc); + add_finalizer(fnl, FNL_LEVEL_GEN_1, gc); } - } diff --git a/racket/src/racket/gc2/gc2.h b/racket/src/racket/gc2/gc2.h index db6adf9edb..724c99af58 100644 --- a/racket/src/racket/gc2/gc2.h +++ b/racket/src/racket/gc2/gc2.h @@ -31,12 +31,13 @@ typedef int (*Fixup_Proc)(void *obj); typedef int (*Fixup2_Proc)(void *obj, struct NewGC *); typedef void (*GC_collect_start_callback_Proc)(void); typedef void (*GC_collect_end_callback_Proc)(void); -typedef void (*GC_collect_inform_callback_Proc)(int master_gc, int major_gc, +typedef void (*GC_collect_inform_callback_Proc)(int master_gc, int major_gc, int inc_gc, intptr_t pre_used, intptr_t post_used, intptr_t pre_admin, intptr_t post_admin, intptr_t post_child_places_used); typedef uintptr_t (*GC_get_thread_stack_base_Proc)(void); typedef void (*GC_Post_Propagate_Hook_Proc)(struct NewGC *); +typedef int (*GC_Treat_As_Incremental_Mark_Proc)(void *p); /* Types of the traversal procs (supplied by Racket); see overview in README for information about traversals. The return value is the size of @@ -119,6 +120,7 @@ GC2_EXTERN GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_colle GC2_EXTERN GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc); GC2_EXTERN void GC_set_collect_inform_callback(GC_collect_inform_callback_Proc); GC2_EXTERN void GC_set_post_propagate_hook(GC_Post_Propagate_Hook_Proc); +GC2_EXTERN void GC_set_treat_as_incremental_mark(short tag, GC_Treat_As_Incremental_Mark_Proc); /* Sets callbacks called by GC before/after performing a collection. Used by Racket to zero out some data and record collection times. The end @@ -172,6 +174,11 @@ GC2_EXTERN void GC_request_incremental_mode(void); /* Requests incremental mode; lasts until the next major collection. */ +GC2_EXTERN void GC_set_incremental_mode(int on); +/* + Sets whether incremental mode is the default (1), always disabled (0), + or available on demand (-1). */ + GC2_EXTERN void GC_free_all(void); /* Releases all memory, removes all signal handlers, etc. @@ -380,8 +387,9 @@ GC2_EXTERN int GC_current_mode(struct NewGC *gc); # define GC_CURRENT_MODE_MINOR 0 # define GC_CURRENT_MODE_MAJOR 1 # define GC_CURRENT_MODE_INCREMENTAL 2 -# define GC_CURRENT_MODE_BACKPOINTER_REMARK 3 -# define GC_CURRENT_MODE_ACCOUNTING 4 +# define GC_CURRENT_MODE_INCREMENTAL_FINAL 3 +# define GC_CURRENT_MODE_BACKPOINTER_REMARK 4 +# define GC_CURRENT_MODE_ACCOUNTING 5 /* The mode during a mark or fixup function callback. The GC_CURRENT_MODE_BACKPOINTER_REMARK mode corresponds diff --git a/racket/src/racket/gc2/mem_account.c b/racket/src/racket/gc2/mem_account.c index fb13cf1b59..4aadc9f450 100644 --- a/racket/src/racket/gc2/mem_account.c +++ b/racket/src/racket/gc2/mem_account.c @@ -88,7 +88,7 @@ inline static void clean_up_thread_list(NewGC *gc) GC_Thread_Info *prev = NULL; while(work) { - if(!pagemap_find_page(gc->page_maps, work->thread) || marked(gc, work->thread)) { + if (marked(gc, work->thread)) { work->thread = GC_resolve2(work->thread, gc); prev = work; work = work->next; @@ -225,21 +225,27 @@ inline static void clean_up_owner_table(NewGC *gc) { OTEntry **owner_table = gc->owner_table; const int table_size = gc->owner_table_size; - int i; + int i, really_doing_accounting = 0; for(i = 1; i < table_size; i++) if(owner_table[i]) { /* repair or delete the originator */ if(!marked(gc, owner_table[i]->originator)) { owner_table[i]->originator = NULL; - } else + } else { owner_table[i]->originator = GC_resolve2(owner_table[i]->originator, gc); + if (((Scheme_Custodian *)owner_table[i]->originator)->really_doing_accounting) { + really_doing_accounting = 1; + } + } /* potential delete */ if(i != 1) if((owner_table[i]->memory_use == 0) && !owner_table[i]->originator) free_owner_set(gc, i); } + + gc->next_really_doing_accounting |= really_doing_accounting; } inline static uintptr_t custodian_usage(NewGC*gc, void *custodian) @@ -248,11 +254,13 @@ inline static uintptr_t custodian_usage(NewGC*gc, void *custodian) uintptr_t retval = 0; int i; + ((Scheme_Custodian *)custodian)->really_doing_accounting = 1; + if(!gc->really_doing_accounting) { if (!gc->avoid_collection) { CHECK_PARK_UNUSED(gc); gc->park[0] = custodian; - gc->really_doing_accounting = 1; + gc->next_really_doing_accounting = 1; garbage_collect(gc, 1, 0, 0, NULL); custodian = gc->park[0]; gc->park[0] = NULL; @@ -377,7 +385,8 @@ inline static void BTC_memory_account_mark(NewGC *gc, mpage *page, void *ptr, in if(info->btc_mark == gc->old_btc_mark) { info->btc_mark = gc->new_btc_mark; account_memory(gc, gc->current_mark_owner, info->size, 0); - push_ptr(gc, ptr, 0); + if (page->generation != AGE_GEN_HALF) + push_ptr(gc, ptr, 0); } } } @@ -462,15 +471,34 @@ static void btc_overmem_abort(NewGC *gc) "Info will be wrong.\n")); } -static void propagate_accounting_marks(NewGC *gc) +static void propagate_accounting_marks(NewGC *gc, int no_full) { void *p; + int fuel = (gc->gc_full + ? -1 + : (no_full + ? INCREMENTAL_COLLECT_FUEL_PER_100M / INCREMENTAL_MINOR_REQUEST_DIVISOR + : (INCREMENTAL_COLLECT_FUEL_PER_100M * AS_100M(gc->memory_in_use)) / 2)); - while(pop_ptr(gc, &p, 0) && !gc->kill_propagation_loop) { + while (pop_ptr(gc, &p, 0) && !gc->kill_propagation_loop) { + gc->traverse_count = 0; + /* GCDEBUG((DEBUGOUTF, "btc_account: popped off page %p:%p, ptr %p\n", page, page->addr, p)); */ propagate_marks_worker(gc, p, 0); + + if (fuel >= 0) { + fuel--; + fuel -= (gc->traverse_count >> 2); + if (gc->unprotected_page) { + gc->unprotected_page = 0; + fuel -= 100; + } + if (fuel <= 0) + break; + } } - if(gc->kill_propagation_loop) + + if (gc->kill_propagation_loop) reset_pointer_stack(gc); } @@ -491,11 +519,33 @@ inline static int BTC_get_redirect_tag(NewGC *gc, int tag) { return tag; } -static void BTC_do_accounting(NewGC *gc) +static void BTC_do_accounting(NewGC *gc, int no_full) { const int table_size = gc->owner_table_size; + int init_table_start, init_table_end, do_mark_threads; OTEntry **owner_table = gc->owner_table; + MarkSegment *orig_mark_stack; + GC_ASSERT(gc->gc_full || gc->finished_incremental); + GC_ASSERT(gc->gc_full || !gc->accounted_incremental); + + if (gc->gc_full) { + if (!gc->acct_mark_stack) + gc->really_doing_accounting = gc->next_really_doing_accounting; + gc->next_really_doing_accounting = 0; + } else { + if (gc->next_really_doing_accounting) + gc->really_doing_accounting = 1; + + GC_ASSERT(!gc->mark_gen1); + GC_ASSERT(!gc->inc_gen1); + GC_ASSERT(!gc->check_gen1); + + gc->mark_gen1 = 1; + gc->check_gen1 = 1; + gc->inc_gen1 = 1; + } + if(gc->really_doing_accounting) { Scheme_Custodian *cur = owner_table[current_owner(gc, NULL)]->originator, *last, *parent; Scheme_Custodian_Reference *box = cur->global_next; @@ -509,8 +559,31 @@ static void BTC_do_accounting(NewGC *gc) gc->unsafe_allocation_abort = btc_overmem_abort; gc->master_page_btc_mark_checked = 0; + if (!gc->gc_full || gc->acct_mark_stack) { + orig_mark_stack = gc->mark_stack; + if (gc->acct_mark_stack) { + gc->mark_stack = gc->acct_mark_stack; + init_table_start = 2; + do_mark_threads = 0; + } else { + gc->mark_stack = NULL; + mark_stack_initialize(gc); + init_table_start = 1; + do_mark_threads = 1; + } + if (gc->gc_full) + init_table_end = table_size; + else + init_table_end = 2; + } else { + orig_mark_stack = NULL; + init_table_start = 1; + init_table_end = table_size; + do_mark_threads = 1; + } + /* clear the memory use numbers out */ - for(i = 1; i < table_size; i++) + for(i = init_table_start; i < init_table_end; i++) if(owner_table[i]) { owner_table[i]->memory_use = 0; #ifdef MZ_USE_PLACES @@ -518,7 +591,7 @@ static void BTC_do_accounting(NewGC *gc) owner_table[i]->master_memory_use = 0; #endif } - + /* start with root: */ while (cur->parent && SCHEME_PTR1_VAL(cur->parent)) { cur = SCHEME_PTR1_VAL(cur->parent); @@ -529,55 +602,82 @@ static void BTC_do_accounting(NewGC *gc) last = cur; while(cur) { int owner = custodian_to_owner_set(gc, cur); - uintptr_t save_count = gc->phantom_count; - gc->phantom_count = 0; + GC_ASSERT(gc->gc_full || (owner == 1)); + + GC_ASSERT(owner >= 0); + GC_ASSERT(owner <= gc->owner_table_size); + + gc->acct_phantom_count = 0; gc->current_mark_owner = owner; GCDEBUG((DEBUGOUTF,"MARKING THREADS OF OWNER %i (CUST %p)\n", owner, cur)); gc->kill_propagation_loop = 0; - mark_threads(gc, owner); - mark_cust_boxes(gc, cur); + if (do_mark_threads) { + mark_threads(gc, owner); + mark_cust_boxes(gc, cur); + } GCDEBUG((DEBUGOUTF, "Propagating accounting marks\n")); - propagate_accounting_marks(gc); + propagate_accounting_marks(gc, no_full); + + owner_table = gc->owner_table; + owner_table[owner]->memory_use = add_no_overflow(owner_table[owner]->memory_use, + gcBYTES_TO_WORDS(gc->acct_phantom_count)); + + if (!gc->gc_full) + break; last = cur; box = cur->global_next; cur = box ? SCHEME_PTR1_VAL(box) : NULL; - owner_table = gc->owner_table; - owner_table[owner]->memory_use = add_no_overflow(owner_table[owner]->memory_use, - gcBYTES_TO_WORDS(gc->phantom_count)); - gc->phantom_count = save_count; + do_mark_threads = 1; } release_master_btc_mark(gc); - /* walk backward folding totals int parent */ - cur = last; - while (cur) { - int owner = custodian_to_owner_set(gc, cur); + if (gc->gc_full) { + /* walk backward folding totals into parent */ + cur = last; + while (cur) { + int owner = custodian_to_owner_set(gc, cur); - box = cur->parent; parent = box ? SCHEME_PTR1_VAL(box) : NULL; - if (parent) { - int powner = custodian_to_owner_set(gc, parent); + box = cur->parent; parent = box ? SCHEME_PTR1_VAL(box) : NULL; + if (parent) { + int powner = custodian_to_owner_set(gc, parent); - owner_table = gc->owner_table; - owner_table[powner]->memory_use = add_no_overflow(owner_table[powner]->memory_use, - owner_table[owner]->memory_use); - owner_table[powner]->master_memory_use += owner_table[owner]->master_memory_use; + owner_table = gc->owner_table; + owner_table[powner]->memory_use = add_no_overflow(owner_table[powner]->memory_use, + owner_table[owner]->memory_use); + owner_table[powner]->master_memory_use += owner_table[owner]->master_memory_use; + } + + box = cur->global_prev; cur = box ? SCHEME_PTR1_VAL(box) : NULL; } - box = cur->global_prev; cur = box ? SCHEME_PTR1_VAL(box) : NULL; + if (orig_mark_stack) { + free_stack_pages_at(gc->mark_stack); + gc->acct_mark_stack = NULL; + gc->mark_stack = orig_mark_stack; + } + } else { + gc->acct_mark_stack = gc->mark_stack; + gc->mark_stack = orig_mark_stack; } gc->in_unsafe_allocation_mode = 0; gc->doing_memory_accounting = 0; - gc->old_btc_mark = gc->new_btc_mark; - gc->new_btc_mark = !gc->new_btc_mark; + if (gc->gc_full) { + gc->old_btc_mark = gc->new_btc_mark; + gc->new_btc_mark = !gc->new_btc_mark; + } } - clear_stack_pages(gc); + if (!gc->gc_full) { + gc->mark_gen1 = 0; + gc->check_gen1 = 0; + gc->inc_gen1 = 0; + } } inline static void BTC_add_account_hook(int type,void *c1,void *c2,uintptr_t b) @@ -585,12 +685,14 @@ inline static void BTC_add_account_hook(int type,void *c1,void *c2,uintptr_t b) NewGC *gc = GC_get_GC(); AccountHook *work; + ((Scheme_Custodian *)c1)->really_doing_accounting = 1; + if(!gc->really_doing_accounting) { if (!gc->avoid_collection) { CHECK_PARK_UNUSED(gc); gc->park[0] = c1; gc->park[1] = c2; - gc->really_doing_accounting = 1; + gc->next_really_doing_accounting = 1; garbage_collect(gc, 1, 0, 0, NULL); c1 = gc->park[0]; gc->park[0] = NULL; c2 = gc->park[1]; gc->park[1] = NULL; diff --git a/racket/src/racket/gc2/newgc.c b/racket/src/racket/gc2/newgc.c index cbf66a94c9..63653dcaa1 100644 --- a/racket/src/racket/gc2/newgc.c +++ b/racket/src/racket/gc2/newgc.c @@ -102,7 +102,8 @@ enum { AGE_GEN_0 = 0, AGE_GEN_HALF = 1, AGE_GEN_1 = 2, - AGE_VACATED = 3 + AGE_VACATED = 3, /* used for pages to be removed */ + AGE_GEN_INC = 4 /* used for naming a finalizer set */ }; static const char *type_name[PAGE_TYPES] = { @@ -178,6 +179,7 @@ inline static int page_mmu_type(mpage *page); inline static int page_mmu_protectable(mpage *page); static void free_mpage(mpage *page); static void gen_half_free_mpage(NewGC *gc, mpage *work); +static int inc_marked_gen1(NewGC *gc, void *p); #if defined(MZ_USE_PLACES) && defined(GC_DEBUG_PAGES) static FILE* gcdebugOUT(NewGC *gc) { @@ -242,14 +244,31 @@ MAYBE_UNUSED static void GCVERBOSEprintf(NewGC *gc, const char *fmt, ...) { full collection. */ #define FULL_COLLECTION_SIZE_RATIO 2 +/* Extra factor allowed before forcing a non-incremental full collection + when incremental model is started: */ +#define INCREMENTAL_EXTRA_SIZE_RATIO 2 + +/* Avoid incremental GC if the heap seems to be getting too fragmented: */ +#define HIGH_FRAGMENTATION_RATIO 2 + /* Whether to use a little aging, moving gen-0 objects to a - gen-1/2 space; by default, enabled when memory use is high - enough: */ -#define AGE_GEN_0_TO_GEN_HALF(gc) ((gc)->memory_in_use > (GEN0_MAX_SIZE * 8)) + gen-1/2 space: */ +#define AGE_GEN_0_TO_GEN_HALF(gc) ((gc)->started_incremental) /* Incremental mode */ -#define ALWAYS_COLLECT_INCREMENTAL_ON_MINOR 0 -#define INCREMENTAL_COLLECT_FUEL (16 * 1024) +static int always_collect_incremental_on_minor = 0; +static int never_collect_incremental_on_minor = 0; +#define INCREMENTAL_COLLECT_FUEL_PER_100M (4 * 1024) +#define INCREMENTAL_REPAIR_FUEL_PER_100M 32 + +/* Shrink the nursery in incremental mode, so that we more frequently + work on a major collection. Tune this parameter in combination with + the fuel parameters above. */ +#define GEN0_INCREMENTAL_MAX_DIVISOR 4 + +/* Factor to shrink incremental-mode fuel when a GC is triggered by + (collect-garbage 'minor): */ +#define INCREMENTAL_MINOR_REQUEST_DIVISOR 1 /* Conservatively force a major GC after a certain number of minor GCs. It should be ok to set this value @@ -257,6 +276,8 @@ MAYBE_UNUSED static void GCVERBOSEprintf(NewGC *gc, const char *fmt, ...) { seems to have been excessively conservative. */ #define FORCE_MAJOR_AFTER_COUNT 1000 +#define AS_100M(c) ((c / (1024 * 1024 * 100)) + 1) + /* This is the log base 2 of the size of one word, given in bytes */ #ifdef SIXTY_FOUR_BIT_INTEGERS # define LOG_WORD_SIZE 3 @@ -307,6 +328,12 @@ void GC_set_collect_inform_callback(GC_collect_inform_callback_Proc func) { gc->GC_collect_inform_callback = func; } +void GC_set_treat_as_incremental_mark(short tag, GC_Treat_As_Incremental_Mark_Proc func) { + NewGC *gc = GC_get_GC(); + gc->treat_as_incremental_mark_hook = func; + gc->treat_as_incremental_mark_tag = tag; +} + void GC_set_post_propagate_hook(GC_Post_Propagate_Hook_Proc func) { NewGC *gc = GC_get_GC(); gc->GC_post_propagate_hook = func; @@ -1340,7 +1367,9 @@ static int TAKE_SLOW_PATH() #endif inline static size_t gen0_size_in_use(NewGC *gc) { - return (gc->gen0.current_size + ((GC_gen0_alloc_page_ptr - NUM(gc->gen0.curr_alloc_page->addr)) - PREFIX_SIZE)); + return (gc->gen0.current_size + (gc->gen0.curr_alloc_page + ? ((GC_gen0_alloc_page_ptr - NUM(gc->gen0.curr_alloc_page->addr)) - PREFIX_SIZE) + : 0)); } #define BYTES_MULTIPLE_OF_WORD_TO_WORDS(sizeb) ((sizeb) >> gcLOG_WORD_SIZE) @@ -1392,7 +1421,9 @@ inline static uintptr_t allocate_slowpath(NewGC *gc, size_t allocate_size, uintp #ifdef INSTRUMENT_PRIMITIVES LOG_PRIM_START(((void*)garbage_collect)); #endif - + + gc->gen0.curr_alloc_page = NULL; /* so the memory use is not counted */ + collect_now(gc, 0, 0); #ifdef INSTRUMENT_PRIMITIVES @@ -1636,10 +1667,19 @@ uintptr_t add_no_overflow(uintptr_t a, uintptr_t b) return c; } +uintptr_t subtract_no_underflow(uintptr_t a, uintptr_t b) +{ + if (a >= b) + return a-b; + else + return 0; +} + int GC_allocate_phantom_bytes(void *pb, intptr_t request_size_bytes) { NewGC *gc = GC_get_GC(); mpage *page; + int inc_count; #ifdef NEWGC_BTC_ACCOUNT if (request_size_bytes > 0) { @@ -1657,20 +1697,30 @@ int GC_allocate_phantom_bytes(void *pb, intptr_t request_size_bytes) page = pagemap_find_page(gc->page_maps, pb); + if (page->generation >= AGE_GEN_1) + inc_count = inc_marked_gen1(gc, pb); + else + inc_count = 0; + if (request_size_bytes < 0) { request_size_bytes = -request_size_bytes; - if (!page || (page->generation < AGE_GEN_1)) { - if (gc->gen0_phantom_count > request_size_bytes) - gc->gen0_phantom_count -= request_size_bytes; - } else { - if (gc->memory_in_use > request_size_bytes) - gc->memory_in_use -= request_size_bytes; + if (!page || (page->generation < AGE_GEN_1)) + gc->gen0_phantom_count = subtract_no_underflow(gc->gen0_phantom_count, request_size_bytes); + else { + gc->memory_in_use = subtract_no_underflow(gc->memory_in_use, request_size_bytes); + gc->phantom_count = subtract_no_underflow(gc->phantom_count, request_size_bytes); + if (inc_count) + gc->inc_phantom_count = subtract_no_underflow(gc->inc_phantom_count, request_size_bytes); } } else { if (!page || (page->generation < AGE_GEN_1)) gc->gen0_phantom_count = add_no_overflow(gc->gen0_phantom_count, request_size_bytes); - else + else { gc->memory_in_use = add_no_overflow(gc->memory_in_use, request_size_bytes); + gc->phantom_count = add_no_overflow(gc->phantom_count, request_size_bytes); + if (inc_count) + gc->inc_phantom_count = add_no_overflow(gc->inc_phantom_count, request_size_bytes); + } } /* If we've allocated enough phantom bytes, then force a GC */ @@ -1976,12 +2026,16 @@ inline static void master_set_max_size(NewGC *gc) inline static void reset_nursery(NewGC *gc) { uintptr_t new_gen0_size; - + new_gen0_size = NUM((GEN0_SIZE_FACTOR * (float)gc->memory_in_use) + GEN0_SIZE_ADDITION); if ((new_gen0_size > GEN0_MAX_SIZE) || (gc->memory_in_use > GEN0_MAX_SIZE)) /* => overflow */ new_gen0_size = GEN0_MAX_SIZE; + if (gc->started_incremental + && (new_gen0_size > (GEN0_MAX_SIZE / GEN0_INCREMENTAL_MAX_DIVISOR))) + new_gen0_size = GEN0_MAX_SIZE / GEN0_INCREMENTAL_MAX_DIVISOR; + resize_gen0(gc, new_gen0_size); } @@ -2015,11 +2069,6 @@ inline static mpage *pagemap_find_page_for_marking(NewGC *gc, const void *p, int return page; } -/* This procedure fundamentally returns true if a pointer is marked, and - false if it isn't. This function assumes that you're talking, at this - point, purely about the mark field of the object. It ignores things like - the object not being one of our GC heap objects, being in a higher gen - than we're collecting, not being a pointer at all, etc. */ inline static int marked(NewGC *gc, const void *p) { mpage *page; @@ -2029,30 +2078,53 @@ inline static int marked(NewGC *gc, const void *p) if(!p) return 0; if(!(page = pagemap_find_page_for_marking(gc, p, gc->check_gen1))) return 1; switch(page->size_class) { - case SIZE_CLASS_BIG_PAGE_MARKED: - return 1; case SIZE_CLASS_SMALL_PAGE: - if (page->generation >= AGE_GEN_1) { - if((NUM(page->addr) + page->scan_boundary) > NUM(p)) + if ((page->generation >= AGE_GEN_1) && !gc->inc_gen1) { + GC_ASSERT(!gc->finished_incremental); + if ((NUM(page->addr) + page->scan_boundary) > NUM(p)) return 1; } /* else FALLTHROUGH */ case SIZE_CLASS_MED_PAGE: /* FALLTHROUGH */ - return OBJPTR_TO_OBJHEAD(p)->mark; + if (page->non_dead_as_mark) { + /* Shouldn't reference a dead object! */ + GC_ASSERT(!OBJPTR_TO_OBJHEAD(p)->dead); + return 1; + } else + return OBJPTR_TO_OBJHEAD(p)->mark; break; case SIZE_CLASS_BIG_PAGE: return 0; - break; + case SIZE_CLASS_BIG_PAGE_MARKED: + return 1; default: fprintf(stderr, "ABORTING! INVALID SIZE_CLASS %i\n", page->size_class); abort(); } } +/* Used outside of GC when an incremental GC might be in progress */ +static int inc_marked_gen1(NewGC *gc, void *p) +{ + if (gc->started_incremental) { + int r; + GC_ASSERT(!gc->check_gen1); + GC_ASSERT(!gc->inc_gen1); + gc->check_gen1 = 1; + gc->inc_gen1 = 1; + r = marked(gc, p); + gc->check_gen1 = 0; + gc->inc_gen1 = 0; + return r; + } else + return 0; +} + static int is_in_generation_half(NewGC *gc, const void *p) { mpage *page; - if (gc->gc_full) return 0; + if (gc->gc_full) /* generation half is never used for a full GC */ + return 0; page = pagemap_find_page_for_marking(gc, p, 1); if (!page) return 0; GC_ASSERT((page->generation == AGE_GEN_1) @@ -2072,9 +2144,12 @@ int GC_current_mode(struct NewGC *gc) return GC_CURRENT_MODE_ACCOUNTING; else if (gc->gc_full) return GC_CURRENT_MODE_MAJOR; - else if (gc->inc_gen1) - return GC_CURRENT_MODE_INCREMENTAL; - else + else if (gc->inc_gen1) { + if (gc->fnl_gen1) + return GC_CURRENT_MODE_INCREMENTAL_FINAL; + else + return GC_CURRENT_MODE_INCREMENTAL; + } else return GC_CURRENT_MODE_MINOR; } @@ -2413,39 +2488,54 @@ static int is_finalizable_page(NewGC *gc, void *p) #include "fnls.c" -inline static void mark_finalizer_structs(NewGC *gc) +inline static void mark_finalizer_structs(NewGC *gc, int lvl) { Fnl *fnl; - set_backtrace_source(gc, &gc->gen0_finalizers, BT_ROOT); - gcMARK2(gc->gen0_finalizers, gc); - for(fnl = gc->gen0_finalizers; fnl; fnl = fnl->next) { + set_backtrace_source(gc, &gc->finalizers[lvl], BT_ROOT); + gcMARK2(gc->finalizers[lvl], gc); + for(fnl = gc->finalizers[lvl]; fnl; fnl = fnl->next) { set_backtrace_source(gc, fnl, BT_FINALIZER); gcMARK2(fnl->data, gc); - set_backtrace_source(gc, &gc->gen0_finalizers, BT_ROOT); + set_backtrace_source(gc, &gc->finalizers[lvl], BT_ROOT); gcMARK2(fnl->next, gc); } - - set_backtrace_source(gc, &gc->run_queue, BT_ROOT); - gcMARK2(gc->run_queue, gc); - for(fnl = gc->run_queue; fnl; fnl = fnl->next) { - set_backtrace_source(gc, fnl, BT_FINALIZER); - gcMARK2(fnl->data, gc); - gcMARK2(fnl->p, gc); - set_backtrace_source(gc, &gc->gen0_finalizers, BT_ROOT); - gcMARK2(fnl->next, gc); + + if (lvl == FNL_LEVEL_GEN_0) { + set_backtrace_source(gc, &gc->run_queue, BT_ROOT); + gcMARK2(gc->run_queue, gc); + for(fnl = gc->run_queue; fnl; fnl = fnl->next) { + set_backtrace_source(gc, fnl, BT_FINALIZER); + gcMARK2(fnl->data, gc); + gcMARK2(fnl->p, gc); + set_backtrace_source(gc, &gc->run_queue, BT_ROOT); + gcMARK2(fnl->next, gc); + } + + set_backtrace_source(gc, &gc->inc_run_queue, BT_ROOT); + gcMARK2(gc->inc_run_queue, gc); + for(fnl = gc->inc_run_queue; fnl; fnl = fnl->next) { + set_backtrace_source(gc, fnl, BT_FINALIZER); + gcMARK2(fnl->data, gc); + gcMARK2(fnl->p, gc); + set_backtrace_source(gc, &gc->inc_run_queue, BT_ROOT); + gcMARK2(fnl->next, gc); + } } -} +} inline static void repair_finalizer_structs(NewGC *gc) { Fnl *fnl; /* repair the base parts of the list */ - gcFIXUP2(gc->gen0_finalizers, gc); + gcFIXUP2(gc->finalizers[FNL_LEVEL_GEN_0], gc); gcFIXUP2(gc->run_queue, gc); + gcFIXUP2(gc->last_in_queue, gc); + gcFIXUP2(gc->inc_run_queue, gc); + gcFIXUP2(gc->inc_last_in_queue, gc); /* then repair the stuff inside them */ - for(fnl = gc->gen0_finalizers; fnl; fnl = fnl->next) { + for(fnl = gc->finalizers[FNL_LEVEL_GEN_0]; fnl; fnl = fnl->next) { gcFIXUP2(fnl->data, gc); gcFIXUP2(fnl->p, gc); gcFIXUP2(fnl->next, gc); @@ -2456,36 +2546,80 @@ inline static void repair_finalizer_structs(NewGC *gc) gcFIXUP2(fnl->p, gc); gcFIXUP2(fnl->next, gc); } + for(fnl = gc->inc_run_queue; fnl; fnl = fnl->next) { + gcFIXUP2(fnl->data, gc); + gcFIXUP2(fnl->p, gc); + gcFIXUP2(fnl->next, gc); + } } -inline static void check_finalizers(NewGC *gc, int level) +static void merge_run_queues(NewGC *gc) { - Fnl *work = GC_resolve2(gc->gen0_finalizers, gc); + if (gc->inc_run_queue) { + gc->inc_last_in_queue->next = gc->run_queue; + gc->run_queue = gc->inc_run_queue; + if (!gc->last_in_queue) + gc->last_in_queue = gc->inc_last_in_queue; + gc->inc_run_queue = NULL; + gc->inc_last_in_queue = NULL; + } +} + +inline static int check_finalizers(NewGC *gc, int level, int old_gen, int fuel) +{ + int lvl = (old_gen + ? (FNL_LEVEL_GEN_1 + level - 1) + : FNL_LEVEL_GEN_0); + Fnl *work = GC_resolve2(gc->finalizers[lvl], gc); Fnl *prev = NULL; + if (!fuel) return 0; + GCDEBUG((DEBUGOUTF, "CFNL: Checking level %i finalizers\n", level)); while(work) { + if (!fuel) { + GC_ASSERT(old_gen); + return 0; + } + if (fuel > 0) { + fuel -= 4; + if (fuel < 0) fuel = 0; + } + if((work->eager_level == level) && !marked(gc, work->p)) { - struct finalizer *next = GC_resolve2(work->next, gc); + struct finalizer *next; GCDEBUG((DEBUGOUTF, "CFNL: Level %i finalizer %p on %p queued for finalization.\n", work->eager_level, work, work->p)); set_backtrace_source(gc, work, BT_FINALIZER); gcMARK2(work->p, gc); - if (prev) - prev->next = next; - else - gc->gen0_finalizers = next; - if (next) - next->prev = work->prev; - work->prev = NULL; /* queue is singly-linked */ - work->left = NULL; - work->right = NULL; - if (gc->last_in_queue) - gc->last_in_queue = gc->last_in_queue->next = work; - else - gc->run_queue = gc->last_in_queue = work; + if (old_gen) { + remove_finalizer(work, lvl, gc); + next = gc->finalizers[lvl]; + + if (gc->inc_last_in_queue) + gc->inc_last_in_queue = gc->inc_last_in_queue->next = work; + else + gc->inc_run_queue = gc->inc_last_in_queue = work; + } else { + next = GC_resolve2(work->next, gc); + if (prev) + prev->next = next; + else + gc->finalizers[lvl] = next; + if (next) + next->prev = work->prev; + work->prev = NULL; /* queue is singly-linked */ + work->left = NULL; + work->right = NULL; + + if (gc->last_in_queue) + gc->last_in_queue = gc->last_in_queue->next = work; + else + gc->run_queue = gc->last_in_queue = work; + } + work->next = NULL; --gc->num_fnls; @@ -2495,13 +2629,23 @@ inline static void check_finalizers(NewGC *gc, int level) GCDEBUG((DEBUGOUTF, "CFNL: Not finalizing %p (level %i on %p): %p / %i\n", work, work->eager_level, work->p, pagemap_find_page(gc->page_maps, work->p), marked(work->p))); - p = GC_resolve2(work->p, gc); - if (p != work->p) - work->p = p; - prev = work; - work = GC_resolve2(work->next, gc); + if (old_gen) { + /* Move to next set of finalizers */ + GC_ASSERT(lvl < FNL_LEVEL_INC_3); + remove_finalizer(work, lvl, gc); + add_finalizer(work, lvl+1, gc); + work = gc->finalizers[lvl]; + } else { + p = GC_resolve2(work->p, gc); + if (p != work->p) + work->p = p; + prev = work; + work = GC_resolve2(work->next, gc); + } } } + + return fuel; } /*****************************************************************************/ @@ -2534,7 +2678,24 @@ static int mark_phantom(void *p, struct NewGC *gc) { Phantom_Bytes *pb = (Phantom_Bytes *)p; - gc->phantom_count = add_no_overflow(gc->phantom_count, pb->count); + if (!gc->during_backpointer) { + if (gc->doing_memory_accounting) + gc->acct_phantom_count = add_no_overflow(gc->acct_phantom_count, pb->count); + else if (gc->inc_gen1) + gc->inc_phantom_count = add_no_overflow(gc->inc_phantom_count, pb->count); + else { + mpage *page = ((gc->use_gen_half && !gc->inc_gen1) + ? pagemap_find_page(gc->page_maps, pb) + : NULL); + if (page && (page->generation == AGE_GEN_HALF)) { + gc->gen0_phantom_count = add_no_overflow(gc->gen0_phantom_count, pb->count); + } else { + gc->phantom_count = add_no_overflow(gc->phantom_count, pb->count); + if (gc->started_incremental && !gc->gc_full) + gc->inc_phantom_count = add_no_overflow(gc->inc_phantom_count, pb->count); + } + } + } return gcBYTES_TO_WORDS(sizeof(Phantom_Bytes)); } @@ -2627,11 +2788,25 @@ static void push_ptr(NewGC *gc, void *ptr, int inc_gen1) } #endif - GC_ASSERT(inc_gen1 || !gc->inc_gen1); + GC_ASSERT(inc_gen1 || !gc->inc_gen1 || gc->doing_memory_accounting); + GC_ASSERT(!inc_gen1 || !gc->all_marked_incremental); push_ptr_at(ptr, inc_gen1 ? &gc->inc_mark_stack : &gc->mark_stack); } +static int mark_stack_is_empty(MarkSegment *mark_stack) +{ + if (!mark_stack) + return 1; + else if (mark_stack->top == MARK_STACK_START(mark_stack)) { + if (mark_stack->prev) + return 0; + else + return 1; + } else + return 0; +} + inline static int pop_ptr_at(void **ptr, MarkSegment **_mark_stack) { MarkSegment *mark_stack = *_mark_stack; @@ -2826,8 +3001,25 @@ static inline void propagate_marks_worker(NewGC *gc, void *pp, int inc_gen1); #ifdef NEWGC_BTC_ACCOUNT # include "mem_account.c" -#else -# define clean_up_thread_list() /* */ + +static void BTC_clean_up_gen1(NewGC *gc) +{ + if (gc->started_incremental && !gc->gc_full) { + /* Need to check marked() for old generation, too */ + GC_ASSERT(!gc->check_gen1); + GC_ASSERT(!gc->inc_gen1); + gc->check_gen1 = 1; + gc->inc_gen1 = 1; + } + + BTC_clean_up(gc); + + if (gc->started_incremental && !gc->gc_full) { + gc->check_gen1 = 0; + gc->inc_gen1 = 0; + } +} + #endif void GC_register_root_custodian(void *c) @@ -2932,10 +3124,18 @@ static int designate_modified_gc(NewGC *gc, void *p) mpage *page = pagemap_find_page(gc->page_maps, p); if (gc->no_further_modifications) { - if (page && (page->generation >= AGE_GEN_1) && gc->inc_gen1 && page->mprotected) { - /* Some marking functions, like the one for weak boxes, - update the record, so it's ok to make the page writable. */ + if (page && (page->generation >= AGE_GEN_1) && page->mprotected + /* Some marking functions, like the one for weak boxes, + update the record, so it's ok to make the page writable. */ + && (gc->inc_gen1 + /* Finalization in incremental mode can touch otherwise + pages that are otherwise unmodified in the current pass: */ + || gc->fnl_gen1 + /* Memory accounting can also modify otherwise unadjusted + pages after incremental mode: */ + || (gc->doing_memory_accounting && gc->finished_incremental))) { check_incremental_unprotect(gc, page); + gc->unprotected_page = 1; /* for using fuel */ return 1; } GCPRINT(GCOUTF, "Seg fault (internal error during gc) at %p\n", p); @@ -2984,11 +3184,11 @@ void GC_allow_master_gc_check() { static void NewGCMasterInfo_initialize() { int i; MASTERGCINFO = ofm_malloc_zero(sizeof(NewGCMasterInfo)); - MASTERGCINFO->size = 32; + MASTERGCINFO->size = 4; MASTERGCINFO->alive = 0; MASTERGCINFO->ready = 0; MASTERGCINFO->signal_fds = (void **)ofm_malloc(sizeof(void*) * MASTERGCINFO->size); - for (i=0; i < 32; i++ ) { + for (i=0; i < MASTERGCINFO->size; i++ ) { MASTERGCINFO->signal_fds[i] = (void *)REAPED_SLOT_AVAILABLE; } mzrt_rwlock_create(&MASTERGCINFO->cangc); @@ -3157,7 +3357,6 @@ static intptr_t NewGCMasterInfo_find_free_id() { void **new_signal_fds; size = MASTERGCINFO->size * 2; - MASTERGCINFO->alive++; new_signal_fds = ofm_malloc(sizeof(void*) * size); memcpy(new_signal_fds, MASTERGCINFO->signal_fds, sizeof(void*) * MASTERGCINFO->size); @@ -3165,6 +3364,8 @@ static intptr_t NewGCMasterInfo_find_free_id() { new_signal_fds[i] = (void *)REAPED_SLOT_AVAILABLE; } + ofm_free(MASTERGCINFO->signal_fds, sizeof(void*) * MASTERGCINFO->size); + MASTERGCINFO->signal_fds = new_signal_fds; MASTERGCINFO->size = size; } @@ -3245,7 +3446,6 @@ static void NewGC_initialize(NewGC *newgc, NewGC *inheritgc, NewGC *parentgc) { newgc->generations_available = 1; newgc->last_full_mem_use = (20 * 1024 * 1024); - newgc->inc_mem_use_threshold = (FULL_COLLECTION_SIZE_RATIO * newgc->inc_mem_use_threshold); newgc->new_btc_mark = 1; newgc->place_memory_limit = (uintptr_t)(intptr_t)-1; @@ -3301,6 +3501,8 @@ static NewGC *init_type_tags_worker(NewGC *inheritgc, NewGC *parentgc, GC_add_roots(&gc->park_fsave, (char *)&gc->park_fsave + sizeof(gc->park_fsave) + 1); GC_add_roots(&gc->park_isave, (char *)&gc->park_isave + sizeof(gc->park_isave) + 1); + gc->weak_incremental_done = WEAK_INCREMENTAL_DONE_1; + return gc; } @@ -3464,9 +3666,20 @@ void GC_gcollect_minor(void) void GC_request_incremental_mode(void) { - NewGC *gc = GC_get_GC(); + if (!never_collect_incremental_on_minor) { + NewGC *gc = GC_get_GC(); - gc->incremental_requested = 1; + /* The request will expire gradually, so that an extra major GC will + be triggered if incremental mode hasn't been requested recently + enough: */ + gc->incremental_requested = 8; + } +} + +void GC_set_incremental_mode(int on) +{ + always_collect_incremental_on_minor = (on > 0); + never_collect_incremental_on_minor = !on; } void GC_enable_collection(int on) @@ -3516,6 +3729,7 @@ intptr_t GC_get_memory_use(void *o) } #endif amt = add_no_overflow(gen0_size_in_use(gc), gc->memory_in_use); + amt = add_no_overflow(amt, gc->gen0_phantom_count); #ifdef MZ_USE_PLACES mzrt_mutex_lock(gc->child_total_lock); amt = add_no_overflow(amt, gc->child_gc_total); @@ -3532,15 +3746,14 @@ intptr_t GC_get_memory_use(void *o) static void check_incremental_unprotect(NewGC *gc, mpage *page) { /* must be due to incremental GC */ - GC_ASSERT(!gc->gc_full); - GC_ASSERT(gc->mark_gen1); + GC_ASSERT(!gc->gc_full || gc->finished_incremental); if (page->mprotected) { page->mprotected = 0; mmu_write_unprotect_page(gc->mmu, page->addr, real_page_size(page), page_mmu_type(page), &page->mmu_src_block); page->reprotect_next = gc->reprotect_next; gc->reprotect_next = page; - page->reprotect = 1; /* in case this page is used to hold moved gen0 objects */ + page->reprotect = 1; } } @@ -3548,9 +3761,16 @@ static void page_newly_marked_on(NewGC *gc, mpage *page, int is_a_master_page, i { if (inc_gen1) { GC_ASSERT(!page->inc_marked_on); + /* If this page isn't already marked as old, it must be a medium page whose + generation will be updated in the clean-up phase */ + GC_ASSERT((page->generation >= AGE_GEN_1) || (page->size_class == SIZE_CLASS_MED_PAGE)); + GC_ASSERT(!gc->finished_incremental || (!gc->accounted_incremental && gc->really_doing_accounting)); + GC_ASSERT(!page->non_dead_as_mark); page->inc_marked_on = 1; page->inc_modified_next = gc->inc_modified_next; gc->inc_modified_next = page; + if (!gc->inc_repair_next) + gc->inc_repair_next = page; } else { GC_ASSERT(!page->marked_on); page->marked_on = 1; @@ -3686,6 +3906,10 @@ void GC_mark2(void *pp, struct NewGC *gc) /* in this case, it has not. So we want to mark it, first off. */ page->size_class = SIZE_CLASS_BIG_PAGE_MARKED; + GC_ASSERT((page->generation < AGE_GEN_1) + || is_a_master_page + || (!gc->all_marked_incremental && !gc->finished_incremental)); + /* if this is in the nursery, we want to move it out of the nursery */ if((page->generation == AGE_GEN_0) && !is_a_master_page) { GC_ASSERT(!gc->inc_gen1); @@ -3709,9 +3933,20 @@ void GC_mark2(void *pp, struct NewGC *gc) int inc_gen1; if (info->mark) { GCDEBUG((DEBUGOUTF,"Not marking %p (already marked)\n", p)); + GC_ASSERT(!page->non_dead_as_mark); RELEASE_PAGE_LOCK(is_a_master_page, page); return; } + if (page->non_dead_as_mark) { + GC_ASSERT(gc->mark_gen1); + GC_ASSERT(page->generation >= AGE_GEN_1); + GC_ASSERT(!info->dead); + RELEASE_PAGE_LOCK(is_a_master_page, page); + return; + } + GC_ASSERT((page->generation < AGE_GEN_1) + || is_a_master_page + || (!gc->all_marked_incremental && !gc->finished_incremental)); if ((page->generation == AGE_GEN_0) || gc->gc_full) { GC_ASSERT(!gc->inc_gen1); inc_gen1 = 0; @@ -3719,6 +3954,7 @@ void GC_mark2(void *pp, struct NewGC *gc) if (is_a_master_page) inc_gen1 = 0; else { + GC_ASSERT(!gc->all_marked_incremental && !gc->finished_incremental); inc_gen1 = 1; check_incremental_unprotect(gc, page); } @@ -3737,12 +3973,17 @@ void GC_mark2(void *pp, struct NewGC *gc) if(ohead->mark) { GCDEBUG((DEBUGOUTF,"Not marking %p (already marked)\n", p)); + GC_ASSERT(!page->non_dead_as_mark); RELEASE_PAGE_LOCK(is_a_master_page, page); if (ohead->moved) *(void **)pp = *(void **)p; return; } + GC_ASSERT((page->generation < AGE_GEN_1) + || is_a_master_page + || (!gc->all_marked_incremental && !gc->finished_incremental)); + /* what we do next depends on whether this is a gen0, gen_half, or gen1 object */ if (page->generation >= AGE_GEN_1) { @@ -3752,6 +3993,14 @@ void GC_mark2(void *pp, struct NewGC *gc) is add the pointer to the mark queue and note on the page that we marked something on it */ int inc_gen1; + if (page->non_dead_as_mark) { + GC_ASSERT(gc->mark_gen1); + GC_ASSERT(page->generation >= AGE_GEN_1); + GC_ASSERT(!ohead->dead); + GC_ASSERT(!ohead->moved); + RELEASE_PAGE_LOCK(is_a_master_page, page); + return; + } if ((NUM(page->addr) + page->scan_boundary) <= NUM(p)) { GC_ASSERT(!gc->inc_gen1); GCDEBUG((DEBUGOUTF, "Marking %p (leaving alone)\n", p)); @@ -3761,6 +4010,7 @@ void GC_mark2(void *pp, struct NewGC *gc) if (is_a_master_page) { inc_gen1 = 0; } else { + GC_ASSERT(!gc->all_marked_incremental && !gc->finished_incremental); check_incremental_unprotect(gc, page); inc_gen1 = 1; } @@ -3803,13 +4053,15 @@ void GC_mark2(void *pp, struct NewGC *gc) } newplace = PTR(NUM(work->addr) + work->size); work->size += size; + work->live_size += gcBYTES_TO_WORDS(size); new_type = 1; /* i.e., in gen 1/2 */ } else { /* now set us up for the search for where to put this thing in gen 1 */ work = gc->gen1_pages[type]; /* search for a page with the space to spare */ - if (work && ((work->size + size) >= APAGE_SIZE)) + if (work && (((work->size + size) >= APAGE_SIZE) + || work->non_dead_as_mark)) work = NULL; /* now either fetch where we're going to put this object or make @@ -3818,7 +4070,7 @@ void GC_mark2(void *pp, struct NewGC *gc) if (!work->marked_on) { work->marked_on = 1; if (!work->marked_from) { - gc->memory_in_use -= work->size; + gc->memory_in_use -= gcWORDS_TO_BYTES(work->live_size); work->modified_next = gc->modified_next; gc->modified_next = work; } @@ -3854,10 +4106,13 @@ void GC_mark2(void *pp, struct NewGC *gc) /* update the size */ work->size += size; + work->live_size += gcBYTES_TO_WORDS(size); work->has_new = 1; new_type = 0; /* i.e., not in gen 1/2 */ } + gc->copy_count += size; + /* transfer the object */ ohead->mark = 1; /* mark is copied to newplace, too */ if (size == PAIR_SIZE_IN_BYTES) @@ -3953,7 +4208,7 @@ static inline void propagate_marks_worker(NewGC *gc, void *pp, int inc_gen1) start = PPTR(BIG_PAGE_TO_OBJECT(page)); alloc_type = page->page_type; end = PAGE_END_VSS(page); - GC_ASSERT(inc_gen1 || !page->mprotected); + GC_ASSERT(inc_gen1 || !page->mprotected || gc->doing_memory_accounting); } else { objhead *info; p = pp; @@ -3963,6 +4218,8 @@ static inline void propagate_marks_worker(NewGC *gc, void *pp, int inc_gen1) end = PPTR(info) + info->size; } + gc->traverse_count += (end - start); + mark_traverse_object(gc, start, end, alloc_type); } @@ -3987,34 +4244,50 @@ static void propagate_marks_plus_ephemerons(NewGC *gc) } while (mark_ready_ephemerons(gc, 0)); } -static void propagate_incremental_marks(NewGC *gc, int fuel) +static int propagate_incremental_marks(NewGC *gc, int do_emph, int fuel) { - if (gc->inc_mark_stack) { - int save_inc, save_mark, save_check, init_fuel = fuel; + int save_inc, save_check, init_fuel = fuel; - save_inc = gc->inc_gen1; - save_mark = gc->mark_gen1; - save_check = gc->check_gen1; + if (!fuel) return 0; + if (!gc->inc_mark_stack) return fuel; + + GC_ASSERT(gc->mark_gen1); + + save_inc = gc->inc_gen1; + save_check = gc->check_gen1; - gc->inc_gen1 = 1; - gc->mark_gen1 = 1; - gc->check_gen1 = 1; + gc->inc_gen1 = 1; + gc->check_gen1 = 1; - do { - void *p; - while (fuel && pop_ptr(gc, &p, 1)) { - GCDEBUG((DEBUGOUTF, "Popped incremental pointer %p\n", p)); - propagate_marks_worker(gc, p, 1); + do { + void *p; + while (fuel && pop_ptr(gc, &p, 1)) { + GCDEBUG((DEBUGOUTF, "Popped incremental pointer %p\n", p)); + gc->copy_count = 0; + gc->traverse_count = 0; + + propagate_marks_worker(gc, p, 1); + + if (fuel > 0) { fuel--; + fuel -= (gc->copy_count >> 2); + fuel -= (gc->traverse_count >> 2); + if (gc->unprotected_page) { + gc->unprotected_page = 0; + fuel -= 100; + } + if (fuel < 0) + fuel = 0; } - } while (mark_ready_ephemerons(gc, 1) && fuel); + } + } while (do_emph && fuel && mark_ready_ephemerons(gc, 1)); - gc->inc_prop_count += (init_fuel - fuel); + gc->inc_prop_count += (init_fuel - fuel); - gc->inc_gen1 = save_inc; - gc->mark_gen1 = save_mark; - gc->check_gen1 = save_check; - } + gc->inc_gen1 = save_inc; + gc->check_gen1 = save_check; + + return fuel; } #ifdef MZ_USE_PLACES @@ -4071,7 +4344,7 @@ void GC_fixup2(void *pp, struct NewGC *gc) if (!p || (NUM(p) & 0x1)) return; - page = pagemap_find_page_for_marking(gc, p, gc->mark_gen1); + page = pagemap_find_page_for_marking(gc, p, gc->check_gen1); if (page) { objhead *info; @@ -4113,7 +4386,7 @@ int GC_is_on_allocated_page(void *p) int GC_is_partial(struct NewGC *gc) { - return !gc->gc_full || gc->doing_memory_accounting; + return (!gc->gc_full && !gc->fnl_gen1) || gc->doing_memory_accounting; } int GC_started_incremental(struct NewGC *gc) @@ -4407,7 +4680,7 @@ void *GC_next_tagged_start(void *p) /* garbage collection */ /*****************************************************************************/ -static void reset_gen1_pages_scan_boundaries(NewGC *gc) +static void reset_gen1_pages_scan_boundaries_and_writable(NewGC *gc) { mpage *work; int i; @@ -4513,7 +4786,7 @@ static void mark_backpointers(NewGC *gc) /* must be a big page */ if (work->size_class == SIZE_CLASS_BIG_PAGE_MARKED) mark_traverse_object(gc, PPTR(BIG_PAGE_TO_OBJECT(work)), PAGE_END_VSS(work), work->page_type); - else if (!gc->gc_full) + else if (!gc->gc_full && !gc->all_marked_incremental) mark_traverse_object_no_gen1(gc, PPTR(BIG_PAGE_TO_OBJECT(work)), PAGE_END_VSS(work), work->page_type); gc->memory_in_use -= work->size; } else if (work->size_class == SIZE_CLASS_SMALL_PAGE) { @@ -4528,14 +4801,19 @@ static void mark_backpointers(NewGC *gc) while (start < end) { objhead *info = (objhead *)start; if (!info->dead) { - if (info->mark) + if (info->mark || work->non_dead_as_mark) mark_traverse_object(gc, PPTR(OBJHEAD_TO_OBJPTR(start)), PPTR(info) + info->size, info->type); - else if (!gc->gc_full) + else if ((!gc->gc_full && !gc->all_marked_incremental) + /* Totally ad hoc; supports closure prefixes */ + || ((info->type == PAGE_TAGGED) + && gc->treat_as_incremental_mark_hook + && (gc->treat_as_incremental_mark_tag == *(short *)OBJHEAD_TO_OBJPTR(start)) + && gc->treat_as_incremental_mark_hook(OBJHEAD_TO_OBJPTR(start)))) mark_traverse_object_no_gen1(gc, PPTR(OBJHEAD_TO_OBJPTR(start)), PPTR(info) + info->size, info->type); } start += info->size; } - gc->memory_in_use -= work->size; + gc->memory_in_use -= gcWORDS_TO_BYTES(work->live_size); } else { /* medium page */ void **start = PPTR(NUM(work->addr) + PREFIX_SIZE); @@ -4546,15 +4824,15 @@ static void mark_backpointers(NewGC *gc) while (start <= end) { objhead *info = (objhead *)start; if (!info->dead) { - if (info->mark) + if (info->mark || work->non_dead_as_mark) mark_traverse_object(gc, PPTR(OBJHEAD_TO_OBJPTR(start)), PPTR(info) + info->size, info->type); - else if (!gc->gc_full) + else if (!gc->gc_full && !gc->all_marked_incremental) mark_traverse_object_no_gen1(gc, PPTR(OBJHEAD_TO_OBJPTR(start)), PPTR(info) + info->size, info->type); } start += info->size; } - gc->memory_in_use -= work->live_size; + gc->memory_in_use -= gcWORDS_TO_BYTES(work->live_size); } traversed++; @@ -4586,6 +4864,7 @@ static void mark_backpointers(NewGC *gc) } gc->inc_modified_next = NULL; + gc->inc_repair_next = NULL; } gc->during_backpointer = 0; @@ -4644,10 +4923,10 @@ inline static void do_heap_compact(NewGC *gc) int i, compact_count = 0, noncompact_count = 0; int tic_tock = gc->num_major_collects % 2; - /* incremental mode disables old-generation compaction: */ - if (gc->started_incremental) + /* Cannot compact old generation if we've finished marking: */ + if (gc->all_marked_incremental) return; - + mmu_prep_for_compaction(gc->mmu); for(i = 0; i < PAGE_BIG; i++) { @@ -4684,6 +4963,8 @@ inline static void do_heap_compact(NewGC *gc) avail = gcBYTES_TO_WORDS(APAGE_SIZE - npage->size); newplace = PPTR(NUM(npage->addr) + npage->size); + GC_ASSERT(!work->non_dead_as_mark); + while (start < end) { objhead *info = (objhead *)start; @@ -4831,6 +5112,7 @@ static int unmark_range(void **start, void **end) objhead *info = (objhead *)start; if (info->mark) { + GC_ASSERT(!info->dead); info->mark = 0; live_size += info->size; } else @@ -4906,7 +5188,7 @@ static void repair_heap(NewGC *gc) memory_in_use = gc->memory_in_use; need_fixup = gc->need_fixup; - minor_for_incremental = !gc->gc_full && gc->mark_gen1; + minor_for_incremental = !gc->gc_full && gc->started_incremental; for (; page; page = next) { GC_ASSERT(page->marked_on || page->marked_from); @@ -4918,7 +5200,7 @@ static void repair_heap(NewGC *gc) if (gc->gc_full) page->marked_on = 1; else { - if (gc->mark_gen1 && page->marked_on) + if (minor_for_incremental && page->marked_on) page_marked_on(gc, page, 0, 1); page->marked_on = 0; } @@ -4958,7 +5240,7 @@ static void repair_heap(NewGC *gc) memory_in_use += page->size; } else if (page->size_class == SIZE_CLASS_SMALL_PAGE) { - int need_unmark = 0; + int need_unmark = 0, need_fixup_now = need_fixup; /* ------ small page ------ */ if (minor_for_incremental) { /* leave marks as-is */ @@ -4971,16 +5253,21 @@ static void repair_heap(NewGC *gc) if (!need_fixup || (page->page_type == PAGE_ATOMIC) || (page->scan_boundary != PREFIX_SIZE)) { - live_size = unmark_range(PPTR(NUM(page->addr) + page->scan_boundary), - PAGE_END_VSS(page)); - - if (page->scan_boundary == PREFIX_SIZE) - page->live_size = live_size; - } else - need_unmark = 1; + if (!page->non_dead_as_mark) { + live_size = unmark_range(PPTR(NUM(page->addr) + page->scan_boundary), + PAGE_END_VSS(page)); + if (page->scan_boundary == PREFIX_SIZE) + page->live_size = live_size; + } + } else { + need_unmark = !page->non_dead_as_mark; + if (!need_unmark && !page->back_pointers) + need_fixup_now = 0; + } + page->non_dead_as_mark = 0; } - if (need_fixup) { + if (need_fixup_now) { /* fixup should walk the full page: */ void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); void **end = PAGE_END_VSS(page); @@ -5070,16 +5357,17 @@ static void repair_heap(NewGC *gc) break; } - if (page->page_type != PAGE_ATOMIC) + if (need_unmark && (page->page_type != PAGE_ATOMIC)) page->live_size = live_size; } /* everything on this page is now old-generation: */ page->scan_boundary = page->size; - memory_in_use += page->size; + memory_in_use += gcWORDS_TO_BYTES(page->live_size); } else { /* ------ medium page ------ */ + int need_fixup_now = need_fixup; GC_ASSERT(page->size_class == SIZE_CLASS_MED_PAGE); if (minor_for_incremental) { @@ -5089,26 +5377,35 @@ static void repair_heap(NewGC *gc) mark_backpointers. */ void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->obj_size); + int live_count = 0; while(start < end) { objhead *info = (objhead *)start; if (!info->mark) info->dead = 1; + else + live_count++; start += info->size; } + page->live_size = live_count * gcBYTES_TO_WORDS(page->obj_size); } } else { if ((page->generation == AGE_GEN_0) || gc->gc_full) { - int live_size; - live_size = unmark_range(PPTR(NUM(page->addr) + PREFIX_SIZE), - PPTR(NUM(page->addr) + APAGE_SIZE - page->obj_size)); - page->live_size = live_size; + if (!page->non_dead_as_mark) { + int live_size; + live_size = unmark_range(PPTR(NUM(page->addr) + PREFIX_SIZE), + PPTR(NUM(page->addr) + APAGE_SIZE - page->obj_size)); + page->live_size = live_size; + } else { + need_fixup_now = page->back_pointers; + page->non_dead_as_mark = 0; + } } } - if (need_fixup) + if (need_fixup_now) repair_mixed_page(gc, page, PPTR(NUM(page->addr) + APAGE_SIZE - page->obj_size)); - memory_in_use += page->live_size; + memory_in_use += gcWORDS_TO_BYTES(page->live_size); page->med_search_start = PREFIX_SIZE; /* start next block search at the beginning */ if (page->generation == AGE_GEN_0) { /* Tell the clean-up phase to keep this one (needed even for a minor GC): */ @@ -5128,11 +5425,19 @@ static void repair_heap(NewGC *gc) if (page->reprotect) { /* must have been set for incremental, but also used for new gen1 objects moved from gen0 */ - GC_ASSERT(!gc->gc_full); + GC_ASSERT(!gc->gc_full || gc->finished_incremental); GC_ASSERT(gc->mark_gen1); } else { - page->reprotect_next = gc->reprotect_next; - gc->reprotect_next = page; + if (page->mprotected) { + /* This only happens for a full collection to wrap up a + finished incremental collection; the page wasn't + touched at al in the wrap-up */ + GC_ASSERT(gc->gc_full && gc->finished_incremental); + } else { + page->reprotect_next = gc->reprotect_next; + gc->reprotect_next = page; + page->reprotect = 1; + } } } } @@ -5148,12 +5453,11 @@ static void repair_heap(NewGC *gc) } } + /* This calculation will be ignored for a full GC: */ memory_in_use += gen_half_size_in_use(gc); memory_in_use = add_no_overflow(memory_in_use, gc->phantom_count); gc->memory_in_use = memory_in_use; - - #if CHECK_NO_MISSED_FIXUPS /* Double-check that no fixups apply to live objects at this point */ if (need_fixup) { @@ -5202,6 +5506,91 @@ static void repair_heap(NewGC *gc) #endif } +static void incremental_repair_pages(NewGC *gc, int fuel) +{ + mpage *page; + int retry = 1; + +#if 0 + /* Make sure `gc->inc_repair_next` is a tail of `gc->inc_modified_next` */ + for (page = gc->inc_modified_next; page != gc->inc_repair_next; page = page->inc_modified_next) { + } + GC_ASSERT(page == gc->inc_repair_next); +#endif + + /* If gc->finished_incremental already, then we must be in the + process of accounting incrementally */ + GC_ASSERT(!gc->finished_incremental || !gc->inc_repair_next || gc->really_doing_accounting); + + while ((fuel || gc->finished_incremental) && gc->inc_repair_next) { + page = gc->inc_repair_next; + gc->inc_repair_next = page->inc_modified_next; + if (!gc->inc_repair_next) + gc->inc_repair_next = gc->inc_modified_next; + /* If this page isn't already marked as old, it must be a medium page whose + generation will be updated in the clean-up phase */ + GC_ASSERT((page->generation >= AGE_GEN_1) || (page->size_class == SIZE_CLASS_MED_PAGE)); + if (page->generation == AGE_VACATED) { + /* skip */ + } else if (page->size_class >= SIZE_CLASS_BIG_PAGE) { + /* skip */ + } else { + if (page->non_dead_as_mark) { + /* hit already-repaired tail; no more to repair here */ + if (retry) { + retry = 0; + gc->inc_repair_next = gc->inc_modified_next; + } else + gc->inc_repair_next = NULL; + } else { + int live_size; + check_incremental_unprotect(gc, page); + if (page->size_class == SIZE_CLASS_SMALL_PAGE) { + GC_ASSERT(page->scan_boundary == page->size); + live_size = unmark_range(PPTR(NUM(page->addr) + PREFIX_SIZE), + PAGE_END_VSS(page)); + } else { + GC_ASSERT(page->size_class == SIZE_CLASS_MED_PAGE); + live_size = unmark_range(PPTR(NUM(page->addr) + PREFIX_SIZE), + PPTR(NUM(page->addr) + APAGE_SIZE - page->obj_size)); + } + gc->memory_in_use -= gcWORDS_TO_BYTES(page->live_size); + page->live_size = live_size; + gc->memory_in_use += gcWORDS_TO_BYTES(live_size); + page->non_dead_as_mark = 1; + --fuel; + } + } + } +} + +#if 0 +static void check_finished_incremental(NewGC *gc) +{ + mpage *work; + int i, ty; + + /* Marking all objects, so make all pages writeable and set the scan + boundary on small pages to the beginning of the page. */ + + for(i = 0; i < PAGE_BIG; i++) { + for(work = gc->gen1_pages[i]; work; work = work->next) { + GC_ASSERT(!work->inc_marked_on || work->non_dead_as_mark); + } + } + + for (ty = 0; ty < MED_PAGE_TYPES; ty++) { + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (work = gc->med_pages[ty][i]; work; work = work->next) { + GC_ASSERT(!work->inc_marked_on || work->non_dead_as_mark); + } + } + } +} +#else +static void check_finished_incremental(NewGC *gc) { } +#endif + static inline void cleanup_vacated_pages(NewGC *gc) { mpage *pages = gc->release_pages; PageMap pagemap = gc->page_maps; @@ -5259,6 +5648,15 @@ inline static void gen0_free_big_pages(NewGC *gc) { gc->gen0.big_pages = NULL; } +static void check_mprotected_for_finished_incremental(NewGC *gc, mpage *work) +{ + if (work->mprotected) { + GC_ASSERT(gc->gc_full && gc->finished_incremental); + work->mprotected = 0; + mmu_write_unprotect_page(gc->mmu, work->addr, real_page_size(work), page_mmu_type(work), &work->mmu_src_block); + } +} + static void clean_up_heap(NewGC *gc) { int i, ty; @@ -5278,12 +5676,16 @@ static void clean_up_heap(NewGC *gc) if(prev) prev->next = next; else gc->gen1_pages[i] = next; if(next) work->next->prev = prev; GCVERBOSEPAGE(gc, "Cleaning up BIGPAGE", work); + check_mprotected_for_finished_incremental(gc, work); gen1_free_mpage(pagemap, work); --gc->num_gen1_pages; } else { GCVERBOSEPAGE(gc, "clean_up_heap BIG PAGE ALIVE", work); work->marked_on = 0; - memory_in_use += work->size; + if (work->size_class == SIZE_CLASS_SMALL_PAGE) + memory_in_use += gcWORDS_TO_BYTES(work->live_size); + else + memory_in_use += work->size; prev = work; } work = next; @@ -5292,7 +5694,7 @@ static void clean_up_heap(NewGC *gc) } /* For medium pages, generation-0 pages will appear first in each - list, so for a mnior GC, we can stop whenever we find a + list, so for a minor GC, we can stop whenever we find a generation-1 page */ for (ty = 0; ty < MED_PAGE_TYPES; ty++) { for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { @@ -5303,7 +5705,7 @@ static void clean_up_heap(NewGC *gc) next = work->next; if (work->marked_on) { work->marked_on = 0; - memory_in_use += work->live_size; + memory_in_use += gcWORDS_TO_BYTES(work->live_size); work->generation = AGE_GEN_1; prev = work; } else if (gc->gc_full || (work->generation == AGE_GEN_0)) { @@ -5312,6 +5714,7 @@ static void clean_up_heap(NewGC *gc) if(prev) prev->next = next; else gc->med_pages[ty][i] = next; if(next) work->next->prev = prev; GCVERBOSEPAGE(gc, "Cleaning up MED NO MARKEDON", work); + check_mprotected_for_finished_incremental(gc, work); gen1_free_mpage(pagemap, work); --gc->num_gen1_pages; } else { @@ -5319,7 +5722,11 @@ static void clean_up_heap(NewGC *gc) next = NULL; } } - gc->med_freelist_pages[ty][i] = prev; + if (gc->all_marked_incremental && !gc->gc_full) { + /* no more allocation on old pages */ + gc->med_freelist_pages[ty][i] = NULL; + } else + gc->med_freelist_pages[ty][i] = prev; } } @@ -5364,6 +5771,12 @@ static void unprotect_old_pages(NewGC *gc) } mmu_flush_write_unprotect_ranges(mmu); + + /* Clear out ignored list of reprotects */ + for (page = gc->reprotect_next; page; page = page->reprotect_next) { + page->reprotect = 0; + } + gc->reprotect_next = NULL; } #endif @@ -5383,8 +5796,10 @@ static void protect_old_pages(NewGC *gc) for (page = gc->gen1_pages[i]; page; page = page->next) { GC_ASSERT(page->generation != AGE_VACATED); if (page->page_type != PAGE_ATOMIC) { - if (!page->mprotected) + if (!page->mprotected) { count++; + GC_ASSERT(page->reprotect); + } } } } @@ -5392,8 +5807,10 @@ static void protect_old_pages(NewGC *gc) for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { for (page = gc->med_pages[MED_PAGE_NONATOMIC_INDEX][i]; page; page = page->next) { - if (!page->mprotected) + if (!page->mprotected) { count++; + GC_ASSERT(page->reprotect); + } } } @@ -5470,6 +5887,48 @@ static void check_marks_cleared(NewGC *gc) static void check_marks_cleared(NewGC *gc) { } #endif +#if 0 +static int get_live_size_range(void **start, void **end) +{ + int live_size = 0; + + while(start < end) { + objhead *info = (objhead *)start; + + if (!info->dead) + live_size += info->size; + + start += info->size; + } + + return live_size; +} + +static void check_live_sizes(NewGC *gc) +{ + mpage *page; + int i, ty; + + for (i = 0; i < PAGE_BIG; i++) { + for (page = gc->gen1_pages[i]; page; page = page->next) { + GC_ASSERT(page->size == page->scan_boundary); + GC_ASSERT(page->live_size == get_live_size_range(PAGE_START_VSS(page), PAGE_END_VSS(page))); + } + } + + for (ty = 0; ty < MED_PAGE_TYPES; ty++) { + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (page = gc->med_pages[ty][i]; page; page = page->next) { + GC_ASSERT(page->live_size == get_live_size_range(PAGE_START_VSS(page), + PPTR(NUM(page->addr) + APAGE_SIZE - page->obj_size))); + } + } + } +} +#else +static void check_live_sizes(NewGC *gc) { } +#endif + static void park_for_inform_callback(NewGC *gc) { /* Avoid nested collections, which would need @@ -5496,22 +5955,140 @@ static void unpark_for_inform_callback(NewGC *gc) #if 0 extern double scheme_get_inexact_milliseconds(void); # define SHOW_TIME_NOW gc->gc_full -# define TIME_DECLS() double start, task_start +# define TIME_DECLS() double start, task_start, *_task_start = &task_start # define TIME_INIT() start = task_start = scheme_get_inexact_milliseconds(); if (SHOW_TIME_NOW) fprintf(stderr, "GC (%d):\n", gc->gc_full) -# define TIME_STEP(task) if (SHOW_TIME_NOW) fprintf(stderr, " %s: %lf\n", task, scheme_get_inexact_milliseconds() - task_start); \ - task_start = scheme_get_inexact_milliseconds() +# define TIME_STEP(task) if (SHOW_TIME_NOW) fprintf(stderr, " %s: %lf\n", task, scheme_get_inexact_milliseconds() - (*_task_start)); \ + (*_task_start) = scheme_get_inexact_milliseconds() # define TIME_DONE() if (SHOW_TIME_NOW) fprintf(stderr, " Total: %lf\n", scheme_get_inexact_milliseconds() - start) +# define TIME_FORMAL_ARGS , double start, double *_task_start +# define TIME_ARGS , start, _task_start #else # define TIME_DECLS() /**/ # define TIME_INIT() /**/ # define TIME_STEP(task) /**/ # define TIME_DONE() /**/ +# define TIME_FORMAL_ARGS /**/ +# define TIME_ARGS /**/ #endif -/* Full GCs trigger finalization. Finalization releases data - in the old generation. So one more full GC is needed to - really clean up. The full_needed_for_finalization flag triggers - the second full GC. */ +static int mark_and_finalize_all(NewGC *gc, int old_gen, int no_full TIME_FORMAL_ARGS) +{ + int fuel = (old_gen + ? (no_full + ? INCREMENTAL_COLLECT_FUEL_PER_100M / INCREMENTAL_MINOR_REQUEST_DIVISOR + : (INCREMENTAL_COLLECT_FUEL_PER_100M * AS_100M(gc->memory_in_use)) / 2) + : -1); + int reset_gen1; + + /* Propagate marks */ + if (!old_gen) + propagate_marks_plus_ephemerons(gc); + else + fuel = propagate_incremental_marks(gc, 1, fuel); + + /* check finalizers at level 1 */ + fuel = check_finalizers(gc, 1, old_gen, fuel); + + if (!old_gen) + propagate_marks_plus_ephemerons(gc); + else + fuel = propagate_incremental_marks(gc, 1, fuel); + + TIME_STEP("marked"); + + if (old_gen || (gc->gc_full && gc->finished_incremental)) { + GC_ASSERT(!gc->fnl_gen1); + gc->fnl_gen1 = 1; + reset_gen1 = 1; + } else + reset_gen1 = 0; + + if (gc->gc_full) + (void)zero_weak_boxes(gc, 0, 0, 1, 1, -1); + fuel = zero_weak_boxes(gc, 0, 0, old_gen, !old_gen, fuel); + + if (gc->gc_full) + (void)zero_weak_arrays(gc, 0, 1, 1, -1); + fuel = zero_weak_arrays(gc, 0, old_gen, !old_gen, fuel); + + if (gc->gc_full) + zero_remaining_ephemerons(gc, 1); + if (fuel) + zero_remaining_ephemerons(gc, old_gen); + + TIME_STEP("zeroed"); + + fuel = check_finalizers(gc, 2, old_gen, fuel); + + if (!old_gen) + propagate_marks(gc); + else + fuel = propagate_incremental_marks(gc, 0, fuel); + + if (gc->gc_full) + (void)zero_weak_boxes(gc, 1, 0, 1, 1, -1); + fuel = zero_weak_boxes(gc, 1, 0, old_gen, !old_gen, fuel); + + fuel = check_finalizers(gc, 3, old_gen, fuel); + + if (!old_gen) + propagate_marks(gc); + else + fuel = propagate_incremental_marks(gc, 0, fuel); + + if (fuel && gc->GC_post_propagate_hook) + gc->GC_post_propagate_hook(gc); + + if (fuel) { + /* for any new ones that appeared: */ + (void)zero_weak_boxes(gc, 0, 1, old_gen, 0, -1); + (void)zero_weak_boxes(gc, 1, 1, old_gen, 0, -1); + (void)zero_weak_arrays(gc, 1, old_gen, 0, -1); + zero_remaining_ephemerons(gc, old_gen); + + GC_ASSERT(!gc->weak_arrays); + GC_ASSERT(!gc->bp_weak_arrays); + GC_ASSERT(!gc->weak_boxes[0]); + GC_ASSERT(!gc->weak_boxes[1]); + GC_ASSERT(!gc->bp_weak_boxes[0]); + GC_ASSERT(!gc->bp_weak_boxes[1]); + GC_ASSERT(!gc->ephemerons); + GC_ASSERT(!gc->bp_ephemerons); + if (gc->gc_full) { + GC_ASSERT(!gc->inc_weak_arrays); + GC_ASSERT(!gc->inc_weak_boxes[0]); + GC_ASSERT(!gc->inc_weak_boxes[1]); + GC_ASSERT(!gc->inc_ephemerons); + } + } + + if (reset_gen1) + gc->fnl_gen1 = 0; + + TIME_STEP("finalized"); + + return !fuel; +} + +static int mark_and_finalize_all_incremental(NewGC *gc, int no_full TIME_FORMAL_ARGS) +{ + int save_inc, save_check, more_to_do; + + GC_ASSERT(gc->mark_gen1); + + save_inc = gc->inc_gen1; + save_check = gc->check_gen1; + + gc->inc_gen1 = 1; + gc->check_gen1 = 1; + + more_to_do = mark_and_finalize_all(gc, 1, no_full TIME_ARGS); + + gc->inc_gen1 = save_inc; + gc->check_gen1 = save_check; + + return more_to_do; +} static void garbage_collect(NewGC *gc, int force_full, int no_full, int switching_master, Log_Master_Info *lmi) { @@ -5519,16 +6096,21 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin uintptr_t old_gen0; uintptr_t old_mem_allocated; int next_gc_full; - int do_incremental = 0; + int do_incremental = 0, had_started_incremental, check_inc_repair; old_mem_use = gc->memory_in_use; /* includes gc->phantom_count */ - old_gen0 = gc->gen0.current_size + gc->gen0_phantom_count; + old_gen0 = gen0_size_in_use(gc) + gc->gen0_phantom_count; old_mem_allocated = mmu_memory_allocated(gc->mmu) + gc->phantom_count + gc->gen0_phantom_count; TIME_DECLS(); dump_page_map(gc, "pre"); + GC_ASSERT(!gc->all_marked_incremental || gc->started_incremental); + GC_ASSERT(!gc->all_marked_incremental || mark_stack_is_empty(gc->inc_mark_stack)); + GC_ASSERT(!gc->finished_incremental || (gc->all_marked_incremental && !gc->inc_repair_next)); + GC_ASSERT(!gc->accounted_incremental || gc->finished_incremental); + /* determine if this should be a full collection or not */ gc->gc_full = (force_full || !gc->generations_available @@ -5536,32 +6118,38 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin to a given ratio of memory use after the last GC. This approach makes total memory use roughly a constant fraction of the actual use by live data: */ - || (gc->memory_in_use > (FULL_COLLECTION_SIZE_RATIO * gc->last_full_mem_use)) + || (gc->memory_in_use > (FULL_COLLECTION_SIZE_RATIO + * gc->last_full_mem_use + * (gc->incremental_requested + ? INCREMENTAL_EXTRA_SIZE_RATIO + : 1))) /* Just in case, for a full GC every so often, unless incremental mode has been enabled: */ || ((gc->since_last_full > FORCE_MAJOR_AFTER_COUNT) && !gc->started_incremental) - /* In incremental mode, maybe GC earlier. Since incremental - mode promotes objects from gen0 to already-marked - old-generation objects, we try to keep memory use at - some limit from before incremental mode started. At - the same time, we don't want to start if there's still - worked queued to perform incrementally. */ - || (gc->started_incremental - && (gc->memory_in_use > gc->inc_mem_use_threshold) - && (!gc->inc_mark_stack - || (gc->inc_mark_stack->top == MARK_STACK_START(gc->inc_mark_stack))))); + /* Finalization triggers an extra full in case it releases + a lot of additional memory: */ + || (gc->full_needed_again + && !gc->incremental_requested + && !gc->started_incremental) + /* In incremental mode, GC earlier if we've done everything + that we can do incrementally. */ + || gc->accounted_incremental); - if (gc->gc_full && no_full) { + if (gc->gc_full && no_full) return; - } - next_gc_full = gc->gc_full && !gc->started_incremental; + /* Switch from incremental to not, schedule another + full GC for next time: */ + next_gc_full = (gc->gc_full + && gc->started_incremental + && !gc->incremental_requested + && !always_collect_incremental_on_minor + && !gc->full_needed_again); + + if (gc->full_needed_again && gc->gc_full) + gc->full_needed_again = 0; - if (gc->full_needed_for_finalization) { - gc->full_needed_for_finalization= 0; - gc->gc_full = 1; - } #ifdef GC_DEBUG_PAGES if (gc->gc_full == 1) { GCVERBOSEprintf(gc, "GC_FULL gc: %p MASTER: %p\n", gc, MASTERGC); @@ -5579,9 +6167,10 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin gc->use_gen_half = !gc->gc_full && AGE_GEN_0_TO_GEN_HALF(gc); - if (gc->gc_full) - gc->phantom_count = 0; - else if (gc->memory_in_use > gc->phantom_count) { + if (gc->gc_full) { + gc->phantom_count = gc->inc_phantom_count; + gc->inc_phantom_count = 0; + } else if (gc->memory_in_use > gc->phantom_count) { /* added back in repair_heap(), after any adjustments from gen0 phantom bytes */ gc->memory_in_use -= gc->phantom_count; } @@ -5589,18 +6178,21 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin gc->need_fixup = 0; - do_incremental = (!gc->gc_full && (gc->incremental_requested - || ALWAYS_COLLECT_INCREMENTAL_ON_MINOR)); + do_incremental = (!gc->gc_full + && (gc->incremental_requested + || always_collect_incremental_on_minor) + && !gc->high_fragmentation); if (!postmaster_and_place_gc(gc)) do_incremental = 0; if (do_incremental) gc->started_incremental = 1; - gc->incremental_requested = 0; + if (gc->incremental_requested) + --gc->incremental_requested; - gc->mark_gen1 = gc->gc_full || gc->started_incremental; - gc->check_gen1 = gc->gc_full; + gc->mark_gen1 = (gc->gc_full || gc->started_incremental) && !gc->all_marked_incremental; + gc->check_gen1 = gc->gc_full && !gc->all_marked_incremental; TIME_INIT(); @@ -5616,11 +6208,14 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin merge_incremental_mark_stack(gc); else if (gc->mark_gen1) incremental_mark_stack_initialize(gc); - - if (gc->gc_full) - reset_gen1_pages_scan_boundaries(gc); - if (gc->gc_full) + if (gc->finished_incremental) + check_finished_incremental(gc); + + if (gc->gc_full && !gc->finished_incremental) + reset_gen1_pages_scan_boundaries_and_writable(gc); + + if (gc->gc_full && !gc->finished_incremental) merge_finalizer_trees(gc); move_gen_half_pages_to_old(gc); @@ -5637,7 +6232,7 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin /* mark and repair the roots for collection */ mark_backpointers(gc); TIME_STEP("backpointered"); - mark_finalizer_structs(gc); + mark_finalizer_structs(gc, FNL_LEVEL_GEN_0); TIME_STEP("pre-rooted"); mark_roots(gc); mark_immobiles(gc); @@ -5648,55 +6243,38 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin if (postmaster_and_master_gc(gc)) promote_marked_gen0_big_pages(gc); #endif - TIME_STEP("stacked"); /* now propagate/repair the marks we got from these roots, and do the finalizer passes */ + (void)mark_and_finalize_all(gc, 0, no_full TIME_ARGS); - propagate_marks_plus_ephemerons(gc); - - check_finalizers(gc, 1); - propagate_marks_plus_ephemerons(gc); - - TIME_STEP("marked"); - - zero_weak_boxes(gc, 0, 0); - zero_weak_arrays(gc, 0); - zero_remaining_ephemerons(gc); - -#ifndef NEWGC_BTC_ACCOUNT - /* we need to clear out the stack pages. If we're doing memory accounting, - though, we might as well leave them up for now and let the accounting - system clear them later. Better then freeing them, at least. If we're - not doing accounting, though, there is no "later" where they'll get - removed */ - clear_stack_pages(gc); -#endif - - TIME_STEP("zeroed"); - - check_finalizers(gc, 2); - propagate_marks(gc); - zero_weak_boxes(gc, 1, 0); - - check_finalizers(gc, 3); - propagate_marks(gc); - - if (gc->GC_post_propagate_hook) - gc->GC_post_propagate_hook(gc); - - /* for any new ones that appeared: */ - zero_weak_boxes(gc, 0, 1); - zero_weak_boxes(gc, 1, 1); - zero_weak_arrays(gc, 1); - zero_remaining_ephemerons(gc); - - if (do_incremental) - propagate_incremental_marks(gc, INCREMENTAL_COLLECT_FUEL); - - TIME_STEP("finalized2"); - + if (gc->started_incremental) { + if (!gc->all_marked_incremental) { + mark_finalizer_structs(gc, FNL_LEVEL_GEN_1); + if (!mark_stack_is_empty(gc->inc_mark_stack)) { + int fuel = (no_full + ? INCREMENTAL_COLLECT_FUEL_PER_100M / INCREMENTAL_MINOR_REQUEST_DIVISOR + : INCREMENTAL_COLLECT_FUEL_PER_100M * AS_100M(gc->memory_in_use)); + (void)propagate_incremental_marks(gc, 1, fuel); + TIME_STEP("incremented"); + } else { + /* We ran out of incremental marking work, so + perform major-GC finalization */ + if (mark_and_finalize_all_incremental(gc, no_full TIME_ARGS)) { + /* More finalizaton work to do */ + } else { + BTC_clean_up_gen1(gc); + /* Switch to incrementally reparing pages */ + gc->all_marked_incremental = 1; + } + } + check_inc_repair = 0; + } else + check_inc_repair = 1; + } else + check_inc_repair = 0; + #if MZ_GC_BACKTRACE if (0) #endif @@ -5724,10 +6302,23 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin chain_marked_on(gc); else if (gc->gc_full) chain_marked_on_check(gc); + repair_heap(gc); TIME_STEP("repaired"); + if (check_inc_repair) { + int fuel = (no_full + ? INCREMENTAL_REPAIR_FUEL_PER_100M / INCREMENTAL_MINOR_REQUEST_DIVISOR + : INCREMENTAL_REPAIR_FUEL_PER_100M * AS_100M(gc->memory_in_use)); + GC_ASSERT(gc->all_marked_incremental); + incremental_repair_pages(gc, fuel); + TIME_STEP("inc-repaired"); + if (!gc->inc_repair_next) + gc->finished_incremental = 1; + } + clean_up_heap(gc); TIME_STEP("cleaned heap"); + clean_gen_half(gc); #ifdef MZ_USE_PLACES if (postmaster_and_master_gc(gc) && !switching_master) { @@ -5738,10 +6329,18 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin reset_nursery(gc); TIME_STEP("reset nursurey"); #ifdef NEWGC_BTC_ACCOUNT - if (gc->gc_full && postmaster_and_place_gc(gc)) - BTC_do_accounting(gc); + if ((gc->gc_full || (gc->finished_incremental && !gc->accounted_incremental)) + && postmaster_and_place_gc(gc)) { + BTC_do_accounting(gc, no_full); + if (!gc->gc_full && mark_stack_is_empty(gc->acct_mark_stack)) + gc->accounted_incremental = 1; + } +#else + if (gc->finished_incremental) + gc->accounted_incremental = 1; #endif TIME_STEP("accounted"); + if (gc->generations_available) { #ifdef MZ_USE_PLACES if (postmaster_and_master_gc(gc) || switching_master) @@ -5751,12 +6350,21 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin protect_old_pages(gc); } TIME_STEP("protect"); - if (gc->gc_full) + + if (gc->gc_full) { mmu_flush_freed_pages(gc->mmu); + gc->high_fragmentation = (mmu_memory_allocated_and_used(gc->mmu) + > (HIGH_FRAGMENTATION_RATIO + * (gc->memory_in_use + gen_half_size_in_use(gc) + GEN0_MAX_SIZE))); + } reset_finalizer_tree(gc); if (gc->gc_full || !gc->started_incremental) check_marks_cleared(gc); + if (gc->gc_full) + check_live_sizes(gc); + + clear_stack_pages(gc); TIME_STEP("reset"); @@ -5765,8 +6373,17 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin gc->no_further_modifications = 0; - if (gc->gc_full) + if (gc->gc_full) { free_incremental_admin_pages(gc); + if (gc->started_incremental) { + /* Flip `weak_incremental_done`, so we can detect + whether a weak reference is handled on a given pass. */ + if (gc->weak_incremental_done == WEAK_INCREMENTAL_DONE_1) + gc->weak_incremental_done = WEAK_INCREMENTAL_DONE_2; + else + gc->weak_incremental_done = WEAK_INCREMENTAL_DONE_1; + } + } check_excessive_free_pages(gc); @@ -5785,15 +6402,15 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin else gc->since_last_full += 10; } + had_started_incremental = gc->started_incremental; if (gc->gc_full) { gc->last_full_mem_use = gc->memory_in_use; - if (!gc->started_incremental - || ((FULL_COLLECTION_SIZE_RATIO * gc->memory_in_use) < gc->inc_mem_use_threshold) - || (gc->memory_in_use > gc->inc_mem_use_threshold)) - gc->inc_mem_use_threshold = (FULL_COLLECTION_SIZE_RATIO * gc->memory_in_use); - gc->started_incremental = 0; + gc->all_marked_incremental = 0; + gc->finished_incremental = 0; + gc->accounted_incremental = 0; gc->inc_prop_count = 0; + gc->incremental_requested = 0; /* request expires completely after a full GC */ } /* inform the system (if it wants us to) that we're done with collection */ @@ -5805,9 +6422,16 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin is_master = (gc == MASTERGC); #endif park_for_inform_callback(gc); - gc->GC_collect_inform_callback(is_master, gc->gc_full, - old_mem_use + old_gen0, gc->memory_in_use, - old_mem_allocated, mmu_memory_allocated(gc->mmu)+gc->phantom_count, + gc->GC_collect_inform_callback(is_master, gc->gc_full, had_started_incremental, + /* original memory use: */ + old_mem_use + old_gen0, + /* new memory use; gen0_phantom_count can be non-zero due to + phantom-bytes record in generation 1/2: */ + gc->memory_in_use + gc->gen0_phantom_count, + /* original memory use, including adminstrative structures: */ + old_mem_allocated, + /* new memory use with adminstrative structures: */ + mmu_memory_allocated(gc->mmu)+gc->phantom_count+gc->gen0_phantom_count, gc->child_gc_total); unpark_for_inform_callback(gc); } @@ -5829,8 +6453,8 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin dump_page_map(gc, "post"); - if (!gc->run_queue) - next_gc_full = 0; + if (gc->gc_full) + merge_run_queues(gc); /* Run any queued finalizers, EXCEPT in the case where this collection was triggered during the execution of a finalizer. @@ -5867,13 +6491,12 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin gc->park[1] = gc->park_fsave[1]; gc->park_fsave[0] = NULL; gc->park_fsave[1] = NULL; - } else - next_gc_full = 0; + } DUMP_HEAP(); CLOSE_DEBUG_FILE(); if (next_gc_full) - gc->full_needed_for_finalization = 1; + gc->full_needed_again = 1; #ifdef MZ_USE_PLACES if (postmaster_and_place_gc(gc)) { @@ -5884,7 +6507,7 @@ static void garbage_collect(NewGC *gc, int force_full, int no_full, int switchin if (sub_lmi.ran) { if (gc->GC_collect_inform_callback) { park_for_inform_callback(gc); - gc->GC_collect_inform_callback(1, sub_lmi.full, + gc->GC_collect_inform_callback(1, sub_lmi.full, 0, sub_lmi.pre_used, sub_lmi.post_used, sub_lmi.pre_admin, sub_lmi.post_admin, 0); diff --git a/racket/src/racket/gc2/newgc.h b/racket/src/racket/gc2/newgc.h index 1456f7603f..bca883d5ca 100644 --- a/racket/src/racket/gc2/newgc.h +++ b/racket/src/racket/gc2/newgc.h @@ -50,6 +50,7 @@ typedef struct mpage { unsigned char has_new :1; unsigned char mprotected :1; unsigned char reprotect :1; /* in reprotect_next chain already */ + unsigned char non_dead_as_mark :1; /* already repaired in incremental pass */ } mpage; typedef struct Gen0 { @@ -148,6 +149,15 @@ typedef mpage **PageMap; #define NUM_MED_PAGE_SIZES (((LOG_APAGE_SIZE - 1) - 3) + 1) +enum { + FNL_LEVEL_GEN_0, + FNL_LEVEL_GEN_1, + FNL_LEVEL_INC_1, + FNL_LEVEL_INC_2, + FNL_LEVEL_INC_3, + NUM_FNL_LEVELS +}; + typedef struct NewGC { Gen0 gen0; Gen_Half gen_half; @@ -168,15 +178,17 @@ typedef struct NewGC { struct mpage *modified_next; /* pages marked incrementally: */ struct mpage *inc_modified_next; + /* tail of inc_modified_next being repaired incrementally */ + struct mpage *inc_repair_next; /* linked list of pages that need to be given write protection at the end of the GC cycle: */ struct mpage *reprotect_next; - MarkSegment *mark_stack, *inc_mark_stack; + MarkSegment *mark_stack, *inc_mark_stack, *acct_mark_stack; /* Finalization */ - Fnl *run_queue; - Fnl *last_in_queue; + Fnl *run_queue, *last_in_queue; + Fnl *inc_run_queue, *inc_last_in_queue; int mark_depth; @@ -200,23 +212,31 @@ typedef struct NewGC { unsigned char generations_available :1; unsigned char started_incremental :1; /* must stick with incremental until major GC */ + unsigned char all_marked_incremental :1; /* finished all marking for an incremental GC */ + unsigned char finished_incremental :1; /* finished marking and reparing an incremental GC */ + unsigned char accounted_incremental :1; /* memory accounting for an incremental GC */ unsigned char in_unsafe_allocation_mode :1; - unsigned char full_needed_for_finalization :1; + unsigned char full_needed_again :1; unsigned char no_further_modifications :1; unsigned char gc_full :1; /* a flag saying if this is a full/major collection */ + unsigned char had_finished_incremental :1; /* when gc_full, indicates full GC after incremental finished */ unsigned char use_gen_half :1; unsigned char running_finalizers :1; unsigned char back_pointers :1; unsigned char need_fixup :1; - unsigned char check_gen1 :1; - unsigned char mark_gen1 :1; - unsigned char inc_gen1 :1; + unsigned char check_gen1 :1; /* check marks bit for old generation (instead of claiming always marked) */ + unsigned char mark_gen1 :1; /* set mark bits for old generation */ + unsigned char inc_gen1 :1; /* during incremental marking of old generation */ + unsigned char fnl_gen1 :1; /* during incremental finalization of old generation */ unsigned char during_backpointer :1; - unsigned char incremental_requested :1; + unsigned char incremental_requested :4; /* counts down to track recentness of request */ + unsigned char high_fragmentation :1; + unsigned char unprotected_page :1; /* blame the child */ unsigned int doing_memory_accounting :1; unsigned int really_doing_accounting :1; + unsigned int next_really_doing_accounting :1; unsigned int old_btc_mark :1; unsigned int new_btc_mark :1; unsigned int reset_limits :1; @@ -231,10 +251,11 @@ typedef struct NewGC { uintptr_t number_of_gc_runs; unsigned int since_last_full; uintptr_t last_full_mem_use; - uintptr_t inc_mem_use_threshold; uintptr_t prop_count; uintptr_t inc_prop_count; + uintptr_t copy_count; /* bytes */ + uintptr_t traverse_count; /* words */ /* These collect information about memory usage, for use in GC_dump. */ uintptr_t peak_memory_use; @@ -267,13 +288,13 @@ typedef struct NewGC { GC_collect_inform_callback_Proc GC_collect_inform_callback; uintptr_t (*GC_get_thread_stack_base)(void); GC_Post_Propagate_Hook_Proc GC_post_propagate_hook; + GC_Treat_As_Incremental_Mark_Proc treat_as_incremental_mark_hook; + short treat_as_incremental_mark_tag; GC_Immobile_Box *immobile_boxes; - Fnl *finalizers; - Fnl *splayed_finalizers; - Fnl *gen0_finalizers; - Fnl *splayed_gen0_finalizers; + Fnl *finalizers[NUM_FNL_LEVELS]; + Fnl *splayed_finalizers[NUM_FNL_LEVELS]; int num_fnls; void *park[2]; @@ -286,8 +307,10 @@ typedef struct NewGC { unsigned short cust_box_tag; unsigned short phantom_tag; - uintptr_t phantom_count; - uintptr_t gen0_phantom_count; + uintptr_t phantom_count; /* old-generation count; included in `memory_in_use`, except during a minor collection */ + uintptr_t gen0_phantom_count; /* count for generation 0 + 1/2 */ + uintptr_t inc_phantom_count; /* accumulated count for an incremental collection */ + uintptr_t acct_phantom_count; /* count that is set during memory accounting */ Roots roots; struct MMU *mmu; @@ -306,6 +329,8 @@ typedef struct NewGC { GC_Ephemeron *ephemerons, *inc_ephemerons, *bp_ephemerons; int num_last_seen_ephemerons; + void *weak_incremental_done; + Allocator *saved_allocator; #ifdef MZ_USE_PLACES diff --git a/racket/src/racket/gc2/vm.c b/racket/src/racket/gc2/vm.c index 53795283ce..04e539c0d5 100644 --- a/racket/src/racket/gc2/vm.c +++ b/racket/src/racket/gc2/vm.c @@ -47,7 +47,8 @@ typedef struct MMU { struct AllocCacheBlock *alloc_caches[2]; Page_Range *page_range; #endif - intptr_t memory_allocated; + intptr_t memory_allocated; /* allocated from OS */ + intptr_t memory_used; /* subset of alloctaed from OS that's being used */ size_t os_pagesize; NewGC *gc; } MMU; @@ -139,6 +140,7 @@ static void mmu_free(MMU *mmu) { static void *mmu_alloc_page(MMU* mmu, size_t len, size_t alignment, int dirty, int type, int expect_mprotect, void **src_block) { mmu_assert_os_page_aligned(mmu, len); + mmu->memory_used += len; #ifdef USE_BLOCK_CACHE return block_cache_alloc_page(mmu->block_cache, len, alignment, dirty, type, expect_mprotect, src_block, &mmu->memory_allocated); #else @@ -164,6 +166,7 @@ static void mmu_free_page(MMU* mmu, void *p, size_t len, int type, int expect_mp int originated_here) { mmu_assert_os_page_aligned(mmu, (size_t)p); mmu_assert_os_page_aligned(mmu, len); + mmu->memory_used -= len; #ifdef USE_BLOCK_CACHE mmu->memory_allocated += block_cache_free_page(mmu->block_cache, p, len, type, expect_mprotect, src_block, originated_here); @@ -251,6 +254,10 @@ static size_t mmu_memory_allocated(MMU *mmu) { return mmu->memory_allocated; } +static size_t mmu_memory_allocated_and_used(MMU *mmu) { + return mmu->memory_used; +} + /* _WIN32 and OSKIT use these functions On OSX and Linux the block and alloc caches diff --git a/racket/src/racket/gc2/weak.c b/racket/src/racket/gc2/weak.c index 7e4596a999..e1b0aa5255 100644 --- a/racket/src/racket/gc2/weak.c +++ b/racket/src/racket/gc2/weak.c @@ -21,6 +21,8 @@ Type_Tag */ +#define WEAK_INCREMENTAL_DONE_1 ((void *)0x1) +#define WEAK_INCREMENTAL_DONE_2 ((void *)0x3) /******************************************************************************/ /* weak arrays */ @@ -47,7 +49,12 @@ static int mark_weak_array(void *p, struct NewGC *gc) a->data[a->count] = gc->inc_weak_arrays; gc->inc_weak_arrays = a; } else if (gc->during_backpointer) { - if (!gc->gc_full) { + if (!gc->gc_full + || (gc->started_incremental + /* `a` must have been marked and must be in the old + generation, or we wouldn't get here; `a` may have been + fully processed in incremental mode, though */ + && (a->data[a->count] == gc->weak_incremental_done))) { /* Keep backpointered weak arrays separate, because we should not merge them to the incremental list in incremental mode. */ @@ -57,6 +64,8 @@ static int mark_weak_array(void *p, struct NewGC *gc) } else { a->next = gc->weak_arrays; gc->weak_arrays = a; + if (gc->gc_full) + a->data[a->count] = NULL; /* ensure not a future weak_incremental_done */ } #if CHECKS @@ -123,21 +132,10 @@ void *GC_malloc_weak_array(size_t size_in_bytes, void *replace_val) return w; } -static void rechain_inc_weak_arrays(GC_Weak_Array *w) +static void init_weak_arrays(GCTYPE *gc) { - for (; w; w = (GC_Weak_Array *)w->data[w->count]) { - w->next = (GC_Weak_Array *)w->data[w->count]; - } -} - -static void init_weak_arrays(GCTYPE *gc) { - if (gc->gc_full) { - rechain_inc_weak_arrays(gc->inc_weak_arrays); - gc->weak_arrays = gc->inc_weak_arrays; - gc->inc_weak_arrays = NULL; - } else - gc->weak_arrays = NULL; - gc->bp_weak_arrays = NULL; + GC_ASSERT(!gc->bp_weak_arrays); + gc->weak_arrays = NULL; } static GC_Weak_Array *append_weak_arrays(GC_Weak_Array *wa, GC_Weak_Array *bp_wa, int *_num_gen0) @@ -157,14 +155,18 @@ static GC_Weak_Array *append_weak_arrays(GC_Weak_Array *wa, GC_Weak_Array *bp_wa return bp_wa; } -static void zero_weak_arrays(GCTYPE *gc, int force_zero) +static int zero_weak_arrays(GCTYPE *gc, int force_zero, int from_inc, int need_resolve, int fuel) { GC_Weak_Array *wa; int i, num_gen0; - GC_ASSERT(!gc->bp_weak_arrays || !gc->gc_full); + if (!fuel) return 0; - wa = append_weak_arrays(gc->weak_arrays, gc->bp_weak_arrays, &num_gen0); + if (from_inc) { + wa = gc->inc_weak_arrays; + num_gen0 = 0; + } else + wa = append_weak_arrays(gc->weak_arrays, gc->bp_weak_arrays, &num_gen0); if (gc->gc_full || !gc->started_incremental) num_gen0 = 0; @@ -177,25 +179,45 @@ static void zero_weak_arrays(GCTYPE *gc, int force_zero) void *p = data[i]; if (p && (force_zero || !is_marked(gc, p))) data[i] = wa->replace_val; - else + else if (need_resolve) data[i] = GC_resolve2(p, gc); } + if (fuel > 0) { + fuel -= (4 * wa->count); + if (fuel < 0) fuel = 0; + } if (num_gen0 > 0) { if (!is_in_generation_half(gc, wa)) { - /* For incremental mode, preserve this weak box - in the incremental list for re-checking later. */ - wa->data[wa->count] = gc->inc_weak_arrays; - gc->inc_weak_arrays = wa; + if (!gc->all_marked_incremental) { + /* For incremental mode, preserve this weak array + in the incremental list for re-checking later. */ + wa->data[wa->count] = gc->inc_weak_arrays; + gc->inc_weak_arrays = wa; + } else { + /* Count as incremental-done: */ + wa->data[wa->count] = gc->weak_incremental_done; + } } } - wa = wa->next; + if (from_inc) { + GC_Weak_Array *next; + next = (GC_Weak_Array *)wa->data[wa->count]; + wa->data[wa->count] = gc->weak_incremental_done; + wa = next; + } else + wa = wa->next; num_gen0--; } + if (from_inc) + gc->inc_weak_arrays = NULL; + else { + gc->weak_arrays = NULL; + gc->bp_weak_arrays = NULL; + } - gc->weak_arrays = NULL; - gc->bp_weak_arrays = NULL; + return fuel; } /******************************************************************************/ @@ -240,7 +262,12 @@ static int mark_weak_box(void *p, struct NewGC *gc) wb->inc_next = gc->inc_weak_boxes[wb->is_late]; gc->inc_weak_boxes[wb->is_late] = wb; } else if (gc->during_backpointer) { - if (!gc->gc_full && (wb->val || gc->started_incremental)) { + if ((!gc->gc_full + || (gc->started_incremental + /* see note with `gc->weak_incremental_done` for weak arrays */ + && (wb->inc_next == gc->weak_incremental_done) + && wb->val)) + && (wb->val || gc->started_incremental)) { /* Keep backpointered weak arrays separate, because we should not merge them to the incremental list in incremental mode. */ @@ -254,6 +281,8 @@ static int mark_weak_box(void *p, struct NewGC *gc) check_weak_box_not_already_in_chain(wb, gc->bp_weak_boxes[wb->is_late]); wb->next = gc->weak_boxes[wb->is_late]; gc->weak_boxes[wb->is_late] = wb; + if (gc->gc_full) + wb->inc_next = NULL; /* ensure not a future weak_incremental_done */ } return gcBYTES_TO_WORDS(sizeof(GC_Weak_Box)); @@ -298,27 +327,12 @@ void *GC_malloc_weak_box(void *p, void **secondary, int soffset, int is_late) return w; } -static void rechain_inc_weak_boxes(GC_Weak_Box *wb) +static void init_weak_boxes(GCTYPE *gc) { - for (; wb; wb = wb->inc_next) { - wb->next = wb->inc_next; - } -} - -static void init_weak_boxes(GCTYPE *gc) { - if (gc->gc_full) { - rechain_inc_weak_boxes(gc->inc_weak_boxes[0]); - rechain_inc_weak_boxes(gc->inc_weak_boxes[1]); - gc->weak_boxes[0] = gc->inc_weak_boxes[0]; - gc->weak_boxes[1] = gc->inc_weak_boxes[1]; - gc->inc_weak_boxes[0] = NULL; - gc->inc_weak_boxes[1] = NULL; - } else { - gc->weak_boxes[0] = NULL; - gc->weak_boxes[1] = NULL; - } - gc->bp_weak_boxes[0] = NULL; - gc->bp_weak_boxes[1] = NULL; + GC_ASSERT(!gc->bp_weak_boxes[0]); + GC_ASSERT(!gc->bp_weak_boxes[1]); + gc->weak_boxes[0] = NULL; + gc->weak_boxes[1] = NULL; } static GC_Weak_Box *append_weak_boxes(GC_Weak_Box *wb, GC_Weak_Box *bp_wb, int *_num_gen0) @@ -338,18 +352,23 @@ static GC_Weak_Box *append_weak_boxes(GC_Weak_Box *wb, GC_Weak_Box *bp_wb, int * return bp_wb; } -static void zero_weak_boxes(GCTYPE *gc, int is_late, int force_zero) +static int zero_weak_boxes(GCTYPE *gc, int is_late, int force_zero, int from_inc, int need_resolve, int fuel) { GC_Weak_Box *wb; int num_gen0; - GC_ASSERT(!gc->bp_weak_boxes[is_late] || !gc->gc_full); + if (!fuel) return 0; - wb = append_weak_boxes(gc->weak_boxes[is_late], - gc->bp_weak_boxes[is_late], - &num_gen0); - if (gc->gc_full || !gc->started_incremental) + if (from_inc) { + wb = gc->inc_weak_boxes[is_late]; num_gen0 = 0; + } else { + wb = append_weak_boxes(gc->weak_boxes[is_late], + gc->bp_weak_boxes[is_late], + &num_gen0); + if (gc->gc_full || !gc->started_incremental) + num_gen0 = 0; + } while (wb) { GC_ASSERT(is_marked(gc, wb)); @@ -367,29 +386,67 @@ static void zero_weak_boxes(GCTYPE *gc, int is_late, int force_zero) if (page->mprotected) { page->mprotected = 0; mmu_write_unprotect_page(gc->mmu, page->addr, APAGE_SIZE, page_mmu_type(page), &page->mmu_src_block); + page->reprotect_next = gc->reprotect_next; + gc->reprotect_next = page; + page->reprotect = 1; } p = (void **)GC_resolve2(wb->secondary_erase, gc); *(p + wb->soffset) = NULL; wb->secondary_erase = NULL; } - } else { + } else if (need_resolve) wb->val = GC_resolve2(wb->val, gc); - } + if (num_gen0 > 0) { if (!is_in_generation_half(gc, wb)) { - /* For incremental mode, preserve this weak box - in the incremental list for re-checking later. */ - wb->inc_next = gc->inc_weak_boxes[is_late]; - gc->inc_weak_boxes[is_late] = wb; + if (!gc->all_marked_incremental) { + /* For incremental mode, preserve this weak box + in the incremental list for re-checking later. */ + check_weak_box_not_already_in_inc_chain(wb, gc->inc_weak_boxes[wb->is_late]); + wb->inc_next = gc->inc_weak_boxes[is_late]; + gc->inc_weak_boxes[is_late] = wb; + } else { + /* Count as incremental-done: */ + wb->inc_next = gc->weak_incremental_done; + } } } - wb = wb->next; + + if (from_inc) { + GC_Weak_Box *next; + next = wb->inc_next; + wb->inc_next = gc->weak_incremental_done; + wb = next; + } else + wb = wb->next; + num_gen0--; + + if (fuel >= 0) { + if (fuel > 0) { + if (gc->unprotected_page) { + fuel -= 100; + gc->unprotected_page = 0; + } else + fuel -= 4; + if (fuel < 0) fuel = 0; + } else { + GC_ASSERT(from_inc); + gc->inc_weak_boxes[is_late] = wb; + return 0; + } + } } /* reset, in case we have a second round */ - gc->weak_boxes[is_late] = NULL; - gc->bp_weak_boxes[is_late] = NULL; + if (from_inc) { + gc->inc_weak_boxes[is_late] = NULL; + } else { + gc->weak_boxes[is_late] = NULL; + gc->bp_weak_boxes[is_late] = NULL; + } + + return fuel; } /******************************************************************************/ @@ -411,7 +468,14 @@ static int mark_ephemeron(void *p, struct NewGC *gc) eph->inc_next = gc->inc_ephemerons; gc->inc_ephemerons = eph; } else if (gc->during_backpointer) { - if (!gc->gc_full) { + if (!gc->gc_full + /* If this old-generation object is not yet marked + and we're finishing an incremental pass, then + it won't get marked (and it can only refer to + other old-generation objects), so ignore in that case */ + && (gc->mark_gen1 + || !gc->started_incremental + || !gc->all_marked_incremental)) { eph->next = gc->bp_ephemerons; gc->bp_ephemerons = eph; } @@ -475,20 +539,9 @@ void *GC_malloc_ephemeron(void *k, void *v) return eph; } -static void rechain_inc_ephemerons(GC_Ephemeron *e) -{ - for (; e; e = e->inc_next) { - e->next = e->inc_next; - } -} - void init_ephemerons(GCTYPE *gc) { - if (gc->gc_full) { - rechain_inc_ephemerons(gc->inc_ephemerons); - gc->ephemerons = gc->inc_ephemerons; - gc->inc_ephemerons = NULL; - } else - gc->ephemerons = NULL; + GC_ASSERT(!gc->bp_ephemerons); + gc->ephemerons = NULL; gc->bp_ephemerons = NULL; gc->num_last_seen_ephemerons = 0; } @@ -500,18 +553,23 @@ static int mark_ready_ephemerons(GCTYPE *gc, int inc_gen1) GC_mark_no_recur(gc, 1); - for (j = 0; j < (inc_gen1 ? 1 : 2); j++) { + for (j = 0; j < (inc_gen1 ? 1 : (gc->gc_full ? 3 : 2)); j++) { + waiting = NULL; + if (inc_gen1) eph = gc->inc_ephemerons; else if (j == 0) eph = gc->ephemerons; - else + else if (j == 1) eph = gc->bp_ephemerons; - - waiting = NULL; + else { + eph = gc->inc_ephemerons; + gc->inc_ephemerons = NULL; + waiting = gc->ephemerons; + } for (; eph; eph = next) { - if (inc_gen1) + if (inc_gen1 || (j == 2)) next = eph->inc_next; else next = eph->next; @@ -521,9 +579,10 @@ static int mark_ready_ephemerons(GCTYPE *gc, int inc_gen1) gcMARK2(eph->val, gc); gc->num_last_seen_ephemerons++; did_one = 1; - if (!inc_gen1 && (j == 0) && !gc->gc_full && gc->started_incremental) { + if (!inc_gen1 && (j == 0) && !gc->gc_full + && gc->started_incremental && !gc->all_marked_incremental) { /* Need to preserve the ephemeron in the incremental list, - unless it's kept in generation 1/2 nistead of promoted to + unless it's kept in generation 1/2 instead of promoted to generation 1. */ if (!is_in_generation_half(gc, eph)) { eph->inc_next = gc->inc_ephemerons; @@ -543,7 +602,7 @@ static int mark_ready_ephemerons(GCTYPE *gc, int inc_gen1) if (inc_gen1) gc->inc_ephemerons = waiting; - else if (j == 0) + else if ((j == 0)|| (j == 2)) gc->ephemerons = waiting; else gc->bp_ephemerons = waiting; @@ -554,15 +613,25 @@ static int mark_ready_ephemerons(GCTYPE *gc, int inc_gen1) return did_one; } -static void zero_remaining_ephemerons(GCTYPE *gc) +static void zero_remaining_ephemerons(GCTYPE *gc, int from_inc) { GC_Ephemeron *eph; + GC_ASSERT(from_inc || !gc->gc_full || !gc->inc_ephemerons); + /* After level-1 finalization, any remaining ephemerons should be zeroed. */ - for (eph = gc->ephemerons; eph; eph = eph->next) { - eph->key = NULL; - eph->val = NULL; + if (from_inc) { + for (eph = gc->inc_ephemerons; eph; eph = eph->inc_next) { + eph->key = NULL; + eph->val = NULL; + } + gc->inc_ephemerons = NULL; + } else { + for (eph = gc->ephemerons; eph; eph = eph->next) { + eph->key = NULL; + eph->val = NULL; + } + gc->ephemerons = NULL; } - gc->ephemerons = NULL; } diff --git a/racket/src/racket/include/escheme.h b/racket/src/racket/include/escheme.h index 6d117330f2..abe690a720 100644 --- a/racket/src/racket/include/escheme.h +++ b/racket/src/racket/include/escheme.h @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995 Matthew Flatt All rights reserved. diff --git a/racket/src/racket/include/mzwin.def b/racket/src/racket/include/mzwin.def index f76f16ac0f..ede22b69ab 100644 --- a/racket/src/racket/include/mzwin.def +++ b/racket/src/racket/include/mzwin.def @@ -226,6 +226,7 @@ EXPORTS scheme_collect_garbage scheme_collect_garbage_minor scheme_enable_garbage_collection + scheme_incremental_garbage_collection scheme_malloc_immobile_box scheme_free_immobile_box scheme_add_gc_callback diff --git a/racket/src/racket/include/mzwin3m.def b/racket/src/racket/include/mzwin3m.def index 844b694200..8cada188d5 100644 --- a/racket/src/racket/include/mzwin3m.def +++ b/racket/src/racket/include/mzwin3m.def @@ -234,6 +234,7 @@ EXPORTS scheme_collect_garbage scheme_collect_garbage_minor scheme_enable_garbage_collection + scheme_incremental_garbage_collection GC_variable_stack GC_register_traversers GC_resolve diff --git a/racket/src/racket/include/racket.exp b/racket/src/racket/include/racket.exp index 831814d7b4..3cf3a31ea3 100644 --- a/racket/src/racket/include/racket.exp +++ b/racket/src/racket/include/racket.exp @@ -237,6 +237,7 @@ scheme_gc_ptr_ok scheme_collect_garbage scheme_collect_garbage_minor scheme_enable_garbage_collection +scheme_incremental_garbage_collection GC_register_traversers GC_resolve GC_mark diff --git a/racket/src/racket/include/racket3m.exp b/racket/src/racket/include/racket3m.exp index 84d9b9c58f..b20a398a31 100644 --- a/racket/src/racket/include/racket3m.exp +++ b/racket/src/racket/include/racket3m.exp @@ -241,6 +241,7 @@ scheme_gc_ptr_ok scheme_collect_garbage scheme_collect_garbage_minor scheme_enable_garbage_collection +scheme_incremental_garbage_collection GC_variable_stack GC_register_traversers GC_resolve diff --git a/racket/src/racket/include/scheme.h b/racket/src/racket/include/scheme.h index 1ede3d0c9b..dcaa235510 100644 --- a/racket/src/racket/include/scheme.h +++ b/racket/src/racket/include/scheme.h @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt All rights reserved. @@ -93,6 +93,9 @@ typedef struct { typedef long double mz_long_double; # endif #else +# ifdef MZ_INSIST_EXTFLONUMS +# error "cannot support extflonums; you may need to adjust compiler options" +# endif typedef double mz_long_double; #endif @@ -1345,6 +1348,7 @@ enum { MZCONFIG_CAN_READ_READER, MZCONFIG_CAN_READ_LANG, MZCONFIG_READ_DECIMAL_INEXACT, + MZCONFIG_READ_CDOT, MZCONFIG_PRINT_GRAPH, MZCONFIG_PRINT_STRUCT, @@ -1362,6 +1366,8 @@ enum { MZCONFIG_CASE_SENS, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, MZCONFIG_CURLY_BRACES_ARE_PARENS, + MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, + MZCONFIG_CURLY_BRACES_ARE_TAGGED, MZCONFIG_ERROR_PRINT_WIDTH, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, @@ -1542,10 +1548,6 @@ struct Scheme_Output_Port struct Scheme_Input_Port *input_half; }; -#define SCHEME_INPORT_VAL(obj) (((Scheme_Input_Port *)(obj))->port_data) -#define SCHEME_OUTPORT_VAL(obj) (((Scheme_Output_Port *)(obj))->port_data) -#define SCHEME_IPORT_NAME(obj) (((Scheme_Input_Port *)obj)->name) - #define SCHEME_SPECIAL (-2) #define SCHEME_UNLESS_READY (-3) @@ -1947,6 +1949,9 @@ MZ_EXTERN void scheme_set_addon_dir(Scheme_Object *p); MZ_EXTERN void scheme_set_command_line_arguments(Scheme_Object *vec); MZ_EXTERN void scheme_set_compiled_file_paths(Scheme_Object *list); MZ_EXTERN void scheme_set_compiled_file_roots(Scheme_Object *list); +#ifdef DOS_FILE_SYSTEM +MZ_EXTERN void scheme_set_dll_path(wchar_t *s); +#endif MZ_EXTERN void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs); MZ_EXTERN void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *extra_dirs, Scheme_Object *extra_post_dirs); diff --git a/racket/src/racket/include/schthread.h b/racket/src/racket/include/schthread.h index e614cf1842..2bf55034d5 100644 --- a/racket/src/racket/include/schthread.h +++ b/racket/src/racket/include/schthread.h @@ -202,6 +202,7 @@ typedef struct Thread_Local_Variables { struct Scheme_Custodian *new_port_cust_; #if (defined(__WIN32__) || defined(WIN32) || defined(_WIN32)) void *scheme_break_semaphore_; + void *process_job_object_; #else int external_event_fd_; int put_external_event_fd_; @@ -267,7 +268,6 @@ typedef struct Thread_Local_Variables { intptr_t scheme_current_cont_mark_stack_; intptr_t scheme_current_cont_mark_pos_; struct Scheme_Custodian *main_custodian_; - struct Scheme_Custodian *last_custodian_; struct Scheme_Hash_Table *limited_custodians_; struct Scheme_Plumber *initial_plumber_; struct Scheme_Config *initial_config_; @@ -599,6 +599,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define locked_fd_process_map XOA (scheme_get_thread_local_variables()->locked_fd_process_map_) #define new_port_cust XOA (scheme_get_thread_local_variables()->new_port_cust_) #define scheme_break_semaphore XOA (scheme_get_thread_local_variables()->scheme_break_semaphore_) +#define process_job_object XOA (scheme_get_thread_local_variables()->process_job_object_) #define external_event_fd XOA (scheme_get_thread_local_variables()->external_event_fd_) #define put_external_event_fd XOA (scheme_get_thread_local_variables()->put_external_event_fd_) #define read_string_byte_buffer XOA (scheme_get_thread_local_variables()->read_string_byte_buffer_) diff --git a/racket/src/racket/main.c b/racket/src/racket/main.c index 2c65759161..2e6b294613 100644 --- a/racket/src/racket/main.c +++ b/racket/src/racket/main.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2000 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/mzconfig.h.in b/racket/src/racket/mzconfig.h.in index 154363d47e..c110bdd358 100644 --- a/racket/src/racket/mzconfig.h.in +++ b/racket/src/racket/mzconfig.h.in @@ -74,6 +74,9 @@ typedef unsigned long uintptr_t; /* When __builtin_popcount() is available: */ #undef MZ_HAS_BUILTIN_POPCOUNT +/* When __builtin_clz() is available: */ +#undef MZ_HAS_BUILTIN_CLZ + /* Enable futures: */ #undef MZ_USE_FUTURES @@ -95,6 +98,9 @@ typedef unsigned long uintptr_t; /* To disable extflonums when they would otherwise work: */ #undef MZ_NO_EXTFLONUMS +/* Extflonums are specifically requested (so complain if not supported): */ +#undef MZ_INSIST_EXTFLONUMS + /* Library subpath */ #undef SPLS_SUFFIX diff --git a/racket/src/racket/sconfig.h b/racket/src/racket/sconfig.h index 27fb376ea5..4df1b80d59 100644 --- a/racket/src/racket/sconfig.h +++ b/racket/src/racket/sconfig.h @@ -679,6 +679,7 @@ /* With VC 7, ATAN2_DOESNT... wasn't needed, and POW_HANDLES_INF_CORRECTLY worked, too. */ # define SIN_COS_NEED_DEOPTIMIZE +# define AVOID_INT_TO_FLOAT_TRUNCATION #endif #ifdef __BORLANDC__ # define NAN_EQUALS_ANYTHING @@ -1281,6 +1282,11 @@ /* FLOATING_POINT_IS_NOT_IEEE disables inexact->exact conversion via parsing of IEEE-format bits. */ + /* AVOID_INT_TO_FLOAT_TRUNCATION indicates that conversion from an + integer to a floating point type does not round-to-nearest when + precision is lost, even when the FP rounding mode is + round-to-nearest */ + /* USE_SINGLE_FLOATS turns on support for single-precision floating point numbers. Otherwise, floating point numbers are always represented in double-precision. */ diff --git a/racket/src/racket/sgc/sgc.c b/racket/src/racket/sgc/sgc.c index 0e8cea20d4..022c488d84 100644 --- a/racket/src/racket/sgc/sgc.c +++ b/racket/src/racket/sgc/sgc.c @@ -1,7 +1,7 @@ /* SenoraGC, a relatively portable conservative GC for a slightly cooperative environment - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1996-98 Matthew Flatt All rights reserved. diff --git a/racket/src/racket/src/bgnfloat.inc b/racket/src/racket/src/bgnfloat.inc index bd07924ae9..38bd0ec5d1 100644 --- a/racket/src/racket/src/bgnfloat.inc +++ b/racket/src/racket/src/bgnfloat.inc @@ -27,7 +27,7 @@ FP_TYPE SCHEME_BIGNUM_TO_FLOAT_INFO(const Scheme_Object *n, intptr_t skip, intpt FP_TYPE d; nl = SCHEME_BIGLEN(n); - na = SCHEME_BIGDIG(n) + nl; + na = SCHEME_BIGDIG(n); skipped = nl; @@ -38,14 +38,63 @@ FP_TYPE SCHEME_BIGNUM_TO_FLOAT_INFO(const Scheme_Object *n, intptr_t skip, intpt return FP_scheme_floating_point_nzero; } else nl -= skip; - - d = FP_ZEROx; - while (nl--) { - d = FP_TYPE_MULT(d, FP_TYPE_FROM_DOUBLE(BIG_RADIX)); - d = FP_TYPE_PLUS(d, FP_TYPE_FROM_UINTPTR(*(--na))); - if (IS_FLOAT_INF(d)) - break; - --skipped; + + if (!nl) + d = FP_ZEROx; + else if (nl == 1) { + d = FP_TYPE_FROM_UINTPTR(*na); + skipped = 0; + } else { + /* We'll get all the bits that matter in the first word or two, + and we won't lose precision as long as we shift so that the + highest bit in a word is non-zero */ + bigdig b = na[nl-1]; + int delta; + + delta = mz_clz(b); + if (delta) { + /* zero bits in the highest word => pull in bits from the + second-highest word */ + b = (b << delta) + (na[nl-2] >> (WORD_SIZE - delta)); + } + if (sizeof(FP_TYPE) <= sizeof(bigdig)) { + /* one bigdig is enough, and the last bit is certainly + not needed, but it needs to summarize whether there + are any more non-zero bits in the number */ + if (!(b & 0x1) && any_nonzero_digits(na, nl-1, delta)) + b |= 0x1; + d = FP_TYPE_FROM_UINTPTR(b); + } else { + /* Need to look at a second word, possibly pulling in bits from + a third word */ + d = FP_TYPE_FROM_UINTPTR(b); + d = FP_TYPE_MULT(d, FP_TYPE_FROM_DOUBLE(BIG_RADIX)); + b = (na[nl-2] << delta); + if ((nl > 2) && delta) + b += (na[nl-3] >> (WORD_SIZE - delta)); + if (!(b & 0x1) && (nl > 2) && any_nonzero_digits(na, nl-2, delta)) + b |= 0x1; + d = FP_TYPE_PLUS(d, FP_TYPE_FROM_UINTPTR(b)); + d = FP_TYPE_DIV(d, FP_TYPE_FROM_DOUBLE(BIG_RADIX)); + } + /* Shift `d` back down by delta: */ + if (delta) + d = FP_TYPE_DIV(d, FP_TYPE_POW(FP_TYPE_FROM_DOUBLE(2.0), + FP_TYPE_FROM_INT(delta))); + nl--; + + /* Shift `d` up by remaining bignum words */ + if (_skipped) { + while (nl--) { + d = FP_TYPE_MULT(d, FP_TYPE_FROM_DOUBLE(BIG_RADIX)); + if (IS_FLOAT_INF(d)) + break; + --skipped; + } + } else { + d = FP_TYPE_MULT(d, FP_TYPE_POW(FP_TYPE_FROM_DOUBLE(2.0), + FP_TYPE_FROM_UINTPTR(nl * WORD_SIZE))); + } } if (_skipped) @@ -151,6 +200,7 @@ Scheme_Object *SCHEME_BIGNUM_FROM_FLOAT(FP_TYPE d) #undef FP_TYPE_MULT #undef FP_TYPE_PLUS #undef FP_TYPE_DIV +#undef FP_TYPE_POW #undef FP_TYPE_FROM_INT #undef FP_TYPE_GREATER_OR_EQV #undef FP_TYPE_MINUS diff --git a/racket/src/racket/src/bignum.c b/racket/src/racket/src/bignum.c index 51ec30b937..f73197ba3b 100644 --- a/racket/src/racket/src/bignum.c +++ b/racket/src/racket/src/bignum.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt, Scott Owens This library is free software; you can redistribute it and/or @@ -90,6 +90,7 @@ void scheme_bignum_use_fuel(intptr_t n); #if defined(SIXTY_FOUR_BIT_INTEGERS) || defined(USE_LONG_LONG_FOR_BIGDIG) # define BIG_RADIX 18446744073709551616.0 /* = 0x10000000000000000 */ +# define BIG_HALF_RADIX 4294967296.0 # define WORD_SIZE 64 #else # define BIG_RADIX 4294967296.0 /* = 0x100000000 */ @@ -1422,19 +1423,77 @@ static void bignum_add1_inplace(Scheme_Object **_stk_o) *_stk_o = bignum_copy(*_stk_o, carry); } +XFORM_NONGCING static int mz_clz(uintptr_t n) +{ +#ifdef MZ_HAS_BUILTIN_CLZ +# if defined(SIXTY_FOUR_BIT_INTEGERS) || defined(USE_LONG_LONG_FOR_BIGDIG) + uintptr_t hi = (n >> (WORD_SIZE >> 1)); + if (hi) + return __builtin_clz(hi); + else { + unsigned int low = n; + return (WORD_SIZE >> 1) + __builtin_clz(low); + } +# else + return __builtin_clz(n); +# endif +#else + int c = 0, d = (WORD_SIZE >> 1); + while (d) { + if (n >> (c + d)) + c += d; + d = d >> 1; + } + return WORD_SIZE - 1 - c; +#endif +} + +XFORM_NONGCING static int any_nonzero_digits(bigdig *na, intptr_t nl, int delta) +/* if `delta`, then check only after that many bits in the most-significant + digit */ +{ + if (delta) { + if (na[nl-1] & (((bigdig)1 << (WORD_SIZE - delta)) - 1)) + return 1; + nl--; + } + + while (nl--) { + if (na[nl]) + return 1; + } + return 0; +} + +#if defined(SIXTY_FOUR_BIT_INTEGERS) && defined(AVOID_INT_TO_FLOAT_TRUNCATION) +XFORM_NONGCING static double double_from_bigdig(bigdig b) +{ + double d1, d2; + + d1 = (double)(b >> (WORD_SIZE >> 1)); + d2 = (double)(b & (((bigdig)1 << (WORD_SIZE >> 1))-1)); + return (d1 * BIG_HALF_RADIX) + d2; +} +#endif + #define USE_FLOAT_BITS 53 #define FP_TYPE double -#define FP_TYPE_FROM_DOUBLE(x) (FP_TYPE)x +#define FP_TYPE_FROM_DOUBLE(x) ((FP_TYPE)(x)) #define FP_TYPE_NEG(x) (-(x)) #define FP_TYPE_LESS(x, y) ((x)<(y)) #define FP_TYPE_MULT(x, y) ((x)*(y)) #define FP_TYPE_PLUS(x, y) ((x)+(y)) #define FP_TYPE_DIV(x, y) ((x)/(y)) +#define FP_TYPE_POW(x, y) pow(x, y) #define FP_TYPE_FROM_INT(x) ((FP_TYPE)(x)) +#if defined(SIXTY_FOUR_BIT_INTEGERS) && defined(AVOID_INT_TO_FLOAT_TRUNCATION) +# define FP_TYPE_FROM_UINTPTR(x) double_from_bigdig(x) +#else +# define FP_TYPE_FROM_UINTPTR(x) ((FP_TYPE)(x)) +#endif #define FP_TYPE_GREATER_OR_EQV(x, y) ((x)>=(y)) #define FP_TYPE_MINUS(x, y) ((x)-(y)) -#define FP_TYPE_FROM_UINTPTR #define IS_FLOAT_INF scheme__is_double_inf #define SCHEME_BIGNUM_TO_FLOAT_INFO scheme_bignum_to_double_inf_info @@ -1447,16 +1506,26 @@ static void bignum_add1_inplace(Scheme_Object **_stk_o) # define USE_FLOAT_BITS 24 # define FP_TYPE float -# define FP_TYPE_FROM_DOUBLE(x) (FP_TYPE)x +#define FP_TYPE_FROM_DOUBLE(x) ((FP_TYPE)(x)) #define FP_TYPE_NEG(x) (-(x)) #define FP_TYPE_LESS(x, y) ((x)<(y)) #define FP_TYPE_MULT(x, y) ((x)*(y)) #define FP_TYPE_PLUS(x, y) ((x)+(y)) #define FP_TYPE_DIV(x, y) ((x)/(y)) -#define FP_TYPE_FROM_INT(x) ((FP_TYPE)(x)) +#define FP_TYPE_POW(x, y) pow(x, y) +#if defined(AVOID_INT_TO_FLOAT_TRUNCATION) +# if defined(SIXTY_FOUR_BIT_INTEGERS) +# define FP_TYPE_FROM_UINTPTR(x) ((FP_TYPE)double_from_bigdig(x)) +# else +# define FP_TYPE_FROM_UINTPTR(x) (FP_TYPE)((double)(x)) +# endif +# define FP_TYPE_FROM_INT(x) (FP_TYPE)((double)(x)) +#else +# define FP_TYPE_FROM_UINTPTR(x) ((FP_TYPE)(x)) +# define FP_TYPE_FROM_INT(x) ((FP_TYPE)(x)) +#endif #define FP_TYPE_GREATER_OR_EQV(x, y) ((x)>=(y)) #define FP_TYPE_MINUS(x, y) ((x)-(y)) -# define FP_TYPE_FROM_UINTPTR # define IS_FLOAT_INF scheme__is_float_inf # define SCHEME_BIGNUM_TO_FLOAT_INFO scheme_bignum_to_float_inf_info @@ -1475,6 +1544,7 @@ static void bignum_add1_inplace(Scheme_Object **_stk_o) # define FP_TYPE_MULT(x, y) long_double_mult(x, y) # define FP_TYPE_DIV(x, y) long_double_div(x, y) # define FP_TYPE_PLUS(x, y) long_double_plus(x, y) +# define FP_TYPE_POW(x, y) long_double_pow(x, y) # define FP_TYPE_FROM_INT(x) long_double_from_int(x) # define FP_TYPE_GREATER_OR_EQV(x, y) long_double_greater_or_eqv(x, y) # define FP_TYPE_MINUS(x, y) long_double_minus(x, y) diff --git a/racket/src/racket/src/bool.c b/racket/src/racket/src/bool.c index 20cee7e098..4be93d6a68 100644 --- a/racket/src/racket/src/bool.c +++ b/racket/src/racket/src/bool.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/builtin.c b/racket/src/racket/src/builtin.c index 5ccb0167a6..8bf11e9c0b 100644 --- a/racket/src/racket/src/builtin.c +++ b/racket/src/racket/src/builtin.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/char.c b/racket/src/racket/src/char.c index a0a19e7ee0..0ad270afa3 100644 --- a/racket/src/racket/src/char.c +++ b/racket/src/racket/src/char.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index 34eaaae6d9..7ee37f5a05 100644 --- a/racket/src/racket/src/compenv.c +++ b/racket/src/racket/src/compenv.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/compile.c b/racket/src/racket/src/compile.c index 08411a061b..5aefc655d1 100644 --- a/racket/src/racket/src/compile.c +++ b/racket/src/racket/src/compile.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -4819,6 +4819,7 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, form = scheme_stx_track(SCHEME_PTR1_VAL(var), form, NULL); if (!rec[drec].comp) { /* Already fully expanded. */ + SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(env->observer, form); return form; } } else { diff --git a/racket/src/racket/src/complex.c b/racket/src/racket/src/complex.c index e913396d5f..e1f2d65ad1 100644 --- a/racket/src/racket/src/complex.c +++ b/racket/src/racket/src/complex.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/cstartup.inc b/racket/src/racket/src/cstartup.inc index 116af35bcd..574a9b0113 100644 --- a/racket/src/racket/src/cstartup.inc +++ b/racket/src/racket/src/cstartup.inc @@ -1,952 +1,955 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,10,54,46,50,46,57,48,48,46,49,53,84,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,0,0,54,0,0,0,1,0,0,8, -0,18,0,22,0,26,0,31,0,38,0,42,0,47,0,59,0,66,0,69,0, -82,0,89,0,94,0,103,0,109,0,123,0,137,0,140,0,146,0,157,0,159, -0,173,0,180,0,202,0,204,0,218,0,246,0,251,0,255,0,72,1,79,1, -90,1,128,1,135,1,144,1,177,1,210,1,16,2,21,2,102,2,107,2,112, -2,133,2,30,3,51,3,104,3,173,3,242,3,132,4,24,5,35,5,118,5, -0,0,148,7,0,0,3,1,5,105,110,115,112,48,71,35,37,109,105,110,45, -115,116,120,29,11,11,11,65,97,110,100,66,99,111,110,100,68,100,101,102,105, -110,101,65,108,101,116,66,108,101,116,42,73,108,101,116,42,45,118,97,108,117, -101,115,68,108,101,116,114,101,99,64,111,114,74,112,97,114,97,109,101,116,101, -114,105,122,101,68,117,110,108,101,115,115,66,119,104,101,110,70,104,101,114,101, -45,115,116,120,67,113,117,111,116,101,29,94,2,16,70,35,37,107,101,114,110, -101,108,11,29,94,2,16,70,35,37,112,97,114,97,109,122,11,64,105,102,67, -98,101,103,105,110,72,108,101,116,45,118,97,108,117,101,115,63,120,75,108,101, -116,114,101,99,45,118,97,108,117,101,115,68,108,97,109,98,100,97,1,20,112, -97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,63,118, -75,100,101,102,105,110,101,45,118,97,108,117,101,115,38,28,16,3,93,16,2, -29,11,11,11,2,3,2,29,93,143,16,5,39,2,31,40,2,34,2,2,39, -38,29,93,2,30,36,30,0,39,36,31,1,145,40,143,2,32,16,4,2,17, -39,39,2,1,143,2,32,16,4,2,18,39,39,2,1,16,22,2,4,2,33, -2,5,2,33,2,6,2,33,2,7,2,33,2,8,2,33,2,9,2,33,2, -10,2,33,2,11,2,33,2,12,2,33,2,13,2,33,2,14,2,33,38,32, -143,2,31,2,29,38,33,93,143,2,32,143,2,1,2,3,36,34,2,144,40, -143,2,35,16,4,2,17,40,39,2,1,16,2,2,15,93,143,2,35,147,2, -1,2,3,40,2,15,143,2,3,40,2,15,38,35,143,2,34,2,29,18,143, -66,104,101,114,101,2,28,27,248,22,164,4,195,249,22,157,4,80,143,42,39, -251,22,90,2,19,248,22,102,199,12,249,22,80,2,20,248,22,104,201,27,248, -22,164,4,195,249,22,157,4,80,143,42,39,251,22,90,2,19,248,22,102,199, -249,22,80,2,20,248,22,104,201,12,27,248,22,82,248,22,164,4,196,28,248, -22,88,193,20,14,144,40,39,40,28,248,22,88,248,22,82,194,248,22,164,20, -193,249,22,157,4,80,143,42,39,251,22,90,2,19,248,22,164,20,199,249,22, -80,2,4,248,22,165,20,201,11,18,143,10,2,28,27,248,22,82,248,22,164, -4,196,28,248,22,88,193,20,14,144,40,39,40,28,248,22,88,248,22,82,194, -248,22,164,20,193,249,22,157,4,80,143,42,39,250,22,90,2,21,248,22,90, -249,22,90,248,22,90,2,22,248,22,164,20,201,251,22,90,2,19,2,22,2, -22,249,22,80,2,11,248,22,165,20,204,18,143,11,2,28,248,22,164,4,193, -27,248,22,164,4,194,249,22,80,248,22,90,248,22,81,196,248,22,165,20,195, -27,248,22,82,248,22,164,4,23,197,1,249,22,157,4,80,143,42,39,28,248, -22,64,248,22,158,4,248,22,81,23,198,2,27,249,22,2,32,0,88,148,8, -36,40,46,11,9,222,33,43,248,22,164,4,248,22,102,23,200,2,250,22,90, -2,23,248,22,90,249,22,90,248,22,90,248,22,164,20,23,204,2,250,22,91, -2,24,249,22,2,22,81,23,204,2,248,22,104,23,206,2,249,22,80,248,22, -164,20,23,202,1,249,22,2,22,102,23,200,1,250,22,91,2,21,249,22,2, -32,0,88,148,8,36,40,50,11,9,222,33,44,248,22,164,4,248,22,164,20, -201,248,22,165,20,198,27,248,22,164,4,194,249,22,80,248,22,90,248,22,81, -196,248,22,165,20,195,27,248,22,82,248,22,164,4,23,197,1,249,22,157,4, -80,143,42,39,250,22,91,2,23,249,22,2,32,0,88,148,8,36,40,50,11, -9,222,33,46,248,22,164,4,248,22,81,201,248,22,165,20,198,27,248,22,82, -248,22,164,4,196,27,248,22,164,4,248,22,81,195,249,22,157,4,80,143,43, -39,28,248,22,88,195,250,22,91,2,21,9,248,22,165,20,199,250,22,90,2, -7,248,22,90,248,22,81,199,250,22,91,2,8,248,22,165,20,201,248,22,165, -20,202,27,248,22,82,248,22,164,4,196,27,248,22,164,4,248,22,81,195,249, -22,157,4,80,143,43,39,28,248,22,88,195,250,22,91,2,21,9,248,22,165, -20,199,250,22,90,2,21,248,22,90,248,22,81,199,250,22,91,2,9,248,22, -165,20,201,248,22,165,20,202,27,248,22,82,248,22,164,4,23,197,1,27,249, -22,1,22,94,249,22,2,22,164,4,248,22,164,4,248,22,81,199,248,22,185, -4,249,22,157,4,80,143,44,39,251,22,90,1,22,119,105,116,104,45,99,111, -110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,2,25,250,22,91,1, -23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116, -105,111,110,21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109, -97,114,107,45,115,101,116,45,102,105,114,115,116,11,2,25,202,250,22,91,2, -21,9,248,22,165,20,204,27,248,22,82,248,22,164,4,196,28,248,22,88,193, -20,14,144,40,39,40,249,22,157,4,80,143,42,39,27,248,22,164,4,248,22, -81,197,28,249,22,169,9,64,61,62,248,22,158,4,248,22,102,196,250,22,90, -2,21,248,22,90,249,22,90,21,93,2,26,248,22,164,20,199,250,22,91,2, -5,249,22,90,2,26,249,22,90,248,22,111,203,2,26,248,22,165,20,202,251, -22,90,2,19,28,249,22,169,9,248,22,158,4,248,22,164,20,200,66,101,108, -115,101,10,248,22,164,20,197,250,22,91,2,21,9,248,22,165,20,200,249,22, -80,2,5,248,22,165,20,202,18,143,94,10,66,118,111,105,100,2,28,27,248, -22,82,248,22,164,4,196,249,22,157,4,80,143,42,39,28,248,22,64,248,22, -158,4,248,22,81,197,250,22,90,2,27,248,22,90,248,22,164,20,199,248,22, -102,198,27,248,22,158,4,248,22,164,20,197,250,22,90,2,27,248,22,90,248, -22,81,197,250,22,91,2,24,248,22,165,20,199,248,22,165,20,202,145,39,9, -20,121,145,2,1,39,16,1,11,16,0,20,27,15,61,9,2,2,2,2,2, -3,11,11,11,11,9,9,11,11,11,10,39,80,143,39,39,20,121,145,2,1, -39,16,0,16,0,41,42,39,16,0,39,16,0,39,11,11,11,16,11,2,4, -2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,16, -11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,4,2,5,2,6,2, -7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,39,50,40,16,0,39, -16,1,2,15,40,11,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16, -0,16,0,16,0,39,39,16,12,16,5,11,20,15,16,2,20,14,144,39,39, -40,80,143,39,39,39,20,121,145,2,1,39,16,1,2,15,16,1,33,36,10, -16,5,2,13,88,148,8,36,40,56,40,9,223,0,33,37,39,20,121,145,2, -1,39,16,1,2,15,16,0,11,16,5,2,14,88,148,8,36,40,56,40,9, -223,0,33,38,39,20,121,145,2,1,39,16,1,2,15,16,0,11,16,5,2, -4,88,148,8,36,40,56,42,9,223,0,33,39,39,20,121,145,2,1,39,16, -1,2,15,16,1,33,40,11,16,5,2,11,88,148,8,36,40,59,42,9,223, -0,33,41,39,20,121,145,2,1,39,16,1,2,15,16,1,33,42,11,16,5, -2,7,88,148,8,36,40,61,40,9,223,0,33,45,39,20,121,145,2,1,39, -16,1,2,15,16,0,11,16,5,2,10,88,148,8,36,40,56,40,9,223,0, -33,47,39,20,121,145,2,1,39,16,1,2,15,16,0,11,16,5,2,8,88, -148,8,36,40,57,40,9,223,0,33,48,39,20,121,145,2,1,39,16,1,2, -15,16,0,11,16,5,2,9,88,148,8,36,40,57,40,9,223,0,33,49,39, -20,121,145,2,1,39,16,1,2,15,16,0,11,16,5,2,12,88,148,8,36, -40,59,40,9,223,0,33,50,39,20,121,145,2,1,39,16,1,2,15,16,0, -11,16,5,2,5,88,148,8,36,40,61,42,9,223,0,33,51,39,20,121,145, -2,1,39,16,1,2,15,16,1,33,52,11,16,5,2,6,88,148,8,36,40, -57,40,9,223,0,33,53,39,20,121,145,2,1,39,16,1,2,15,16,0,11, -16,0,94,2,17,2,18,93,2,17,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2093); + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,51,46,48,46,49,48,84,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,54,0,0,0,1,0,0,8,0,18, +0,22,0,26,0,31,0,38,0,42,0,47,0,59,0,66,0,69,0,82,0, +89,0,94,0,103,0,109,0,123,0,137,0,140,0,146,0,157,0,159,0,173, +0,180,0,202,0,204,0,218,0,246,0,251,0,255,0,72,1,79,1,90,1, +128,1,135,1,144,1,177,1,210,1,16,2,21,2,102,2,107,2,112,2,133, +2,30,3,51,3,104,3,173,3,242,3,132,4,24,5,35,5,118,5,0,0, +148,7,0,0,3,1,5,105,110,115,112,48,71,35,37,109,105,110,45,115,116, +120,29,11,11,11,65,97,110,100,66,99,111,110,100,68,100,101,102,105,110,101, +65,108,101,116,66,108,101,116,42,73,108,101,116,42,45,118,97,108,117,101,115, +68,108,101,116,114,101,99,64,111,114,74,112,97,114,97,109,101,116,101,114,105, +122,101,68,117,110,108,101,115,115,66,119,104,101,110,70,104,101,114,101,45,115, +116,120,67,113,117,111,116,101,29,94,2,16,70,35,37,107,101,114,110,101,108, +11,29,94,2,16,70,35,37,112,97,114,97,109,122,11,64,105,102,67,98,101, +103,105,110,72,108,101,116,45,118,97,108,117,101,115,63,120,75,108,101,116,114, +101,99,45,118,97,108,117,101,115,68,108,97,109,98,100,97,1,20,112,97,114, +97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,63,118,75,100, +101,102,105,110,101,45,118,97,108,117,101,115,38,28,16,3,93,16,2,29,11, +11,11,2,3,2,29,93,143,16,5,39,2,31,40,2,34,2,2,39,38,29, +93,2,30,36,30,0,39,36,31,1,145,40,143,2,32,16,4,2,17,39,39, +2,1,143,2,32,16,4,2,18,39,39,2,1,16,22,2,4,2,33,2,5, +2,33,2,6,2,33,2,7,2,33,2,8,2,33,2,9,2,33,2,10,2, +33,2,11,2,33,2,12,2,33,2,13,2,33,2,14,2,33,38,32,143,2, +31,2,29,38,33,93,143,2,32,143,2,1,2,3,36,34,2,144,40,143,2, +35,16,4,2,17,40,39,2,1,16,2,2,15,93,143,2,35,147,2,1,2, +3,40,2,15,143,2,3,40,2,15,38,35,143,2,34,2,29,18,143,66,104, +101,114,101,2,28,27,248,22,165,4,195,249,22,158,4,80,143,42,39,251,22, +91,2,19,248,22,103,199,12,249,22,81,2,20,248,22,105,201,27,248,22,165, +4,195,249,22,158,4,80,143,42,39,251,22,91,2,19,248,22,103,199,249,22, +81,2,20,248,22,105,201,12,27,248,22,83,248,22,165,4,196,28,248,22,89, +193,20,14,144,40,39,40,28,248,22,89,248,22,83,194,248,22,170,20,193,249, +22,158,4,80,143,42,39,251,22,91,2,19,248,22,170,20,199,249,22,81,2, +4,248,22,171,20,201,11,18,143,10,2,28,27,248,22,83,248,22,165,4,196, +28,248,22,89,193,20,14,144,40,39,40,28,248,22,89,248,22,83,194,248,22, +170,20,193,249,22,158,4,80,143,42,39,250,22,91,2,21,248,22,91,249,22, +91,248,22,91,2,22,248,22,170,20,201,251,22,91,2,19,2,22,2,22,249, +22,81,2,11,248,22,171,20,204,18,143,11,2,28,248,22,165,4,193,27,248, +22,165,4,194,249,22,81,248,22,91,248,22,82,196,248,22,171,20,195,27,248, +22,83,248,22,165,4,23,197,1,249,22,158,4,80,143,42,39,28,248,22,65, +248,22,159,4,248,22,82,23,198,2,27,249,22,2,32,0,88,148,8,36,40, +46,11,9,222,33,43,248,22,165,4,248,22,103,23,200,2,250,22,91,2,23, +248,22,91,249,22,91,248,22,91,248,22,170,20,23,204,2,250,22,92,2,24, +249,22,2,22,82,23,204,2,248,22,105,23,206,2,249,22,81,248,22,170,20, +23,202,1,249,22,2,22,103,23,200,1,250,22,92,2,21,249,22,2,32,0, +88,148,8,36,40,50,11,9,222,33,44,248,22,165,4,248,22,170,20,201,248, +22,171,20,198,27,248,22,165,4,194,249,22,81,248,22,91,248,22,82,196,248, +22,171,20,195,27,248,22,83,248,22,165,4,23,197,1,249,22,158,4,80,143, +42,39,250,22,92,2,23,249,22,2,32,0,88,148,8,36,40,50,11,9,222, +33,46,248,22,165,4,248,22,82,201,248,22,171,20,198,27,248,22,83,248,22, +165,4,196,27,248,22,165,4,248,22,82,195,249,22,158,4,80,143,43,39,28, +248,22,89,195,250,22,92,2,21,9,248,22,171,20,199,250,22,91,2,7,248, +22,91,248,22,82,199,250,22,92,2,8,248,22,171,20,201,248,22,171,20,202, +27,248,22,83,248,22,165,4,196,27,248,22,165,4,248,22,82,195,249,22,158, +4,80,143,43,39,28,248,22,89,195,250,22,92,2,21,9,248,22,171,20,199, +250,22,91,2,21,248,22,91,248,22,82,199,250,22,92,2,9,248,22,171,20, +201,248,22,171,20,202,27,248,22,83,248,22,165,4,23,197,1,27,249,22,1, +22,95,249,22,2,22,165,4,248,22,165,4,248,22,82,199,248,22,186,4,249, +22,158,4,80,143,44,39,251,22,91,1,22,119,105,116,104,45,99,111,110,116, +105,110,117,97,116,105,111,110,45,109,97,114,107,2,25,250,22,92,1,23,101, +120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111, +110,21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114, +107,45,115,101,116,45,102,105,114,115,116,11,2,25,202,250,22,92,2,21,9, +248,22,171,20,204,27,248,22,83,248,22,165,4,196,28,248,22,89,193,20,14, +144,40,39,40,249,22,158,4,80,143,42,39,27,248,22,165,4,248,22,82,197, +28,249,22,170,9,64,61,62,248,22,159,4,248,22,103,196,250,22,91,2,21, +248,22,91,249,22,91,21,93,2,26,248,22,170,20,199,250,22,92,2,5,249, +22,91,2,26,249,22,91,248,22,112,203,2,26,248,22,171,20,202,251,22,91, +2,19,28,249,22,170,9,248,22,159,4,248,22,170,20,200,66,101,108,115,101, +10,248,22,170,20,197,250,22,92,2,21,9,248,22,171,20,200,249,22,81,2, +5,248,22,171,20,202,18,143,94,10,66,118,111,105,100,2,28,27,248,22,83, +248,22,165,4,196,249,22,158,4,80,143,42,39,28,248,22,65,248,22,159,4, +248,22,82,197,250,22,91,2,27,248,22,91,248,22,170,20,199,248,22,103,198, +27,248,22,159,4,248,22,170,20,197,250,22,91,2,27,248,22,91,248,22,82, +197,250,22,92,2,24,248,22,171,20,199,248,22,171,20,202,145,39,9,20,121, +145,2,1,39,16,1,11,16,0,20,27,15,61,9,2,2,2,2,2,3,11, +11,11,11,9,9,11,11,11,10,39,80,143,39,39,20,121,145,2,1,39,16, +0,16,0,41,42,39,16,0,39,16,0,39,11,11,11,16,11,2,4,2,5, +2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,16,11,11, +11,11,11,11,11,11,11,11,11,11,16,11,2,4,2,5,2,6,2,7,2, +8,2,9,2,10,2,11,2,12,2,13,2,14,39,50,40,16,0,39,16,1, +2,15,40,11,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16, +0,16,0,39,39,16,12,16,5,11,20,15,16,2,20,14,144,39,39,40,80, +143,39,39,39,20,121,145,2,1,39,16,1,2,15,16,1,33,36,10,16,5, +2,13,88,148,8,36,40,56,40,9,223,0,33,37,39,20,121,145,2,1,39, +16,1,2,15,16,0,11,16,5,2,14,88,148,8,36,40,56,40,9,223,0, +33,38,39,20,121,145,2,1,39,16,1,2,15,16,0,11,16,5,2,4,88, +148,8,36,40,56,42,9,223,0,33,39,39,20,121,145,2,1,39,16,1,2, +15,16,1,33,40,11,16,5,2,11,88,148,8,36,40,59,42,9,223,0,33, +41,39,20,121,145,2,1,39,16,1,2,15,16,1,33,42,11,16,5,2,7, +88,148,8,36,40,61,40,9,223,0,33,45,39,20,121,145,2,1,39,16,1, +2,15,16,0,11,16,5,2,10,88,148,8,36,40,56,40,9,223,0,33,47, +39,20,121,145,2,1,39,16,1,2,15,16,0,11,16,5,2,8,88,148,8, +36,40,57,40,9,223,0,33,48,39,20,121,145,2,1,39,16,1,2,15,16, +0,11,16,5,2,9,88,148,8,36,40,57,40,9,223,0,33,49,39,20,121, +145,2,1,39,16,1,2,15,16,0,11,16,5,2,12,88,148,8,36,40,59, +40,9,223,0,33,50,39,20,121,145,2,1,39,16,1,2,15,16,0,11,16, +5,2,5,88,148,8,36,40,61,42,9,223,0,33,51,39,20,121,145,2,1, +39,16,1,2,15,16,1,33,52,11,16,5,2,6,88,148,8,36,40,57,40, +9,223,0,33,53,39,20,121,145,2,1,39,16,1,2,15,16,0,11,16,0, +94,2,17,2,18,93,2,17,9,9,39,9,0}; + EVAL_ONE_SIZED_STR((char *)expr, 2091); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,10,54,46,50,46,57,48,48,46,49,53,84,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,0,0,192,0,0,0,1,0,0,8, -0,16,0,29,0,34,0,51,0,63,0,85,0,114,0,158,0,164,0,178,0, -193,0,211,0,223,0,239,0,253,0,19,1,39,1,73,1,90,1,107,1,130, -1,145,1,184,1,202,1,233,1,245,1,6,2,18,2,33,2,57,2,89,2, -118,2,134,2,152,2,172,2,193,2,211,2,242,2,0,3,17,3,61,3,69, -3,74,3,118,3,125,3,135,3,150,3,159,3,164,3,166,3,199,3,223,3, -244,3,1,4,11,4,20,4,31,4,49,4,62,4,72,4,82,4,88,4,93, -4,105,4,108,4,112,4,117,4,160,4,173,4,176,4,200,4,239,4,246,4, -3,5,25,5,36,5,66,5,89,5,97,5,121,5,142,5,86,6,116,6,197, -9,220,9,237,9,161,11,8,12,22,12,226,12,202,14,211,14,220,14,234,14, -244,14,5,16,108,16,221,16,38,17,111,17,215,17,244,17,59,18,197,18,12, -19,225,19,87,20,100,20,218,20,231,20,70,21,137,21,150,21,161,21,57,22, -175,22,219,22,74,23,152,25,176,25,38,26,120,27,127,27,179,27,192,27,182, -28,198,28,53,29,212,29,219,29,96,31,173,31,190,31,90,32,110,32,170,32, -177,32,37,33,91,33,110,33,61,34,77,34,38,35,27,36,64,36,73,36,150, -37,251,39,11,40,78,40,99,40,119,40,139,40,196,40,156,43,122,44,138,44, -109,45,167,45,200,45,76,46,235,46,251,46,92,47,109,47,187,49,238,51,254, -51,228,53,160,54,162,54,189,54,205,54,221,54,62,55,129,56,61,57,77,57, -86,57,93,57,159,58,225,59,87,60,133,63,7,64,139,64,84,66,34,67,76, -67,184,67,0,0,132,75,0,0,3,1,5,105,110,115,112,48,69,35,37,117, -116,105,108,115,74,112,97,116,104,45,115,116,114,105,110,103,63,66,98,115,98, -115,78,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104,73,114,101, -114,111,111,116,45,112,97,116,104,1,20,102,105,110,100,45,101,120,101,99,117, -116,97,98,108,101,45,112,97,116,104,1,27,112,97,116,104,45,108,105,115,116, -45,115,116,114,105,110,103,45,62,112,97,116,104,45,108,105,115,116,1,42,99, -97,108,108,45,119,105,116,104,45,100,101,102,97,117,108,116,45,114,101,97,100, -105,110,103,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,67, -113,117,111,116,101,29,94,2,10,70,35,37,112,97,114,97,109,122,11,76,45, -99,104,101,99,107,45,114,101,108,112,97,116,104,79,45,99,104,101,99,107,45, -99,111,108,108,101,99,116,105,111,110,73,45,99,104,101,99,107,45,102,97,105, -108,77,99,111,108,108,101,99,116,105,111,110,45,112,97,116,104,75,102,105,110, -100,45,99,111,108,45,102,105,108,101,1,20,99,111,108,108,101,99,116,105,111, -110,45,102,105,108,101,45,112,97,116,104,1,18,102,105,110,100,45,109,97,105, -110,45,99,111,108,108,101,99,116,115,1,32,101,120,101,45,114,101,108,97,116, -105,118,101,45,112,97,116,104,45,62,99,111,109,112,108,101,116,101,45,112,97, -116,104,78,102,105,110,100,45,109,97,105,110,45,99,111,110,102,105,103,78,103, -101,116,45,99,111,110,102,105,103,45,116,97,98,108,101,1,21,103,101,116,45, -105,110,115,116,97,108,108,97,116,105,111,110,45,110,97,109,101,76,99,111,101, -114,99,101,45,116,111,45,112,97,116,104,1,37,99,111,108,108,101,99,116,115, -45,114,101,108,97,116,105,118,101,45,112,97,116,104,45,62,99,111,109,112,108, -101,116,101,45,112,97,116,104,79,97,100,100,45,99,111,110,102,105,103,45,115, -101,97,114,99,104,1,29,102,105,110,100,45,108,105,98,114,97,114,121,45,99, -111,108,108,101,99,116,105,111,110,45,108,105,110,107,115,73,108,105,110,107,115, -45,99,97,99,104,101,78,115,116,97,109,112,45,112,114,111,109,112,116,45,116, -97,103,73,102,105,108,101,45,62,115,116,97,109,112,76,110,111,45,102,105,108, -101,45,115,116,97,109,112,63,1,22,103,101,116,45,108,105,110,107,101,100,45, -99,111,108,108,101,99,116,105,111,110,115,1,30,110,111,114,109,97,108,105,122, -101,45,99,111,108,108,101,99,116,105,111,110,45,114,101,102,101,114,101,110,99, -101,1,27,102,105,108,101,45,101,120,105,115,116,115,63,47,109,97,121,98,101, -45,99,111,109,112,105,108,101,100,77,112,97,116,104,45,97,100,100,45,115,117, -102,102,105,120,79,99,104,101,99,107,45,115,117,102,102,105,120,45,99,97,108, -108,1,18,112,97,116,104,45,97,100,106,117,115,116,45,115,117,102,102,105,120, -1,19,112,97,116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120, -79,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,1,29,102, -105,110,100,45,108,105,98,114,97,114,121,45,99,111,108,108,101,99,116,105,111, -110,45,112,97,116,104,115,75,101,109,98,101,100,100,101,100,45,108,111,97,100, -78,110,111,114,109,97,108,45,112,97,116,104,45,99,97,115,101,6,41,41,40, -111,114,47,99,32,112,97,116,104,45,102,111,114,45,115,111,109,101,45,115,121, -115,116,101,109,63,32,112,97,116,104,45,115,116,114,105,110,103,63,41,69,119, -105,110,100,111,119,115,6,2,2,92,49,6,41,41,40,111,114,47,99,32,112, -97,116,104,45,115,116,114,105,110,103,63,32,112,97,116,104,45,102,111,114,45, -115,111,109,101,45,115,121,115,116,101,109,63,41,6,4,4,112,97,116,104,5, -8,92,92,63,92,82,69,76,92,6,12,12,112,97,116,104,45,115,116,114,105, -110,103,63,70,114,101,108,97,116,105,118,101,66,108,111,111,112,5,0,6,30, -30,40,112,114,111,99,101,100,117,114,101,45,97,114,105,116,121,45,105,110,99, -108,117,100,101,115,47,99,32,48,41,6,21,21,105,110,118,97,108,105,100,32, -114,101,108,97,116,105,118,101,32,112,97,116,104,6,18,18,40,97,110,121,47, -99,32,46,32,45,62,32,46,32,97,110,121,41,74,99,111,108,108,101,99,116, -115,45,100,105,114,71,101,120,101,99,45,102,105,108,101,70,111,114,105,103,45, -100,105,114,72,99,111,110,102,105,103,45,100,105,114,79,105,110,115,116,97,108, -108,97,116,105,111,110,45,110,97,109,101,6,10,10,108,105,110,107,115,46,114, -107,116,100,71,97,100,100,111,110,45,100,105,114,71,102,115,45,99,104,97,110, -103,101,67,101,114,114,111,114,66,114,111,111,116,73,115,116,97,116,105,99,45, -114,111,111,116,6,0,0,6,1,1,47,5,3,46,122,111,6,40,40,114,101, -109,111,118,105,110,103,32,115,117,102,102,105,120,32,109,97,107,101,115,32,112, -97,116,104,32,101,108,101,109,101,110,116,32,101,109,112,116,121,6,10,10,103, -105,118,101,110,32,112,97,116,104,5,1,95,6,21,21,40,111,114,47,99,32, -115,116,114,105,110,103,63,32,98,121,116,101,115,63,41,6,36,36,99,97,110, -110,111,116,32,97,100,100,32,97,32,115,117,102,102,105,120,32,116,111,32,97, -32,114,111,111,116,32,112,97,116,104,58,32,68,102,105,110,105,115,104,5,11, -80,76,84,67,79,76,76,69,67,84,83,1,20,99,111,108,108,101,99,116,115, -45,115,101,97,114,99,104,45,100,105,114,115,6,8,8,99,111,108,108,101,99, -116,115,27,248,22,175,15,194,28,192,192,28,248,22,153,7,194,27,248,22,134, -16,195,28,192,192,248,22,135,16,195,11,0,21,35,114,120,34,94,91,92,92, -93,91,92,92,93,91,63,93,91,92,92,93,34,0,6,35,114,120,34,47,34, -0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47,92,92,93, -42,36,34,0,19,35,114,120,34,91,32,46,93,43,40,91,47,92,92,93,42, -41,36,34,86,94,28,28,248,22,176,15,23,195,2,10,28,248,22,175,15,23, -195,2,10,28,248,22,153,7,23,195,2,28,248,22,134,16,23,195,2,10,248, -22,135,16,23,195,2,11,12,250,22,182,11,2,41,2,42,23,197,2,28,28, -248,22,176,15,23,195,2,249,22,169,9,248,22,177,15,23,197,2,2,43,249, -22,169,9,247,22,180,8,2,43,27,28,248,22,153,7,23,196,2,23,195,2, -248,22,165,8,248,22,180,15,23,197,2,28,249,22,172,16,2,79,23,195,2, -28,248,22,153,7,195,248,22,183,15,195,194,27,248,22,128,8,23,195,1,249, -22,184,15,248,22,168,8,250,22,180,16,2,80,28,249,22,172,16,2,81,23, -201,2,23,199,1,250,22,180,16,2,82,23,202,1,2,44,80,144,47,40,41, -2,43,28,248,22,153,7,194,248,22,183,15,194,193,0,28,35,114,120,34,94, -92,92,92,92,92,92,92,92,91,63,93,92,92,92,92,85,78,67,92,92,92, -92,34,86,95,28,28,28,248,22,175,15,23,195,2,10,28,248,22,153,7,23, -195,2,28,248,22,134,16,23,195,2,10,248,22,135,16,23,195,2,11,10,248, -22,176,15,23,195,2,12,252,22,182,11,2,6,2,45,39,23,199,2,23,200, -2,28,28,28,248,22,175,15,23,196,2,10,28,248,22,153,7,23,196,2,28, -248,22,134,16,23,196,2,10,248,22,135,16,23,196,2,11,10,248,22,176,15, -23,196,2,12,252,22,182,11,2,6,2,45,40,23,199,2,23,200,2,27,28, -248,22,176,15,23,196,2,248,22,177,15,23,196,2,247,22,178,15,86,95,28, -28,248,22,136,16,23,196,2,10,249,22,169,9,247,22,178,15,23,195,2,12, -253,22,184,11,2,6,6,54,54,112,97,116,104,32,105,115,32,110,111,116,32, -99,111,109,112,108,101,116,101,32,97,110,100,32,110,111,116,32,116,104,101,32, -112,108,97,116,102,111,114,109,39,115,32,99,111,110,118,101,110,116,105,111,110, -2,46,23,201,2,6,24,24,112,108,97,116,102,111,114,109,32,99,111,110,118, -101,110,116,105,111,110,32,116,121,112,101,247,22,178,15,28,249,22,169,9,28, -248,22,176,15,23,199,2,248,22,177,15,23,199,2,247,22,178,15,23,195,2, -12,253,22,184,11,2,6,6,37,37,103,105,118,101,110,32,112,97,116,104,115, -32,117,115,101,32,100,105,102,102,101,114,101,110,116,32,99,111,110,118,101,110, -116,105,111,110,115,2,46,23,201,2,6,9,9,114,111,111,116,32,112,97,116, -104,23,202,2,27,27,248,22,140,16,28,248,22,136,16,23,199,2,23,198,1, -248,22,137,16,23,199,1,86,94,28,28,248,22,176,15,23,194,2,10,28,248, -22,175,15,23,194,2,10,28,248,22,153,7,23,194,2,28,248,22,134,16,23, -194,2,10,248,22,135,16,23,194,2,11,12,250,22,182,11,2,41,2,42,23, -196,2,28,28,248,22,176,15,23,194,2,249,22,169,9,248,22,177,15,23,196, -2,2,43,249,22,169,9,247,22,180,8,2,43,27,28,248,22,153,7,23,195, -2,23,194,2,248,22,165,8,248,22,180,15,23,196,2,28,249,22,172,16,2, -79,23,195,2,28,248,22,153,7,194,248,22,183,15,194,193,27,248,22,128,8, -23,195,1,249,22,184,15,248,22,168,8,250,22,180,16,2,80,28,249,22,172, -16,2,81,23,201,2,23,199,1,250,22,180,16,2,82,23,202,1,2,44,80, -144,50,40,41,2,43,28,248,22,153,7,193,248,22,183,15,193,192,27,248,22, -180,15,23,195,2,28,249,22,169,9,23,197,2,66,117,110,105,120,28,249,22, -150,8,194,5,1,47,28,248,22,176,15,198,197,248,22,183,15,198,249,22,129, -16,199,249,22,184,15,249,22,153,8,248,22,180,15,200,40,198,28,249,22,169, -9,23,197,2,2,43,249,22,129,16,23,200,1,249,22,184,15,28,249,22,172, -16,0,27,35,114,120,34,94,92,92,92,92,92,92,92,92,91,63,93,92,92, -92,92,91,97,45,122,93,58,34,23,199,2,251,22,154,8,2,47,250,22,153, -8,203,43,44,5,1,92,249,22,153,8,202,45,28,249,22,172,16,2,84,23, -199,2,249,22,154,8,2,47,249,22,153,8,200,43,28,249,22,172,16,2,84, -23,199,2,249,22,154,8,2,47,249,22,153,8,200,43,28,249,22,172,16,0, -14,35,114,120,34,94,92,92,92,92,92,92,92,92,34,23,199,2,249,22,154, -8,5,4,85,78,67,92,249,22,153,8,200,41,28,249,22,172,16,0,12,35, -114,120,34,94,91,97,45,122,93,58,34,198,249,22,154,8,250,22,153,8,201, -39,40,249,22,153,8,200,41,12,198,12,32,86,88,148,8,36,42,56,11,72, -102,111,117,110,100,45,101,120,101,99,222,33,89,32,87,88,148,8,36,43,61, -11,66,110,101,120,116,222,33,88,27,248,22,138,16,23,196,2,28,249,22,171, -9,23,195,2,23,197,1,11,28,248,22,134,16,23,194,2,27,249,22,129,16, -23,197,1,23,196,1,28,23,197,2,90,144,42,11,89,146,42,39,11,248,22, -132,16,23,197,2,86,95,23,195,1,23,194,1,27,28,23,202,2,27,248,22, -138,16,23,199,2,28,249,22,171,9,23,195,2,23,200,2,11,28,248,22,134, -16,23,194,2,250,2,86,23,205,2,23,206,2,249,22,129,16,23,200,2,23, -198,1,250,2,86,23,205,2,23,206,2,23,196,1,11,28,23,193,2,192,86, -94,23,193,1,27,28,248,22,175,15,23,196,2,27,249,22,129,16,23,198,2, -23,205,2,28,28,248,22,188,15,193,10,248,22,187,15,193,192,11,11,28,23, -193,2,192,86,94,23,193,1,28,23,203,2,11,27,248,22,138,16,23,200,2, -28,249,22,171,9,194,23,201,1,11,28,248,22,134,16,193,250,2,86,205,206, -249,22,129,16,200,197,250,2,86,205,206,195,192,86,94,23,194,1,28,23,196, -2,90,144,42,11,89,146,42,39,11,248,22,132,16,23,197,2,86,95,23,195, -1,23,194,1,27,28,23,201,2,27,248,22,138,16,23,199,2,28,249,22,171, -9,23,195,2,23,200,2,11,28,248,22,134,16,23,194,2,250,2,86,23,204, -2,23,205,2,249,22,129,16,23,200,2,23,198,1,250,2,86,23,204,2,23, -205,2,23,196,1,11,28,23,193,2,192,86,94,23,193,1,27,28,248,22,175, -15,23,196,2,27,249,22,129,16,23,198,2,23,204,2,28,28,248,22,188,15, -193,10,248,22,187,15,193,192,11,11,28,23,193,2,192,86,94,23,193,1,28, -23,202,2,11,27,248,22,138,16,23,200,2,28,249,22,171,9,194,23,201,1, -11,28,248,22,134,16,193,250,2,86,204,205,249,22,129,16,200,197,250,2,86, -204,205,195,192,28,23,193,2,90,144,42,11,89,146,42,39,11,248,22,132,16, -23,199,2,86,95,23,195,1,23,194,1,27,28,23,198,2,251,2,87,23,198, -2,23,203,2,23,201,2,23,202,2,11,28,23,193,2,192,86,94,23,193,1, -27,28,248,22,175,15,195,27,249,22,129,16,197,200,28,28,248,22,188,15,193, -10,248,22,187,15,193,192,11,11,28,192,192,28,198,11,251,2,87,198,203,201, -202,194,32,90,88,148,8,36,43,60,11,2,50,222,33,91,28,248,22,88,23, -197,2,11,27,249,22,129,16,248,22,137,16,248,22,81,23,201,2,23,196,2, -28,248,22,187,15,23,194,2,250,2,86,197,198,195,86,94,23,193,1,27,248, -22,165,20,23,199,1,28,248,22,88,23,194,2,11,27,249,22,129,16,248,22, -137,16,248,22,81,23,198,2,23,198,2,28,248,22,187,15,23,194,2,250,2, -86,199,200,195,86,94,23,193,1,27,248,22,165,20,23,196,1,28,248,22,88, -23,194,2,11,27,249,22,129,16,248,22,137,16,248,22,81,23,198,2,23,200, -2,28,248,22,187,15,23,194,2,250,2,86,201,202,195,86,94,23,193,1,27, -248,22,165,20,23,196,1,28,248,22,88,23,194,2,11,27,249,22,129,16,248, -22,137,16,248,22,81,197,201,28,248,22,187,15,193,250,2,86,203,204,195,251, -2,90,203,204,205,248,22,165,20,198,86,95,28,28,248,22,175,15,23,195,2, -10,28,248,22,153,7,23,195,2,28,248,22,134,16,23,195,2,10,248,22,135, -16,23,195,2,11,12,250,22,182,11,2,7,2,48,23,197,2,28,28,23,195, -2,28,28,248,22,175,15,23,196,2,10,28,248,22,153,7,23,196,2,28,248, -22,134,16,23,196,2,10,248,22,135,16,23,196,2,11,248,22,134,16,23,196, -2,11,10,12,250,22,182,11,2,7,6,45,45,40,111,114,47,99,32,35,102, -32,40,97,110,100,47,99,32,112,97,116,104,45,115,116,114,105,110,103,63,32, -114,101,108,97,116,105,118,101,45,112,97,116,104,63,41,41,23,198,2,28,28, -248,22,134,16,23,195,2,90,144,42,11,89,146,42,39,11,248,22,132,16,23, -198,2,249,22,169,9,194,2,49,11,27,249,22,175,8,247,22,174,8,5,4, -80,65,84,72,27,28,23,194,2,249,80,143,43,44,249,22,165,8,23,198,1, -7,63,9,86,94,23,194,1,9,27,28,249,22,169,9,247,22,180,8,2,43, -249,22,80,248,22,184,15,5,1,46,23,196,1,23,194,1,28,248,22,88,23, -194,2,11,27,249,22,129,16,248,22,137,16,248,22,81,23,198,2,23,200,2, -28,248,22,187,15,23,194,2,250,2,86,201,202,195,86,94,23,193,1,27,248, -22,165,20,23,196,1,28,248,22,88,23,194,2,11,27,249,22,129,16,248,22, -137,16,248,22,81,23,198,2,23,202,2,28,248,22,187,15,23,194,2,250,2, -86,203,204,195,86,94,23,193,1,27,248,22,165,20,23,196,1,28,248,22,88, -23,194,2,11,27,249,22,129,16,248,22,137,16,248,22,81,23,198,2,23,204, -2,28,248,22,187,15,23,194,2,250,2,86,205,206,195,86,94,23,193,1,27, -248,22,165,20,23,196,1,28,248,22,88,23,194,2,11,27,249,22,129,16,248, -22,137,16,248,22,81,197,205,28,248,22,187,15,193,250,2,86,23,15,23,16, -195,251,2,90,23,15,23,16,23,17,248,22,165,20,198,27,248,22,137,16,23, -196,1,28,248,22,187,15,193,250,2,86,198,199,195,11,250,80,144,42,43,42, -196,197,11,250,80,144,42,43,42,196,11,11,32,95,88,148,8,36,42,58,11, -2,50,222,33,97,0,8,35,114,120,35,34,92,34,34,27,249,22,168,16,23, -197,2,23,198,2,28,23,193,2,86,94,23,196,1,27,248,22,102,23,195,2, -27,27,248,22,111,23,197,1,27,249,22,168,16,23,201,2,23,196,2,28,23, -193,2,86,94,23,194,1,27,248,22,102,23,195,2,27,250,2,95,202,23,204, -1,248,22,111,23,199,1,27,28,249,22,169,9,247,22,180,8,2,43,250,22, -180,16,2,96,23,198,1,2,51,194,28,249,22,150,8,194,2,51,249,22,94, -202,195,249,22,80,248,22,184,15,195,195,86,95,23,199,1,23,193,1,27,28, -249,22,169,9,247,22,180,8,2,43,250,22,180,16,2,96,23,198,1,2,51, -194,28,249,22,150,8,194,2,51,249,22,94,200,9,249,22,80,248,22,184,15, -195,9,27,28,249,22,169,9,247,22,180,8,2,43,250,22,180,16,2,96,23, -198,1,2,51,194,28,249,22,150,8,194,2,51,249,22,94,198,195,249,22,80, -248,22,184,15,195,195,86,94,23,193,1,27,28,249,22,169,9,247,22,180,8, -2,43,250,22,180,16,2,96,23,200,1,2,51,196,28,249,22,150,8,194,2, -51,249,22,94,196,9,249,22,80,248,22,184,15,195,9,86,95,28,28,248,22, -142,8,194,10,248,22,153,7,194,12,250,22,182,11,2,8,6,21,21,40,111, -114,47,99,32,98,121,116,101,115,63,32,115,116,114,105,110,103,63,41,196,28, -28,248,22,89,195,249,22,4,22,175,15,196,11,12,250,22,182,11,2,8,6, -14,14,40,108,105,115,116,111,102,32,112,97,116,104,63,41,197,250,2,95,197, -195,28,248,22,153,7,197,248,22,167,8,197,196,28,28,248,22,0,23,195,2, -249,22,48,23,196,2,39,11,20,13,144,80,144,39,46,40,26,29,80,144,8, -29,47,40,249,22,31,11,80,144,8,31,46,40,22,145,15,10,22,146,15,10, -22,147,15,10,22,150,15,10,22,149,15,11,22,151,15,10,22,148,15,10,22, -152,15,10,22,153,15,10,22,154,15,10,22,155,15,10,22,156,15,11,22,157, -15,10,22,143,15,11,247,23,194,1,250,22,182,11,2,9,2,52,23,197,1, -86,94,28,28,248,22,175,15,23,195,2,10,28,248,22,153,7,23,195,2,28, -248,22,134,16,23,195,2,10,248,22,135,16,23,195,2,11,12,250,22,182,11, -23,196,2,2,48,23,197,2,28,248,22,134,16,23,195,2,12,251,22,184,11, -23,197,1,2,53,2,46,23,198,1,86,94,28,28,248,22,175,15,23,195,2, -10,28,248,22,153,7,23,195,2,28,248,22,134,16,23,195,2,10,248,22,135, -16,23,195,2,11,12,250,22,182,11,23,196,2,2,48,23,197,2,28,248,22, -134,16,23,195,2,12,251,22,184,11,23,197,1,2,53,2,46,23,198,1,86, -94,86,94,28,28,248,22,175,15,23,195,2,10,28,248,22,153,7,23,195,2, -28,248,22,134,16,23,195,2,10,248,22,135,16,23,195,2,11,12,250,22,182, -11,23,196,2,2,48,23,197,2,28,248,22,134,16,23,195,2,86,94,23,194, -1,12,251,22,184,11,23,197,2,2,53,2,46,23,198,1,249,22,3,20,20, -94,88,148,8,36,40,50,11,9,223,2,33,101,23,195,1,23,197,1,28,28, -248,22,0,23,195,2,249,22,48,23,196,2,40,11,12,250,22,182,11,23,196, -1,2,54,23,197,1,86,94,28,28,248,22,175,15,23,194,2,10,28,248,22, -153,7,23,194,2,28,248,22,134,16,23,194,2,10,248,22,135,16,23,194,2, -11,12,250,22,182,11,2,15,2,48,23,196,2,28,248,22,134,16,23,194,2, -12,251,22,184,11,2,15,2,53,2,46,23,197,1,86,95,86,94,86,94,28, -28,248,22,175,15,23,196,2,10,28,248,22,153,7,23,196,2,28,248,22,134, -16,23,196,2,10,248,22,135,16,23,196,2,11,12,250,22,182,11,2,15,2, -48,23,198,2,28,248,22,134,16,23,196,2,12,251,22,184,11,2,15,2,53, -2,46,23,199,2,249,22,3,32,0,88,148,8,36,40,49,11,9,222,33,104, -23,198,2,28,28,248,22,0,23,195,2,249,22,48,23,196,2,40,11,12,250, -22,182,11,2,15,2,54,23,197,2,252,80,143,44,52,23,199,1,23,200,1, -23,201,1,11,11,86,94,28,28,248,22,175,15,23,194,2,10,28,248,22,153, -7,23,194,2,28,248,22,134,16,23,194,2,10,248,22,135,16,23,194,2,11, -12,250,22,182,11,2,17,2,48,23,196,2,28,248,22,134,16,23,194,2,12, -251,22,184,11,2,17,2,53,2,46,23,197,1,86,96,86,94,28,28,248,22, -175,15,23,197,2,10,28,248,22,153,7,23,197,2,28,248,22,134,16,23,197, -2,10,248,22,135,16,23,197,2,11,12,250,22,182,11,2,17,2,48,23,199, -2,28,248,22,134,16,23,197,2,12,251,22,184,11,2,17,2,53,2,46,23, -200,2,86,94,86,94,28,28,248,22,175,15,23,198,2,10,28,248,22,153,7, -23,198,2,28,248,22,134,16,23,198,2,10,248,22,135,16,23,198,2,11,12, -250,22,182,11,2,17,2,48,23,200,2,28,248,22,134,16,23,198,2,12,251, -22,184,11,2,17,2,53,2,46,23,201,2,249,22,3,32,0,88,148,8,36, -40,49,11,9,222,33,106,23,200,2,28,28,248,22,0,23,195,2,249,22,48, -23,196,2,40,11,12,250,22,182,11,2,17,2,54,23,197,2,252,80,143,44, -52,23,199,1,23,202,1,23,203,1,23,201,1,23,200,1,27,248,22,152,16, -2,55,28,248,22,136,16,23,194,2,248,22,139,16,23,194,1,28,248,22,135, -16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,132,16,249,22,137,16, -250,80,144,49,43,42,248,22,152,16,2,56,11,11,248,22,152,16,2,57,86, -95,23,195,1,23,194,1,248,22,139,16,249,22,137,16,23,199,1,23,196,1, -27,250,80,144,44,43,42,248,22,152,16,2,56,23,197,1,10,28,23,193,2, -248,22,139,16,23,194,1,11,249,80,144,41,55,40,39,80,144,41,8,40,42, -27,248,22,152,16,2,58,28,248,22,136,16,23,194,2,248,22,139,16,23,194, -1,28,248,22,135,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,132, -16,249,22,137,16,250,80,144,49,43,42,248,22,152,16,2,56,11,11,248,22, -152,16,2,57,86,95,23,195,1,23,194,1,248,22,139,16,249,22,137,16,23, -199,1,23,196,1,27,250,80,144,44,43,42,248,22,152,16,2,56,23,197,1, -10,28,23,193,2,248,22,139,16,23,194,1,11,249,80,144,41,55,40,40,80, -144,41,8,41,42,27,20,13,144,80,144,40,46,40,26,29,80,144,8,30,47, -40,249,22,31,11,80,144,8,32,46,40,22,145,15,10,22,146,15,10,22,147, -15,10,22,150,15,10,22,149,15,11,22,151,15,10,22,148,15,10,22,152,15, -10,22,153,15,10,22,154,15,10,22,155,15,10,22,156,15,11,22,157,15,10, -22,143,15,11,247,22,148,6,28,248,22,149,2,193,192,11,27,28,23,195,2, -249,22,129,16,23,197,1,6,11,11,99,111,110,102,105,103,46,114,107,116,100, -86,94,23,195,1,11,27,28,23,194,2,28,248,22,187,15,23,195,2,249,22, -140,6,23,196,1,80,144,43,8,42,42,11,11,28,192,192,21,17,1,0,250, -22,158,2,23,196,1,2,59,247,22,171,8,250,22,158,2,195,2,59,247,22, -171,8,28,248,22,153,7,23,195,2,27,248,22,183,15,23,196,1,28,248,22, -136,16,23,194,2,192,249,22,137,16,23,195,1,27,247,80,144,43,54,42,28, -23,193,2,192,86,94,23,193,1,247,22,153,16,28,248,22,142,8,23,195,2, -27,248,22,184,15,23,196,1,28,248,22,136,16,23,194,2,192,249,22,137,16, -23,195,1,27,247,80,144,43,54,42,28,23,193,2,192,86,94,23,193,1,247, -22,153,16,28,248,22,175,15,23,195,2,28,248,22,136,16,23,195,2,193,249, -22,137,16,23,196,1,27,247,80,144,42,54,42,28,23,193,2,192,86,94,23, -193,1,247,22,153,16,193,27,248,22,152,16,2,55,28,248,22,136,16,23,194, -2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2,90,144,42,11,89, -146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,49,43,42,248,22,152, -16,2,56,11,11,248,22,152,16,2,57,86,95,23,195,1,23,194,1,248,22, -139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144,44,43,42,248,22, -152,16,2,56,23,197,1,10,28,23,193,2,248,22,139,16,23,194,1,11,28, -248,22,136,16,23,195,2,193,249,22,137,16,23,196,1,27,249,80,144,44,55, -40,39,80,144,44,8,43,42,28,23,193,2,192,86,94,23,193,1,247,22,153, -16,28,248,22,136,16,23,195,2,248,22,139,16,23,195,1,28,248,22,135,16, -23,195,2,90,144,42,11,89,146,42,39,11,248,22,132,16,249,22,137,16,250, -80,144,48,43,42,248,22,152,16,2,56,11,11,248,22,152,16,2,57,86,95, -23,195,1,23,194,1,248,22,139,16,249,22,137,16,23,200,1,23,196,1,27, -250,80,144,43,43,42,248,22,152,16,2,56,23,198,1,10,28,23,193,2,248, -22,139,16,23,194,1,11,28,248,22,88,23,196,2,9,28,248,22,81,23,196, -2,249,22,80,27,248,22,164,20,23,199,2,28,248,22,153,7,23,194,2,27, -248,22,183,15,23,195,1,28,248,22,136,16,23,194,2,192,249,22,137,16,23, -195,1,27,247,80,144,46,54,42,28,23,193,2,192,86,94,23,193,1,247,22, -153,16,28,248,22,142,8,23,194,2,27,248,22,184,15,23,195,1,28,248,22, -136,16,23,194,2,192,249,22,137,16,23,195,1,27,247,80,144,46,54,42,28, -23,193,2,192,86,94,23,193,1,247,22,153,16,28,248,22,175,15,23,194,2, -28,248,22,136,16,23,194,2,192,249,22,137,16,23,195,1,27,247,80,144,45, -54,42,28,23,193,2,192,86,94,23,193,1,247,22,153,16,192,27,248,22,165, -20,23,199,1,28,248,22,88,23,194,2,9,28,248,22,81,23,194,2,249,22, -80,248,80,144,45,60,42,248,22,164,20,23,197,2,27,248,22,165,20,23,197, -1,28,248,22,88,23,194,2,9,28,248,22,81,23,194,2,249,22,80,248,80, -144,48,60,42,248,22,164,20,23,197,2,249,80,144,49,8,44,42,23,204,1, -248,22,165,20,23,198,1,249,22,94,23,202,2,249,80,144,49,8,44,42,23, -204,1,248,22,165,20,23,198,1,249,22,94,23,199,2,27,248,22,165,20,23, -197,1,28,248,22,88,23,194,2,9,28,248,22,81,23,194,2,249,22,80,248, -80,144,48,60,42,248,22,164,20,23,197,2,249,80,144,49,8,44,42,23,204, -1,248,22,165,20,23,198,1,249,22,94,23,202,2,249,80,144,49,8,44,42, -23,204,1,248,22,165,20,23,198,1,249,22,94,23,196,2,27,248,22,165,20, -23,199,1,28,248,22,88,23,194,2,9,28,248,22,81,23,194,2,249,22,80, -248,80,144,45,60,42,248,22,164,20,23,197,2,27,248,22,165,20,23,197,1, -28,248,22,88,23,194,2,9,28,248,22,81,23,194,2,249,22,80,248,80,144, -48,60,42,248,22,164,20,23,197,2,249,80,144,49,8,44,42,23,204,1,248, -22,165,20,23,198,1,249,22,94,23,202,2,249,80,144,49,8,44,42,23,204, -1,248,22,165,20,23,198,1,249,22,94,23,199,2,27,248,22,165,20,23,197, -1,28,248,22,88,23,194,2,9,28,248,22,81,23,194,2,249,22,80,248,80, -144,48,60,42,248,22,164,20,23,197,2,249,80,144,49,8,44,42,23,204,1, -248,22,165,20,23,198,1,249,22,94,23,202,2,249,80,144,49,8,44,42,23, -204,1,248,22,165,20,23,198,1,27,250,22,158,2,23,198,1,23,199,1,11, -28,192,249,80,144,42,8,44,42,198,194,196,27,248,22,152,16,2,58,28,248, -22,136,16,23,194,2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2, -90,144,42,11,89,146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,49, -43,42,248,22,152,16,2,56,11,11,248,22,152,16,2,57,86,95,23,195,1, -23,194,1,248,22,139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144, -44,43,42,248,22,152,16,2,56,23,197,1,10,28,23,193,2,248,22,139,16, -23,194,1,11,27,248,80,144,41,58,42,249,80,144,43,55,40,40,80,144,43, -8,45,42,27,27,250,22,158,2,23,198,2,72,108,105,110,107,115,45,102,105, -108,101,11,27,28,23,194,2,23,194,1,86,94,23,194,1,249,22,129,16,27, -250,22,158,2,23,202,2,71,115,104,97,114,101,45,100,105,114,11,28,192,192, -249,22,129,16,64,117,112,6,5,5,115,104,97,114,101,2,60,28,248,22,153, -7,23,194,2,27,248,22,183,15,23,195,1,28,248,22,136,16,23,194,2,192, -249,22,137,16,23,195,1,27,247,80,144,47,54,42,28,23,193,2,192,86,94, -23,193,1,247,22,153,16,28,248,22,142,8,23,194,2,27,248,22,184,15,23, -195,1,28,248,22,136,16,23,194,2,192,249,22,137,16,23,195,1,27,247,80, -144,47,54,42,28,23,193,2,192,86,94,23,193,1,247,22,153,16,28,248,22, -175,15,23,194,2,28,248,22,136,16,23,194,2,192,249,22,137,16,23,195,1, -27,247,80,144,46,54,42,28,23,193,2,192,86,94,23,193,1,247,22,153,16, -192,250,22,94,248,22,90,11,28,247,22,160,16,28,247,22,161,16,248,22,90, -250,22,129,16,248,22,152,16,2,61,250,22,158,2,23,204,2,2,59,247,22, -171,8,2,60,9,9,28,247,22,161,16,250,80,144,47,8,23,42,23,200,1, -1,18,108,105,110,107,115,45,115,101,97,114,99,104,45,102,105,108,101,115,248, -22,90,23,200,1,9,248,22,174,13,23,194,1,249,22,14,80,144,41,8,26, -41,28,248,22,130,13,23,197,2,86,94,23,196,1,32,0,88,148,8,36,39, -44,11,9,222,11,20,20,94,88,148,8,36,39,46,11,9,223,3,33,124,23, -196,1,32,126,88,148,39,40,59,11,2,50,222,33,127,90,144,42,11,89,146, -42,39,11,248,22,132,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22, -175,15,23,194,2,28,248,22,188,15,23,194,2,249,22,145,6,23,195,1,32, -0,88,148,8,36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248, -22,132,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22,175,15,23,194, -2,28,248,22,188,15,23,194,2,249,22,145,6,23,195,1,32,0,88,148,8, -36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248,22,132,16,23, -197,1,86,95,23,195,1,23,194,1,28,248,22,175,15,23,194,2,28,248,22, -188,15,23,194,2,249,22,145,6,23,195,1,32,0,88,148,8,36,39,44,11, -9,222,11,90,144,42,11,89,146,42,39,11,248,22,132,16,23,197,1,86,95, -23,195,1,23,194,1,28,248,22,175,15,23,194,2,28,248,22,188,15,23,194, -2,249,22,145,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,248, -2,126,23,194,1,11,11,11,11,32,128,2,88,148,8,36,40,58,11,2,50, -222,33,129,2,27,249,22,163,6,8,128,128,23,196,2,28,248,22,148,7,23, -194,2,9,249,22,80,23,195,1,27,249,22,163,6,8,128,128,23,199,2,28, -248,22,148,7,23,194,2,9,249,22,80,23,195,1,27,249,22,163,6,8,128, -128,23,202,2,28,248,22,148,7,23,194,2,9,249,22,80,23,195,1,27,249, -22,163,6,8,128,128,23,205,2,28,248,22,148,7,23,194,2,9,249,22,80, -23,195,1,248,2,128,2,23,206,1,27,249,22,163,6,8,128,128,23,196,2, -28,248,22,142,8,23,194,2,28,249,22,132,4,248,22,147,8,23,196,2,8, -128,128,249,22,1,22,154,8,249,22,80,23,197,1,27,249,22,163,6,8,128, -128,23,201,2,28,248,22,148,7,23,194,2,9,249,22,80,23,195,1,27,249, -22,163,6,8,128,128,23,204,2,28,248,22,148,7,23,194,2,9,249,22,80, -23,195,1,27,249,22,163,6,8,128,128,23,207,2,28,248,22,148,7,23,194, -2,9,249,22,80,23,195,1,27,249,22,163,6,8,128,128,23,210,2,28,248, -22,148,7,23,194,2,9,249,22,80,23,195,1,248,2,128,2,23,211,1,192, -192,248,22,133,6,23,194,1,20,13,144,80,144,40,8,28,40,80,144,40,8, -46,42,27,28,249,22,189,8,248,22,180,8,2,62,41,90,144,42,11,89,146, -42,39,11,248,22,132,16,23,198,2,86,95,23,195,1,23,194,1,28,248,22, -175,15,23,194,2,28,248,22,188,15,23,194,2,249,22,145,6,23,195,1,32, -0,88,148,8,36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248, -22,132,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22,175,15,23,194, -2,28,248,22,188,15,23,194,2,249,22,145,6,23,195,1,32,0,88,148,8, -36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248,22,132,16,23, -197,1,86,95,23,195,1,23,194,1,28,248,22,175,15,23,194,2,28,248,22, -188,15,23,194,2,249,22,145,6,23,195,1,32,0,88,148,8,36,39,44,11, -9,222,11,90,144,42,11,89,146,42,39,11,248,22,132,16,23,197,1,86,95, -23,195,1,23,194,1,28,248,22,175,15,23,194,2,28,248,22,188,15,23,194, -2,249,22,145,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,248, -2,126,23,194,1,11,11,11,11,11,28,248,22,187,15,23,195,2,27,28,249, -22,189,8,248,22,180,8,2,62,41,249,22,145,6,23,197,2,32,0,88,148, -8,36,39,44,11,9,222,11,11,86,94,28,23,194,2,248,22,147,6,23,195, -1,86,94,23,194,1,12,249,22,80,27,248,22,188,5,23,199,1,250,22,44, -22,35,88,148,39,39,8,24,11,9,223,3,33,130,2,20,20,94,88,148,8, -36,39,46,11,9,223,3,33,131,2,23,196,1,194,249,22,80,11,194,28,28, -23,195,2,28,248,22,82,23,196,2,248,22,167,9,249,22,176,14,39,248,22, -165,20,23,199,2,11,11,194,86,94,23,195,1,249,22,12,20,20,94,88,148, -8,32,39,61,16,4,39,8,128,80,8,240,0,64,0,0,39,9,224,2,3, -33,132,2,23,196,1,80,144,41,8,26,41,27,248,22,167,9,194,28,192,192, -248,22,167,9,248,22,81,195,86,95,28,248,22,151,12,23,198,2,27,247,22, -143,12,28,249,22,133,12,23,195,2,2,63,251,22,139,12,23,197,1,2,63, -250,22,137,8,6,42,42,101,114,114,111,114,32,114,101,97,100,105,110,103,32, -99,111,108,108,101,99,116,105,111,110,32,108,105,110,107,115,32,102,105,108,101, -32,126,115,58,32,126,97,23,203,2,248,22,147,12,23,206,2,247,22,27,12, -12,28,23,193,2,250,22,156,2,80,144,45,8,25,41,23,198,1,249,22,80, -23,198,1,21,17,0,0,86,95,23,195,1,23,193,1,12,28,248,22,151,12, -23,198,2,86,94,23,197,1,248,23,195,1,247,22,138,2,196,88,148,39,40, -58,8,240,0,0,0,2,9,226,0,2,1,3,33,135,2,20,20,94,248,22, -148,6,23,194,2,28,248,22,148,7,248,22,148,6,23,195,1,12,248,22,178, -11,6,30,30,101,120,112,101,99,116,101,100,32,97,32,115,105,110,103,108,101, -32,83,45,101,120,112,114,101,115,115,105,111,110,248,22,133,6,23,194,1,28, -248,22,89,193,28,28,249,22,128,4,41,248,22,93,195,10,249,22,128,4,42, -248,22,93,195,28,28,248,22,153,7,248,22,81,194,10,28,249,22,169,9,2, -64,248,22,164,20,195,10,249,22,169,9,2,65,248,22,164,20,195,28,27,248, -22,102,194,28,248,22,175,15,193,10,28,248,22,153,7,193,28,248,22,134,16, -193,10,248,22,135,16,193,11,27,248,22,88,248,22,104,195,28,192,192,248,22, -181,16,248,22,111,195,11,11,11,11,28,248,22,188,15,249,22,129,16,23,196, -2,23,198,2,27,248,22,68,248,22,179,15,23,198,1,250,22,156,2,23,198, -2,23,196,2,249,22,80,23,199,1,250,22,158,2,23,203,1,23,201,1,9, -12,250,22,156,2,23,197,1,23,198,1,249,22,80,23,198,1,23,201,1,28, -28,248,22,88,248,22,104,23,197,2,10,249,22,172,16,248,22,111,23,198,2, -247,22,171,8,27,248,22,139,16,249,22,137,16,248,22,102,23,200,2,23,198, -1,28,249,22,169,9,248,22,164,20,23,199,2,2,65,86,94,23,196,1,249, -22,3,20,20,94,88,148,8,36,40,56,11,9,224,3,2,33,140,2,23,196, -1,248,22,142,16,23,196,1,28,249,22,169,9,248,22,164,20,23,199,2,2, -64,86,94,23,196,1,86,94,28,250,22,158,2,23,197,2,11,11,12,250,22, -156,2,23,197,2,11,9,249,22,164,2,23,196,2,20,20,95,88,148,8,36, -41,53,11,9,224,3,2,33,141,2,23,195,1,23,196,1,27,248,22,68,248, -22,164,20,23,199,1,250,22,156,2,23,198,2,23,196,2,249,22,80,248,22, -129,2,23,200,1,250,22,158,2,23,203,1,23,201,1,9,12,250,22,156,2, -23,196,1,23,197,1,248,22,95,23,199,1,27,28,28,23,194,2,248,22,167, -9,248,22,81,23,196,2,10,9,27,249,22,188,5,23,198,2,68,98,105,110, -97,114,121,250,22,44,22,35,88,148,8,36,39,47,11,9,223,3,33,137,2, -20,20,94,88,148,8,36,39,46,11,9,223,3,33,138,2,23,196,1,86,94, -28,28,248,22,89,23,194,2,249,22,4,32,0,88,148,8,36,40,48,11,9, -222,33,139,2,23,195,2,11,12,248,22,178,11,6,18,18,105,108,108,45,102, -111,114,109,101,100,32,99,111,110,116,101,110,116,27,247,22,138,2,27,90,144, -42,11,89,146,42,39,11,248,22,132,16,23,201,2,192,86,96,249,22,3,20, -20,94,88,148,8,36,40,57,11,9,224,2,3,33,142,2,23,195,1,23,197, -1,249,22,164,2,195,88,148,8,36,41,51,11,9,223,3,33,143,2,250,22, -156,2,80,144,47,8,25,41,23,200,1,249,22,80,23,201,1,198,193,20,13, -144,80,144,40,8,28,40,250,80,144,43,8,47,42,23,198,2,23,196,2,11, -27,250,22,158,2,80,144,44,8,25,41,23,197,2,21,143,11,17,0,0,27, -248,22,81,23,195,2,27,249,80,144,45,8,27,42,23,198,2,23,196,2,28, -249,22,171,9,23,195,2,23,196,1,248,22,165,20,195,86,94,23,195,1,20, -13,144,80,144,43,8,28,40,250,80,144,46,8,47,42,23,201,1,23,199,2, -23,196,2,27,20,20,95,88,148,8,36,39,55,8,240,0,0,0,2,9,225, -5,4,1,33,144,2,23,194,1,23,197,1,28,249,22,48,23,195,2,39,20, -13,144,80,144,44,46,40,26,29,80,144,8,34,47,40,249,22,31,11,80,144, -8,36,46,40,22,145,15,10,22,146,15,10,22,147,15,10,22,150,15,10,22, -149,15,11,22,151,15,10,22,148,15,10,22,152,15,10,22,153,15,10,22,154, -15,10,22,155,15,10,22,156,15,11,22,157,15,10,22,143,15,11,247,23,193, -1,250,22,182,11,2,9,2,52,23,196,1,248,22,8,20,20,94,88,148,39, -40,8,43,16,4,8,128,6,8,128,104,8,240,0,128,0,0,39,9,224,1, -2,33,145,2,23,195,1,0,7,35,114,120,34,47,43,34,28,248,22,153,7, -23,195,2,27,249,22,170,16,2,147,2,23,197,2,28,23,193,2,28,249,22, -128,4,248,22,101,23,196,2,248,22,182,3,248,22,156,7,23,199,2,249,22, -7,250,22,175,7,23,200,1,39,248,22,101,23,199,1,23,198,1,249,22,7, -250,22,175,7,23,200,2,39,248,22,101,23,199,2,249,22,80,249,22,175,7, -23,201,1,248,22,103,23,200,1,23,200,1,249,22,7,23,197,1,23,198,1, -90,144,42,11,89,146,42,39,11,248,22,132,16,23,198,1,86,94,23,195,1, -28,249,22,169,9,23,195,2,2,49,86,94,23,193,1,249,22,7,23,196,1, -23,200,1,27,249,22,80,23,197,1,23,201,1,28,248,22,153,7,23,195,2, -27,249,22,170,16,2,147,2,23,197,2,28,23,193,2,28,249,22,128,4,248, -22,101,23,196,2,248,22,182,3,248,22,156,7,23,199,2,249,22,7,250,22, -175,7,23,200,1,39,248,22,101,23,199,1,23,196,1,249,22,7,250,22,175, -7,23,200,2,39,248,22,101,23,199,2,249,22,80,249,22,175,7,23,201,1, -248,22,103,23,200,1,23,198,1,249,22,7,23,197,1,23,196,1,90,144,42, -11,89,146,42,39,11,248,22,132,16,23,198,1,86,94,23,195,1,28,249,22, -169,9,23,195,2,2,49,86,94,23,193,1,249,22,7,23,196,1,23,198,1, -249,80,144,48,8,31,42,194,249,22,80,197,199,28,248,22,88,23,196,2,9, -28,248,22,81,23,196,2,28,248,22,149,2,248,22,164,20,23,197,2,250,22, -94,249,22,2,22,129,2,250,22,158,2,248,22,164,20,23,204,2,23,202,2, -9,250,22,158,2,248,22,164,20,23,202,2,11,9,27,248,22,165,20,23,200, -1,28,248,22,88,23,194,2,9,28,248,22,81,23,194,2,28,248,22,149,2, -248,22,164,20,23,195,2,250,22,94,249,22,2,22,129,2,250,22,158,2,248, -22,164,20,23,202,2,23,206,2,9,250,22,158,2,248,22,164,20,23,200,2, -11,9,249,80,144,48,8,48,42,23,203,1,248,22,165,20,23,199,1,27,248, -80,144,45,8,30,42,248,22,164,20,23,196,2,250,22,94,250,22,158,2,23, -199,2,23,205,2,9,250,22,158,2,23,199,1,11,9,249,80,144,49,8,48, -42,23,204,1,248,22,165,20,23,200,1,249,22,94,247,22,156,16,249,80,144, -47,8,48,42,23,202,1,248,22,165,20,23,198,1,27,248,80,144,41,8,30, -42,248,22,164,20,23,198,2,250,22,94,250,22,158,2,23,199,2,23,201,2, -9,250,22,158,2,23,199,1,11,9,27,248,22,165,20,23,201,1,28,248,22, -88,23,194,2,9,28,248,22,81,23,194,2,28,248,22,149,2,248,22,164,20, -23,195,2,250,22,94,249,22,2,22,129,2,250,22,158,2,248,22,164,20,23, -202,2,23,207,2,9,250,22,158,2,248,22,164,20,23,200,2,11,9,249,80, -144,49,8,48,42,23,204,1,248,22,165,20,23,199,1,27,248,80,144,46,8, -30,42,248,22,164,20,23,196,2,250,22,94,250,22,158,2,23,199,2,23,206, -2,9,250,22,158,2,23,199,1,11,9,249,80,144,50,8,48,42,23,205,1, -248,22,165,20,23,200,1,249,22,94,247,22,156,16,249,80,144,48,8,48,42, -23,203,1,248,22,165,20,23,198,1,249,22,94,247,22,156,16,27,248,22,165, -20,23,199,1,28,248,22,88,23,194,2,9,28,248,22,81,23,194,2,28,248, -22,149,2,248,22,164,20,23,195,2,250,22,94,249,22,2,22,129,2,250,22, -158,2,248,22,164,20,23,202,2,23,205,2,9,250,22,158,2,248,22,164,20, -23,200,2,11,9,249,80,144,47,8,48,42,23,202,1,248,22,165,20,23,199, -1,27,248,80,144,44,8,30,42,248,22,164,20,23,196,2,250,22,94,250,22, -158,2,23,199,2,23,204,2,9,250,22,158,2,23,199,1,11,9,249,80,144, -48,8,48,42,23,203,1,248,22,165,20,23,200,1,249,22,94,247,22,156,16, -249,80,144,46,8,48,42,23,201,1,248,22,165,20,23,198,1,32,150,2,88, -148,8,36,40,50,11,2,50,222,33,151,2,28,248,22,88,248,22,82,23,195, -2,248,22,90,27,248,22,164,20,195,28,248,22,175,15,193,248,22,179,15,193, -192,250,22,91,27,248,22,164,20,23,198,2,28,248,22,175,15,193,248,22,179, -15,193,192,2,67,248,2,150,2,248,22,165,20,23,198,1,250,22,137,8,6, -7,7,10,32,126,97,32,126,97,6,1,1,32,23,196,1,249,22,137,8,6, -6,6,10,32,32,32,126,97,248,22,132,2,23,196,1,32,154,2,88,148,39, -41,51,11,68,102,105,108,116,101,114,222,33,155,2,28,248,22,88,23,195,2, -9,28,248,23,194,2,248,22,81,23,196,2,249,22,80,248,22,164,20,23,197, -2,249,2,154,2,23,197,1,248,22,165,20,23,199,1,249,2,154,2,23,195, -1,248,22,165,20,23,197,1,28,248,22,88,23,201,2,86,95,23,200,1,23, -199,1,28,23,201,2,28,197,249,22,129,16,202,199,200,27,28,248,22,88,23, -198,2,2,66,249,22,1,22,176,7,248,2,150,2,23,200,2,248,23,199,1, -251,22,137,8,6,70,70,99,111,108,108,101,99,116,105,111,110,32,110,111,116, -32,102,111,117,110,100,10,32,32,99,111,108,108,101,99,116,105,111,110,58,32, -126,115,10,32,32,105,110,32,99,111,108,108,101,99,116,105,111,110,32,100,105, -114,101,99,116,111,114,105,101,115,58,126,97,126,97,28,248,22,88,23,203,1, -28,248,22,175,15,23,202,2,248,22,179,15,23,202,1,23,201,1,250,22,176, -7,28,248,22,175,15,23,205,2,248,22,179,15,23,205,1,23,204,1,2,67, -23,201,2,249,22,1,22,176,7,249,22,2,32,0,88,148,8,36,40,48,11, -9,222,33,152,2,27,248,22,93,23,206,2,27,248,22,93,247,22,156,16,28, -249,22,129,4,249,22,184,3,23,198,2,23,197,2,44,23,206,2,249,22,94, -247,22,156,16,248,22,90,249,22,137,8,6,50,50,46,46,46,32,91,126,97, -32,97,100,100,105,116,105,111,110,97,108,32,108,105,110,107,101,100,32,97,110, -100,32,112,97,99,107,97,103,101,32,100,105,114,101,99,116,111,114,105,101,115, -93,249,22,184,3,23,201,1,23,200,1,28,249,22,5,22,131,2,23,202,2, -250,22,137,8,6,49,49,10,32,32,32,115,117,98,45,99,111,108,108,101,99, -116,105,111,110,58,32,126,115,10,32,32,105,110,32,112,97,114,101,110,116,32, -100,105,114,101,99,116,111,114,105,101,115,58,126,97,23,201,1,249,22,1,22, -176,7,249,22,2,32,0,88,148,8,36,40,48,11,9,222,33,153,2,249,2, -154,2,22,131,2,23,209,1,86,95,23,200,1,23,198,1,2,66,27,248,22, -81,23,202,2,27,28,248,22,175,15,23,195,2,249,22,129,16,23,196,1,23, -199,2,248,22,132,2,23,195,1,28,28,248,22,175,15,248,22,164,20,23,204, -2,248,22,188,15,23,194,2,10,27,250,22,1,22,129,16,23,197,1,23,202, -2,28,28,248,22,88,23,200,2,10,248,22,188,15,23,194,2,28,23,201,2, -28,28,250,80,144,45,8,32,42,195,203,204,10,27,28,248,22,175,15,202,248, -22,179,15,202,201,19,248,22,156,7,23,195,2,27,28,249,22,132,4,23,196, -4,43,28,249,22,159,7,6,4,4,46,114,107,116,249,22,175,7,23,199,2, -249,22,184,3,23,200,4,43,249,22,176,7,250,22,175,7,23,200,1,39,249, -22,184,3,23,201,4,43,6,3,3,46,115,115,86,94,23,195,1,11,11,28, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,51,46,48,46,49,48,84,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,192,0,0,0,1,0,0,8,0,16, +0,29,0,34,0,51,0,63,0,85,0,114,0,158,0,164,0,178,0,193,0, +211,0,223,0,239,0,253,0,19,1,39,1,73,1,90,1,107,1,130,1,145, +1,184,1,202,1,233,1,245,1,6,2,18,2,33,2,57,2,89,2,118,2, +134,2,152,2,172,2,193,2,211,2,242,2,0,3,17,3,61,3,69,3,74, +3,118,3,125,3,135,3,150,3,159,3,164,3,166,3,199,3,223,3,244,3, +1,4,11,4,20,4,31,4,49,4,62,4,72,4,82,4,88,4,93,4,105, +4,108,4,112,4,117,4,160,4,173,4,176,4,200,4,239,4,246,4,3,5, +25,5,36,5,66,5,89,5,97,5,121,5,142,5,91,6,121,6,212,9,235, +9,252,9,176,11,23,12,37,12,241,12,217,14,226,14,235,14,249,14,3,15, +23,16,126,16,251,16,68,17,141,17,243,17,16,18,87,18,221,18,36,19,243, +19,105,20,118,20,236,20,249,20,100,21,167,21,180,21,191,21,87,22,205,22, +249,22,104,23,182,25,206,25,68,26,150,27,157,27,209,27,222,27,212,28,228, +28,83,29,242,29,249,29,126,31,203,31,220,31,120,32,140,32,200,32,207,32, +67,33,121,33,140,33,91,34,107,34,68,35,69,36,106,36,115,36,202,37,47, +40,63,40,130,40,151,40,171,40,191,40,248,40,221,43,187,44,203,44,174,45, +232,45,9,46,141,46,44,47,60,47,157,47,174,47,252,49,47,52,63,52,37, +54,225,54,227,54,254,54,14,55,30,55,127,55,194,56,126,57,142,57,151,57, +158,57,224,58,34,60,152,60,198,63,72,64,204,64,149,66,99,67,141,67,249, +67,0,0,197,75,0,0,3,1,5,105,110,115,112,48,69,35,37,117,116,105, +108,115,74,112,97,116,104,45,115,116,114,105,110,103,63,66,98,115,98,115,78, +110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104,73,114,101,114,111, +111,116,45,112,97,116,104,1,20,102,105,110,100,45,101,120,101,99,117,116,97, +98,108,101,45,112,97,116,104,1,27,112,97,116,104,45,108,105,115,116,45,115, +116,114,105,110,103,45,62,112,97,116,104,45,108,105,115,116,1,42,99,97,108, +108,45,119,105,116,104,45,100,101,102,97,117,108,116,45,114,101,97,100,105,110, +103,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,67,113,117, +111,116,101,29,94,2,10,70,35,37,112,97,114,97,109,122,11,76,45,99,104, +101,99,107,45,114,101,108,112,97,116,104,79,45,99,104,101,99,107,45,99,111, +108,108,101,99,116,105,111,110,73,45,99,104,101,99,107,45,102,97,105,108,77, +99,111,108,108,101,99,116,105,111,110,45,112,97,116,104,75,102,105,110,100,45, +99,111,108,45,102,105,108,101,1,20,99,111,108,108,101,99,116,105,111,110,45, +102,105,108,101,45,112,97,116,104,1,18,102,105,110,100,45,109,97,105,110,45, +99,111,108,108,101,99,116,115,1,32,101,120,101,45,114,101,108,97,116,105,118, +101,45,112,97,116,104,45,62,99,111,109,112,108,101,116,101,45,112,97,116,104, +78,102,105,110,100,45,109,97,105,110,45,99,111,110,102,105,103,78,103,101,116, +45,99,111,110,102,105,103,45,116,97,98,108,101,1,21,103,101,116,45,105,110, +115,116,97,108,108,97,116,105,111,110,45,110,97,109,101,76,99,111,101,114,99, +101,45,116,111,45,112,97,116,104,1,37,99,111,108,108,101,99,116,115,45,114, +101,108,97,116,105,118,101,45,112,97,116,104,45,62,99,111,109,112,108,101,116, +101,45,112,97,116,104,79,97,100,100,45,99,111,110,102,105,103,45,115,101,97, +114,99,104,1,29,102,105,110,100,45,108,105,98,114,97,114,121,45,99,111,108, +108,101,99,116,105,111,110,45,108,105,110,107,115,73,108,105,110,107,115,45,99, +97,99,104,101,78,115,116,97,109,112,45,112,114,111,109,112,116,45,116,97,103, +73,102,105,108,101,45,62,115,116,97,109,112,76,110,111,45,102,105,108,101,45, +115,116,97,109,112,63,1,22,103,101,116,45,108,105,110,107,101,100,45,99,111, +108,108,101,99,116,105,111,110,115,1,30,110,111,114,109,97,108,105,122,101,45, +99,111,108,108,101,99,116,105,111,110,45,114,101,102,101,114,101,110,99,101,1, +27,102,105,108,101,45,101,120,105,115,116,115,63,47,109,97,121,98,101,45,99, +111,109,112,105,108,101,100,77,112,97,116,104,45,97,100,100,45,115,117,102,102, +105,120,79,99,104,101,99,107,45,115,117,102,102,105,120,45,99,97,108,108,1, +18,112,97,116,104,45,97,100,106,117,115,116,45,115,117,102,102,105,120,1,19, +112,97,116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,79,108, +111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,1,29,102,105,110, +100,45,108,105,98,114,97,114,121,45,99,111,108,108,101,99,116,105,111,110,45, +112,97,116,104,115,75,101,109,98,101,100,100,101,100,45,108,111,97,100,78,110, +111,114,109,97,108,45,112,97,116,104,45,99,97,115,101,6,41,41,40,111,114, +47,99,32,112,97,116,104,45,102,111,114,45,115,111,109,101,45,115,121,115,116, +101,109,63,32,112,97,116,104,45,115,116,114,105,110,103,63,41,69,119,105,110, +100,111,119,115,6,2,2,92,49,6,41,41,40,111,114,47,99,32,112,97,116, +104,45,115,116,114,105,110,103,63,32,112,97,116,104,45,102,111,114,45,115,111, +109,101,45,115,121,115,116,101,109,63,41,6,4,4,112,97,116,104,5,8,92, +92,63,92,82,69,76,92,6,12,12,112,97,116,104,45,115,116,114,105,110,103, +63,70,114,101,108,97,116,105,118,101,66,108,111,111,112,5,0,6,30,30,40, +112,114,111,99,101,100,117,114,101,45,97,114,105,116,121,45,105,110,99,108,117, +100,101,115,47,99,32,48,41,6,21,21,105,110,118,97,108,105,100,32,114,101, +108,97,116,105,118,101,32,112,97,116,104,6,18,18,40,97,110,121,47,99,32, +46,32,45,62,32,46,32,97,110,121,41,74,99,111,108,108,101,99,116,115,45, +100,105,114,71,101,120,101,99,45,102,105,108,101,70,111,114,105,103,45,100,105, +114,72,99,111,110,102,105,103,45,100,105,114,79,105,110,115,116,97,108,108,97, +116,105,111,110,45,110,97,109,101,6,10,10,108,105,110,107,115,46,114,107,116, +100,71,97,100,100,111,110,45,100,105,114,71,102,115,45,99,104,97,110,103,101, +67,101,114,114,111,114,66,114,111,111,116,73,115,116,97,116,105,99,45,114,111, +111,116,6,0,0,6,1,1,47,5,3,46,122,111,6,40,40,114,101,109,111, +118,105,110,103,32,115,117,102,102,105,120,32,109,97,107,101,115,32,112,97,116, +104,32,101,108,101,109,101,110,116,32,101,109,112,116,121,6,10,10,103,105,118, +101,110,32,112,97,116,104,5,1,95,6,21,21,40,111,114,47,99,32,115,116, +114,105,110,103,63,32,98,121,116,101,115,63,41,6,36,36,99,97,110,110,111, +116,32,97,100,100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114, +111,111,116,32,112,97,116,104,58,32,68,102,105,110,105,115,104,5,11,80,76, +84,67,79,76,76,69,67,84,83,1,20,99,111,108,108,101,99,116,115,45,115, +101,97,114,99,104,45,100,105,114,115,6,8,8,99,111,108,108,101,99,116,115, +27,248,22,179,15,194,28,192,192,28,248,22,154,7,194,27,248,22,138,16,195, +28,192,192,248,22,139,16,195,11,0,21,35,114,120,34,94,91,92,92,93,91, +92,92,93,91,63,93,91,92,92,93,34,0,6,35,114,120,34,47,34,0,22, +35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47,92,92,93,42,36, +34,0,19,35,114,120,34,91,32,46,93,43,40,91,47,92,92,93,42,41,36, +34,86,94,28,28,248,22,180,15,23,195,2,10,28,248,22,179,15,23,195,2, +10,28,248,22,154,7,23,195,2,28,248,22,138,16,23,195,2,10,248,22,139, +16,23,195,2,11,12,250,22,183,11,2,41,2,42,23,197,2,28,28,248,22, +180,15,23,195,2,249,22,170,9,248,22,181,15,23,197,2,2,43,249,22,170, +9,247,22,181,8,2,43,27,28,248,22,154,7,23,196,2,23,195,2,248,22, +166,8,248,22,184,15,23,197,2,28,249,22,176,16,2,79,23,195,2,28,248, +22,154,7,195,248,22,187,15,195,194,86,94,23,195,1,27,248,22,129,8,23, +195,1,249,22,188,15,248,22,169,8,250,22,184,16,2,80,28,249,22,176,16, +2,81,23,201,2,23,199,1,250,22,184,16,2,82,23,202,1,2,44,80,144, +47,40,41,2,43,28,248,22,154,7,194,248,22,187,15,194,193,0,28,35,114, +120,34,94,92,92,92,92,92,92,92,92,91,63,93,92,92,92,92,85,78,67, +92,92,92,92,34,86,95,28,28,28,248,22,179,15,23,195,2,10,28,248,22, +154,7,23,195,2,28,248,22,138,16,23,195,2,10,248,22,139,16,23,195,2, +11,10,248,22,180,15,23,195,2,12,252,22,183,11,2,6,2,45,39,23,199, +2,23,200,2,28,28,28,248,22,179,15,23,196,2,10,28,248,22,154,7,23, +196,2,28,248,22,138,16,23,196,2,10,248,22,139,16,23,196,2,11,10,248, +22,180,15,23,196,2,12,252,22,183,11,2,6,2,45,40,23,199,2,23,200, +2,27,28,248,22,180,15,23,196,2,248,22,181,15,23,196,2,247,22,182,15, +86,95,28,28,248,22,140,16,23,196,2,10,249,22,170,9,247,22,182,15,23, +195,2,12,253,22,185,11,2,6,6,54,54,112,97,116,104,32,105,115,32,110, +111,116,32,99,111,109,112,108,101,116,101,32,97,110,100,32,110,111,116,32,116, +104,101,32,112,108,97,116,102,111,114,109,39,115,32,99,111,110,118,101,110,116, +105,111,110,2,46,23,201,2,6,24,24,112,108,97,116,102,111,114,109,32,99, +111,110,118,101,110,116,105,111,110,32,116,121,112,101,247,22,182,15,28,249,22, +170,9,28,248,22,180,15,23,199,2,248,22,181,15,23,199,2,247,22,182,15, +23,195,2,12,253,22,185,11,2,6,6,37,37,103,105,118,101,110,32,112,97, +116,104,115,32,117,115,101,32,100,105,102,102,101,114,101,110,116,32,99,111,110, +118,101,110,116,105,111,110,115,2,46,23,201,2,6,9,9,114,111,111,116,32, +112,97,116,104,23,202,2,27,27,248,22,144,16,28,248,22,140,16,23,199,2, +23,198,1,248,22,141,16,23,199,1,86,94,28,28,248,22,180,15,23,194,2, +10,28,248,22,179,15,23,194,2,10,28,248,22,154,7,23,194,2,28,248,22, +138,16,23,194,2,10,248,22,139,16,23,194,2,11,12,250,22,183,11,2,41, +2,42,23,196,2,28,28,248,22,180,15,23,194,2,249,22,170,9,248,22,181, +15,23,196,2,2,43,249,22,170,9,247,22,181,8,2,43,27,28,248,22,154, +7,23,195,2,23,194,2,248,22,166,8,248,22,184,15,23,196,2,28,249,22, +176,16,2,79,23,195,2,28,248,22,154,7,194,248,22,187,15,194,193,86,94, +23,194,1,27,248,22,129,8,23,195,1,249,22,188,15,248,22,169,8,250,22, +184,16,2,80,28,249,22,176,16,2,81,23,201,2,23,199,1,250,22,184,16, +2,82,23,202,1,2,44,80,144,50,40,41,2,43,28,248,22,154,7,193,248, +22,187,15,193,192,27,248,22,184,15,23,195,2,28,249,22,170,9,23,197,2, +66,117,110,105,120,28,249,22,151,8,194,5,1,47,28,248,22,180,15,198,197, +248,22,187,15,198,249,22,133,16,199,249,22,188,15,249,22,154,8,248,22,184, +15,200,40,198,86,94,23,194,1,28,249,22,170,9,23,197,2,2,43,249,22, +133,16,23,200,1,249,22,188,15,28,249,22,176,16,0,27,35,114,120,34,94, +92,92,92,92,92,92,92,92,91,63,93,92,92,92,92,91,97,45,122,93,58, +34,23,199,2,251,22,155,8,2,47,250,22,154,8,203,43,44,5,1,92,249, +22,154,8,202,45,28,249,22,176,16,2,84,23,199,2,249,22,155,8,2,47, +249,22,154,8,200,43,28,249,22,176,16,2,84,23,199,2,249,22,155,8,2, +47,249,22,154,8,200,43,28,249,22,176,16,0,14,35,114,120,34,94,92,92, +92,92,92,92,92,92,34,23,199,2,249,22,155,8,5,4,85,78,67,92,249, +22,154,8,200,41,28,249,22,176,16,0,12,35,114,120,34,94,91,97,45,122, +93,58,34,198,249,22,155,8,250,22,154,8,201,39,40,249,22,154,8,200,41, +12,198,12,32,86,88,148,8,36,42,56,11,72,102,111,117,110,100,45,101,120, +101,99,222,33,89,32,87,88,148,8,36,43,61,11,66,110,101,120,116,222,33, +88,27,248,22,142,16,23,196,2,28,249,22,172,9,23,195,2,23,197,1,11, +28,248,22,138,16,23,194,2,27,249,22,133,16,23,197,1,23,196,1,28,23, +197,2,90,144,42,11,89,146,42,39,11,248,22,136,16,23,197,2,86,95,23, +195,1,23,194,1,27,28,23,202,2,27,248,22,142,16,23,199,2,28,249,22, +172,9,23,195,2,23,200,2,11,28,248,22,138,16,23,194,2,250,2,86,23, +205,2,23,206,2,249,22,133,16,23,200,2,23,198,1,250,2,86,23,205,2, +23,206,2,23,196,1,11,28,23,193,2,192,86,94,23,193,1,27,28,248,22, +179,15,23,196,2,27,249,22,133,16,23,198,2,23,205,2,28,28,248,22,128, +16,193,10,248,22,191,15,193,192,11,11,28,23,193,2,192,86,94,23,193,1, +28,23,203,2,11,27,248,22,142,16,23,200,2,28,249,22,172,9,194,23,201, +1,11,28,248,22,138,16,193,250,2,86,205,206,249,22,133,16,200,197,250,2, +86,205,206,195,192,86,94,23,194,1,28,23,196,2,90,144,42,11,89,146,42, +39,11,248,22,136,16,23,197,2,86,95,23,195,1,23,194,1,27,28,23,201, +2,27,248,22,142,16,23,199,2,28,249,22,172,9,23,195,2,23,200,2,11, +28,248,22,138,16,23,194,2,250,2,86,23,204,2,23,205,2,249,22,133,16, +23,200,2,23,198,1,250,2,86,23,204,2,23,205,2,23,196,1,11,28,23, +193,2,192,86,94,23,193,1,27,28,248,22,179,15,23,196,2,27,249,22,133, +16,23,198,2,23,204,2,28,28,248,22,128,16,193,10,248,22,191,15,193,192, +11,11,28,23,193,2,192,86,94,23,193,1,28,23,202,2,11,27,248,22,142, +16,23,200,2,28,249,22,172,9,194,23,201,1,11,28,248,22,138,16,193,250, +2,86,204,205,249,22,133,16,200,197,250,2,86,204,205,195,192,28,23,193,2, +90,144,42,11,89,146,42,39,11,248,22,136,16,23,199,2,86,95,23,195,1, +23,194,1,27,28,23,198,2,251,2,87,23,198,2,23,203,2,23,201,2,23, +202,2,11,28,23,193,2,192,86,94,23,193,1,27,28,248,22,179,15,195,27, +249,22,133,16,197,200,28,28,248,22,128,16,193,10,248,22,191,15,193,192,11, +11,28,192,192,28,198,11,251,2,87,198,203,201,202,194,32,90,88,148,8,36, +43,60,11,2,50,222,33,91,28,248,22,89,23,197,2,11,27,249,22,133,16, +248,22,141,16,248,22,82,23,201,2,23,196,2,28,248,22,191,15,23,194,2, +250,2,86,197,198,195,86,94,23,193,1,27,248,22,171,20,23,199,1,28,248, +22,89,23,194,2,11,27,249,22,133,16,248,22,141,16,248,22,82,23,198,2, +23,198,2,28,248,22,191,15,23,194,2,250,2,86,199,200,195,86,94,23,193, +1,27,248,22,171,20,23,196,1,28,248,22,89,23,194,2,11,27,249,22,133, +16,248,22,141,16,248,22,82,23,198,2,23,200,2,28,248,22,191,15,23,194, +2,250,2,86,201,202,195,86,94,23,193,1,27,248,22,171,20,23,196,1,28, +248,22,89,23,194,2,11,27,249,22,133,16,248,22,141,16,248,22,82,197,201, +28,248,22,191,15,193,250,2,86,203,204,195,251,2,90,203,204,205,248,22,171, +20,198,86,95,28,28,248,22,179,15,23,195,2,10,28,248,22,154,7,23,195, +2,28,248,22,138,16,23,195,2,10,248,22,139,16,23,195,2,11,12,250,22, +183,11,2,7,2,48,23,197,2,28,28,23,195,2,28,28,248,22,179,15,23, +196,2,10,28,248,22,154,7,23,196,2,28,248,22,138,16,23,196,2,10,248, +22,139,16,23,196,2,11,248,22,138,16,23,196,2,11,10,12,250,22,183,11, +2,7,6,45,45,40,111,114,47,99,32,35,102,32,40,97,110,100,47,99,32, +112,97,116,104,45,115,116,114,105,110,103,63,32,114,101,108,97,116,105,118,101, +45,112,97,116,104,63,41,41,23,198,2,28,28,248,22,138,16,23,195,2,90, +144,42,11,89,146,42,39,11,248,22,136,16,23,198,2,249,22,170,9,194,2, +49,11,27,249,22,176,8,247,22,175,8,5,4,80,65,84,72,27,28,23,194, +2,249,80,143,43,44,249,22,166,8,23,198,1,7,63,9,86,94,23,194,1, +9,27,28,249,22,170,9,247,22,181,8,2,43,249,22,81,248,22,188,15,5, +1,46,23,196,1,23,194,1,28,248,22,89,23,194,2,11,27,249,22,133,16, +248,22,141,16,248,22,82,23,198,2,23,200,2,28,248,22,191,15,23,194,2, +250,2,86,201,202,195,86,94,23,193,1,27,248,22,171,20,23,196,1,28,248, +22,89,23,194,2,11,27,249,22,133,16,248,22,141,16,248,22,82,23,198,2, +23,202,2,28,248,22,191,15,23,194,2,250,2,86,203,204,195,86,94,23,193, +1,27,248,22,171,20,23,196,1,28,248,22,89,23,194,2,11,27,249,22,133, +16,248,22,141,16,248,22,82,23,198,2,23,204,2,28,248,22,191,15,23,194, +2,250,2,86,205,206,195,86,94,23,193,1,27,248,22,171,20,23,196,1,28, +248,22,89,23,194,2,11,27,249,22,133,16,248,22,141,16,248,22,82,197,205, +28,248,22,191,15,193,250,2,86,23,15,23,16,195,251,2,90,23,15,23,16, +23,17,248,22,171,20,198,27,248,22,141,16,23,196,1,28,248,22,191,15,193, +250,2,86,198,199,195,11,250,80,144,42,43,42,196,197,11,250,80,144,42,43, +42,196,11,11,32,95,88,148,8,36,42,58,11,2,50,222,33,97,0,8,35, +114,120,35,34,92,34,34,27,249,22,172,16,23,197,2,23,198,2,28,23,193, +2,86,94,23,196,1,27,248,22,103,23,195,2,27,27,248,22,112,23,197,1, +27,249,22,172,16,23,201,2,23,196,2,28,23,193,2,86,94,23,194,1,27, +248,22,103,23,195,2,27,250,2,95,202,23,204,1,248,22,112,23,199,1,27, +28,249,22,170,9,247,22,181,8,2,43,250,22,184,16,2,96,23,198,1,2, +51,194,28,249,22,151,8,194,2,51,249,22,95,202,195,249,22,81,248,22,188, +15,195,195,86,95,23,199,1,23,193,1,27,28,249,22,170,9,247,22,181,8, +2,43,250,22,184,16,2,96,23,198,1,2,51,194,28,249,22,151,8,194,2, +51,249,22,95,200,9,249,22,81,248,22,188,15,195,9,27,28,249,22,170,9, +247,22,181,8,2,43,250,22,184,16,2,96,23,198,1,2,51,194,28,249,22, +151,8,194,2,51,249,22,95,198,195,249,22,81,248,22,188,15,195,195,86,95, +23,195,1,23,193,1,27,28,249,22,170,9,247,22,181,8,2,43,250,22,184, +16,2,96,23,200,1,2,51,196,28,249,22,151,8,194,2,51,249,22,95,196, +9,249,22,81,248,22,188,15,195,9,86,95,28,28,248,22,143,8,194,10,248, +22,154,7,194,12,250,22,183,11,2,8,6,21,21,40,111,114,47,99,32,98, +121,116,101,115,63,32,115,116,114,105,110,103,63,41,196,28,28,248,22,90,195, +249,22,4,22,179,15,196,11,12,250,22,183,11,2,8,6,14,14,40,108,105, +115,116,111,102,32,112,97,116,104,63,41,197,250,2,95,197,195,28,248,22,154, +7,197,248,22,168,8,197,196,28,28,248,22,0,23,195,2,249,22,48,23,196, +2,39,11,20,13,144,80,144,39,46,40,26,35,80,144,8,35,47,40,249,22, +31,11,80,144,8,37,46,40,22,146,15,10,22,147,15,10,22,148,15,10,22, +149,15,11,22,150,15,11,22,154,15,10,22,153,15,11,22,155,15,10,22,152, +15,10,22,156,15,10,22,151,15,11,22,157,15,10,22,158,15,10,22,159,15, +10,22,160,15,11,22,161,15,10,22,144,15,11,247,23,194,1,250,22,183,11, +2,9,2,52,23,197,1,86,94,28,28,248,22,179,15,23,195,2,10,28,248, +22,154,7,23,195,2,28,248,22,138,16,23,195,2,10,248,22,139,16,23,195, +2,11,12,250,22,183,11,23,196,2,2,48,23,197,2,28,248,22,138,16,23, +195,2,12,251,22,185,11,23,197,1,2,53,2,46,23,198,1,86,94,28,28, +248,22,179,15,23,195,2,10,28,248,22,154,7,23,195,2,28,248,22,138,16, +23,195,2,10,248,22,139,16,23,195,2,11,12,250,22,183,11,23,196,2,2, +48,23,197,2,28,248,22,138,16,23,195,2,12,251,22,185,11,23,197,1,2, +53,2,46,23,198,1,86,95,28,28,248,22,179,15,23,195,2,10,28,248,22, +154,7,23,195,2,28,248,22,138,16,23,195,2,10,248,22,139,16,23,195,2, +11,12,250,22,183,11,23,196,2,2,48,23,197,2,28,248,22,138,16,23,195, +2,86,94,23,194,1,12,251,22,185,11,23,197,2,2,53,2,46,23,198,1, +249,22,3,20,20,94,88,148,8,36,40,50,11,9,223,2,33,101,23,195,1, +23,197,1,28,28,248,22,0,23,195,2,249,22,48,23,196,2,40,11,12,250, +22,183,11,23,196,1,2,54,23,197,1,86,94,28,28,248,22,179,15,23,194, +2,10,28,248,22,154,7,23,194,2,28,248,22,138,16,23,194,2,10,248,22, +139,16,23,194,2,11,12,250,22,183,11,2,15,2,48,23,196,2,28,248,22, +138,16,23,194,2,12,251,22,185,11,2,15,2,53,2,46,23,197,1,86,97, +28,28,248,22,179,15,23,196,2,10,28,248,22,154,7,23,196,2,28,248,22, +138,16,23,196,2,10,248,22,139,16,23,196,2,11,12,250,22,183,11,2,15, +2,48,23,198,2,28,248,22,138,16,23,196,2,12,251,22,185,11,2,15,2, +53,2,46,23,199,2,249,22,3,32,0,88,148,8,36,40,49,11,9,222,33, +104,23,198,2,28,28,248,22,0,23,195,2,249,22,48,23,196,2,40,11,12, +250,22,183,11,2,15,2,54,23,197,2,252,80,143,44,52,23,199,1,23,200, +1,23,201,1,11,11,86,94,28,28,248,22,179,15,23,194,2,10,28,248,22, +154,7,23,194,2,28,248,22,138,16,23,194,2,10,248,22,139,16,23,194,2, +11,12,250,22,183,11,2,17,2,48,23,196,2,28,248,22,138,16,23,194,2, +12,251,22,185,11,2,17,2,53,2,46,23,197,1,86,99,28,28,248,22,179, +15,23,197,2,10,28,248,22,154,7,23,197,2,28,248,22,138,16,23,197,2, +10,248,22,139,16,23,197,2,11,12,250,22,183,11,2,17,2,48,23,199,2, +28,248,22,138,16,23,197,2,12,251,22,185,11,2,17,2,53,2,46,23,200, +2,28,28,248,22,179,15,23,198,2,10,28,248,22,154,7,23,198,2,28,248, +22,138,16,23,198,2,10,248,22,139,16,23,198,2,11,12,250,22,183,11,2, +17,2,48,23,200,2,28,248,22,138,16,23,198,2,12,251,22,185,11,2,17, +2,53,2,46,23,201,2,249,22,3,32,0,88,148,8,36,40,49,11,9,222, +33,106,23,200,2,28,28,248,22,0,23,195,2,249,22,48,23,196,2,40,11, +12,250,22,183,11,2,17,2,54,23,197,2,252,80,143,44,52,23,199,1,23, +202,1,23,203,1,23,201,1,23,200,1,27,248,22,156,16,2,55,28,248,22, +140,16,23,194,2,248,22,143,16,23,194,1,28,248,22,139,16,23,194,2,90, +144,42,11,89,146,42,39,11,248,22,136,16,249,22,141,16,250,80,144,49,43, +42,248,22,156,16,2,56,11,11,248,22,156,16,2,57,86,95,23,195,1,23, +194,1,248,22,143,16,249,22,141,16,23,199,1,23,196,1,27,250,80,144,44, +43,42,248,22,156,16,2,56,23,197,1,10,28,23,193,2,248,22,143,16,23, +194,1,11,249,80,144,41,55,40,39,80,144,41,8,40,42,27,248,22,156,16, +2,58,28,248,22,140,16,23,194,2,248,22,143,16,23,194,1,28,248,22,139, +16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,136,16,249,22,141,16, +250,80,144,49,43,42,248,22,156,16,2,56,11,11,248,22,156,16,2,57,86, +95,23,195,1,23,194,1,248,22,143,16,249,22,141,16,23,199,1,23,196,1, +27,250,80,144,44,43,42,248,22,156,16,2,56,23,197,1,10,28,23,193,2, +248,22,143,16,23,194,1,11,249,80,144,41,55,40,40,80,144,41,8,41,42, +27,20,13,144,80,144,40,46,40,26,35,80,144,8,36,47,40,249,22,31,11, +80,144,8,38,46,40,22,146,15,10,22,147,15,10,22,148,15,10,22,149,15, +11,22,150,15,11,22,154,15,10,22,153,15,11,22,155,15,10,22,152,15,10, +22,156,15,10,22,151,15,11,22,157,15,10,22,158,15,10,22,159,15,10,22, +160,15,11,22,161,15,10,22,144,15,11,247,22,149,6,28,248,22,150,2,193, +192,11,27,28,23,195,2,249,22,133,16,23,197,1,6,11,11,99,111,110,102, +105,103,46,114,107,116,100,86,94,23,195,1,11,27,28,23,194,2,28,248,22, +191,15,23,195,2,249,22,141,6,23,196,1,80,144,43,8,42,42,11,11,28, +192,192,21,17,1,0,250,22,159,2,23,196,1,2,59,247,22,172,8,250,22, +159,2,195,2,59,247,22,172,8,28,248,22,154,7,23,195,2,27,248,22,187, +15,23,196,1,28,248,22,140,16,23,194,2,192,249,22,141,16,23,195,1,27, +247,80,144,43,54,42,28,23,193,2,192,86,94,23,193,1,247,22,157,16,28, +248,22,143,8,23,195,2,27,248,22,188,15,23,196,1,28,248,22,140,16,23, +194,2,192,249,22,141,16,23,195,1,27,247,80,144,43,54,42,28,23,193,2, +192,86,94,23,193,1,247,22,157,16,28,248,22,179,15,23,195,2,28,248,22, +140,16,23,195,2,193,249,22,141,16,23,196,1,27,247,80,144,42,54,42,28, +23,193,2,192,86,94,23,193,1,247,22,157,16,193,27,248,22,156,16,2,55, +28,248,22,140,16,23,194,2,248,22,143,16,23,194,1,28,248,22,139,16,23, +194,2,90,144,42,11,89,146,42,39,11,248,22,136,16,249,22,141,16,250,80, +144,49,43,42,248,22,156,16,2,56,11,11,248,22,156,16,2,57,86,95,23, +195,1,23,194,1,248,22,143,16,249,22,141,16,23,199,1,23,196,1,27,250, +80,144,44,43,42,248,22,156,16,2,56,23,197,1,10,28,23,193,2,248,22, +143,16,23,194,1,11,28,248,22,140,16,23,195,2,193,249,22,141,16,23,196, +1,27,249,80,144,44,55,40,39,80,144,44,8,43,42,28,23,193,2,192,86, +94,23,193,1,247,22,157,16,28,248,22,140,16,23,195,2,248,22,143,16,23, +195,1,28,248,22,139,16,23,195,2,90,144,42,11,89,146,42,39,11,248,22, +136,16,249,22,141,16,250,80,144,48,43,42,248,22,156,16,2,56,11,11,248, +22,156,16,2,57,86,95,23,195,1,23,194,1,248,22,143,16,249,22,141,16, +23,200,1,23,196,1,27,250,80,144,43,43,42,248,22,156,16,2,56,23,198, +1,10,28,23,193,2,248,22,143,16,23,194,1,11,28,248,22,89,23,196,2, +9,28,248,22,82,23,196,2,249,22,81,27,248,22,170,20,23,199,2,28,248, +22,154,7,23,194,2,27,248,22,187,15,23,195,1,28,248,22,140,16,23,194, +2,192,249,22,141,16,23,195,1,27,247,80,144,46,54,42,28,23,193,2,192, +86,94,23,193,1,247,22,157,16,28,248,22,143,8,23,194,2,27,248,22,188, +15,23,195,1,28,248,22,140,16,23,194,2,192,249,22,141,16,23,195,1,27, +247,80,144,46,54,42,28,23,193,2,192,86,94,23,193,1,247,22,157,16,28, +248,22,179,15,23,194,2,28,248,22,140,16,23,194,2,192,249,22,141,16,23, +195,1,27,247,80,144,45,54,42,28,23,193,2,192,86,94,23,193,1,247,22, +157,16,192,27,248,22,171,20,23,199,1,28,248,22,89,23,194,2,9,28,248, +22,82,23,194,2,249,22,81,248,80,144,45,60,42,248,22,170,20,23,197,2, +27,248,22,171,20,23,197,1,28,248,22,89,23,194,2,9,28,248,22,82,23, +194,2,249,22,81,248,80,144,48,60,42,248,22,170,20,23,197,2,249,80,144, +49,8,44,42,23,204,1,248,22,171,20,23,198,1,249,22,95,23,202,2,249, +80,144,49,8,44,42,23,204,1,248,22,171,20,23,198,1,249,22,95,23,199, +2,27,248,22,171,20,23,197,1,28,248,22,89,23,194,2,9,28,248,22,82, +23,194,2,249,22,81,248,80,144,48,60,42,248,22,170,20,23,197,2,249,80, +144,49,8,44,42,23,204,1,248,22,171,20,23,198,1,249,22,95,23,202,2, +249,80,144,49,8,44,42,23,204,1,248,22,171,20,23,198,1,249,22,95,23, +196,2,27,248,22,171,20,23,199,1,28,248,22,89,23,194,2,9,28,248,22, +82,23,194,2,249,22,81,248,80,144,45,60,42,248,22,170,20,23,197,2,27, +248,22,171,20,23,197,1,28,248,22,89,23,194,2,9,28,248,22,82,23,194, +2,249,22,81,248,80,144,48,60,42,248,22,170,20,23,197,2,249,80,144,49, +8,44,42,23,204,1,248,22,171,20,23,198,1,249,22,95,23,202,2,249,80, +144,49,8,44,42,23,204,1,248,22,171,20,23,198,1,249,22,95,23,199,2, +27,248,22,171,20,23,197,1,28,248,22,89,23,194,2,9,28,248,22,82,23, +194,2,249,22,81,248,80,144,48,60,42,248,22,170,20,23,197,2,249,80,144, +49,8,44,42,23,204,1,248,22,171,20,23,198,1,249,22,95,23,202,2,249, +80,144,49,8,44,42,23,204,1,248,22,171,20,23,198,1,27,250,22,159,2, +23,198,1,23,199,1,11,28,192,249,80,144,42,8,44,42,198,194,196,27,248, +22,156,16,2,58,28,248,22,140,16,23,194,2,248,22,143,16,23,194,1,28, +248,22,139,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,136,16,249, +22,141,16,250,80,144,49,43,42,248,22,156,16,2,56,11,11,248,22,156,16, +2,57,86,95,23,195,1,23,194,1,248,22,143,16,249,22,141,16,23,199,1, +23,196,1,27,250,80,144,44,43,42,248,22,156,16,2,56,23,197,1,10,28, +23,193,2,248,22,143,16,23,194,1,11,27,248,80,144,41,58,42,249,80,144, +43,55,40,40,80,144,43,8,45,42,27,27,250,22,159,2,23,198,2,72,108, +105,110,107,115,45,102,105,108,101,11,27,28,23,194,2,23,194,1,86,94,23, +194,1,249,22,133,16,27,250,22,159,2,23,202,2,71,115,104,97,114,101,45, +100,105,114,11,28,192,192,249,22,133,16,64,117,112,6,5,5,115,104,97,114, +101,2,60,28,248,22,154,7,23,194,2,27,248,22,187,15,23,195,1,28,248, +22,140,16,23,194,2,192,249,22,141,16,23,195,1,27,247,80,144,47,54,42, +28,23,193,2,192,86,94,23,193,1,247,22,157,16,28,248,22,143,8,23,194, +2,27,248,22,188,15,23,195,1,28,248,22,140,16,23,194,2,192,249,22,141, +16,23,195,1,27,247,80,144,47,54,42,28,23,193,2,192,86,94,23,193,1, +247,22,157,16,28,248,22,179,15,23,194,2,28,248,22,140,16,23,194,2,192, +249,22,141,16,23,195,1,27,247,80,144,46,54,42,28,23,193,2,192,86,94, +23,193,1,247,22,157,16,192,250,22,95,248,22,91,11,28,247,22,164,16,28, +247,22,165,16,248,22,91,250,22,133,16,248,22,156,16,2,61,250,22,159,2, +23,204,2,2,59,247,22,172,8,2,60,9,9,28,247,22,165,16,250,80,144, +47,8,23,42,23,200,1,1,18,108,105,110,107,115,45,115,101,97,114,99,104, +45,102,105,108,101,115,248,22,91,23,200,1,9,248,22,175,13,23,194,1,249, +22,14,80,144,41,8,26,41,28,248,22,131,13,23,197,2,86,94,23,196,1, +32,0,88,148,8,36,39,44,11,9,222,11,20,20,94,88,148,8,36,39,46, +11,9,223,3,33,124,23,196,1,32,126,88,148,39,40,59,11,2,50,222,33, +127,90,144,42,11,89,146,42,39,11,248,22,136,16,23,197,1,86,95,23,195, +1,23,194,1,28,248,22,179,15,23,194,2,28,248,22,128,16,23,194,2,249, +22,146,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,90,144,42, +11,89,146,42,39,11,248,22,136,16,23,197,1,86,95,23,195,1,23,194,1, +28,248,22,179,15,23,194,2,28,248,22,128,16,23,194,2,249,22,146,6,23, +195,1,32,0,88,148,8,36,39,44,11,9,222,11,90,144,42,11,89,146,42, +39,11,248,22,136,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22,179, +15,23,194,2,28,248,22,128,16,23,194,2,249,22,146,6,23,195,1,32,0, +88,148,8,36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248,22, +136,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22,179,15,23,194,2, +28,248,22,128,16,23,194,2,249,22,146,6,23,195,1,32,0,88,148,8,36, +39,44,11,9,222,11,248,2,126,23,194,1,11,11,11,11,32,128,2,88,148, +8,36,40,58,11,2,50,222,33,129,2,27,249,22,164,6,8,128,128,23,196, +2,28,248,22,149,7,23,194,2,9,249,22,81,23,195,1,27,249,22,164,6, +8,128,128,23,199,2,28,248,22,149,7,23,194,2,9,249,22,81,23,195,1, +27,249,22,164,6,8,128,128,23,202,2,28,248,22,149,7,23,194,2,9,249, +22,81,23,195,1,27,249,22,164,6,8,128,128,23,205,2,28,248,22,149,7, +23,194,2,9,249,22,81,23,195,1,248,2,128,2,23,206,1,27,249,22,164, +6,8,128,128,23,196,2,28,248,22,143,8,23,194,2,28,249,22,133,4,248, +22,148,8,23,196,2,8,128,128,249,22,1,22,155,8,249,22,81,23,197,1, +27,249,22,164,6,8,128,128,23,201,2,28,248,22,149,7,23,194,2,9,249, +22,81,23,195,1,27,249,22,164,6,8,128,128,23,204,2,28,248,22,149,7, +23,194,2,9,249,22,81,23,195,1,27,249,22,164,6,8,128,128,23,207,2, +28,248,22,149,7,23,194,2,9,249,22,81,23,195,1,27,249,22,164,6,8, +128,128,23,210,2,28,248,22,149,7,23,194,2,9,249,22,81,23,195,1,248, +2,128,2,23,211,1,192,192,248,22,134,6,23,194,1,20,13,144,80,144,40, +8,28,40,80,144,40,8,46,42,27,28,249,22,190,8,248,22,181,8,2,62, +41,90,144,42,11,89,146,42,39,11,248,22,136,16,23,198,2,86,95,23,195, +1,23,194,1,28,248,22,179,15,23,194,2,28,248,22,128,16,23,194,2,249, +22,146,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,90,144,42, +11,89,146,42,39,11,248,22,136,16,23,197,1,86,95,23,195,1,23,194,1, +28,248,22,179,15,23,194,2,28,248,22,128,16,23,194,2,249,22,146,6,23, +195,1,32,0,88,148,8,36,39,44,11,9,222,11,90,144,42,11,89,146,42, +39,11,248,22,136,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22,179, +15,23,194,2,28,248,22,128,16,23,194,2,249,22,146,6,23,195,1,32,0, +88,148,8,36,39,44,11,9,222,11,90,144,42,11,89,146,42,39,11,248,22, +136,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22,179,15,23,194,2, +28,248,22,128,16,23,194,2,249,22,146,6,23,195,1,32,0,88,148,8,36, +39,44,11,9,222,11,248,2,126,23,194,1,11,11,11,11,11,28,248,22,191, +15,23,195,2,27,28,249,22,190,8,248,22,181,8,2,62,41,249,22,146,6, +23,197,2,32,0,88,148,8,36,39,44,11,9,222,11,11,86,94,28,23,194, +2,248,22,148,6,23,195,1,86,94,23,194,1,12,249,22,81,27,248,22,189, +5,23,199,1,250,22,44,22,35,88,148,39,39,8,24,11,9,223,3,33,130, +2,20,20,94,88,148,8,36,39,46,11,9,223,3,33,131,2,23,196,1,194, +249,22,81,11,194,28,28,23,195,2,28,248,22,83,23,196,2,248,22,168,9, +249,22,177,14,39,248,22,171,20,23,199,2,11,11,194,86,94,23,195,1,249, +22,12,20,20,94,88,148,8,32,39,61,16,4,39,8,128,80,8,240,0,64, +0,0,39,9,224,2,3,33,132,2,23,196,1,80,144,41,8,26,41,27,248, +22,168,9,194,28,192,192,248,22,168,9,248,22,82,195,86,95,28,248,22,152, +12,23,198,2,27,247,22,144,12,28,249,22,134,12,23,195,2,2,63,251,22, +140,12,23,197,1,2,63,250,22,138,8,6,42,42,101,114,114,111,114,32,114, +101,97,100,105,110,103,32,99,111,108,108,101,99,116,105,111,110,32,108,105,110, +107,115,32,102,105,108,101,32,126,115,58,32,126,97,23,203,2,248,22,148,12, +23,206,2,247,22,27,12,12,28,23,193,2,250,22,157,2,80,144,45,8,25, +41,23,198,1,249,22,81,23,198,1,21,17,0,0,86,95,23,195,1,23,193, +1,12,28,248,22,152,12,23,198,2,86,94,23,197,1,248,23,195,1,247,22, +139,2,196,88,148,39,40,58,8,240,0,0,0,2,9,226,0,2,1,3,33, +135,2,20,20,94,248,22,149,6,23,194,2,28,248,22,149,7,248,22,149,6, +23,195,1,12,248,22,179,11,6,30,30,101,120,112,101,99,116,101,100,32,97, +32,115,105,110,103,108,101,32,83,45,101,120,112,114,101,115,115,105,111,110,248, +22,134,6,23,194,1,28,248,22,90,193,28,28,249,22,129,4,41,248,22,94, +195,10,249,22,129,4,42,248,22,94,195,28,28,248,22,154,7,248,22,82,194, +10,28,249,22,170,9,2,64,248,22,170,20,195,10,249,22,170,9,2,65,248, +22,170,20,195,28,27,248,22,103,194,28,248,22,179,15,193,10,28,248,22,154, +7,193,28,248,22,138,16,193,10,248,22,139,16,193,11,27,248,22,89,248,22, +105,195,28,192,192,248,22,185,16,248,22,112,195,11,11,11,11,28,248,22,128, +16,249,22,133,16,23,196,2,23,198,2,27,248,22,69,248,22,183,15,23,198, +1,250,22,157,2,23,198,2,23,196,2,249,22,81,23,199,1,250,22,159,2, +23,203,1,23,201,1,9,12,250,22,157,2,23,197,1,23,198,1,249,22,81, +23,198,1,23,201,1,28,28,248,22,89,248,22,105,23,197,2,10,249,22,176, +16,248,22,112,23,198,2,247,22,172,8,27,248,22,143,16,249,22,141,16,248, +22,103,23,200,2,23,198,1,28,249,22,170,9,248,22,170,20,23,199,2,2, +65,86,94,23,196,1,249,22,3,20,20,94,88,148,8,36,40,56,11,9,224, +3,2,33,140,2,23,196,1,248,22,146,16,23,196,1,28,249,22,170,9,248, +22,170,20,23,199,2,2,64,86,94,23,196,1,86,94,28,250,22,159,2,23, +197,2,11,11,12,250,22,157,2,23,197,2,11,9,249,22,165,2,23,196,2, +20,20,95,88,148,8,36,41,53,11,9,224,3,2,33,141,2,23,195,1,23, +196,1,27,248,22,69,248,22,170,20,23,199,1,250,22,157,2,23,198,2,23, +196,2,249,22,81,248,22,130,2,23,200,1,250,22,159,2,23,203,1,23,201, +1,9,12,250,22,157,2,23,196,1,23,197,1,248,22,96,23,199,1,27,28, +28,23,194,2,248,22,168,9,248,22,82,23,196,2,10,9,27,249,22,189,5, +23,198,2,68,98,105,110,97,114,121,250,22,44,22,35,88,148,8,36,39,47, +11,9,223,3,33,137,2,20,20,94,88,148,8,36,39,46,11,9,223,3,33, +138,2,23,196,1,86,94,28,28,248,22,90,23,194,2,249,22,4,32,0,88, +148,8,36,40,48,11,9,222,33,139,2,23,195,2,11,12,248,22,179,11,6, +18,18,105,108,108,45,102,111,114,109,101,100,32,99,111,110,116,101,110,116,27, +247,22,139,2,27,90,144,42,11,89,146,42,39,11,248,22,136,16,23,201,2, +192,86,96,249,22,3,20,20,94,88,148,8,36,40,57,11,9,224,2,3,33, +142,2,23,195,1,23,197,1,249,22,165,2,195,88,148,8,36,41,51,11,9, +223,3,33,143,2,250,22,157,2,80,144,47,8,25,41,23,200,1,249,22,81, +23,201,1,198,193,20,13,144,80,144,40,8,28,40,250,80,144,43,8,47,42, +23,198,2,23,196,2,11,27,250,22,159,2,80,144,44,8,25,41,23,197,2, +21,143,11,17,0,0,27,248,22,82,23,195,2,27,249,80,144,45,8,27,42, +23,198,2,23,196,2,28,249,22,172,9,23,195,2,23,196,1,248,22,171,20, +195,86,94,23,195,1,20,13,144,80,144,43,8,28,40,250,80,144,46,8,47, +42,23,201,1,23,199,2,23,196,2,27,20,20,95,88,148,8,36,39,55,8, +240,0,0,0,2,9,225,5,4,1,33,144,2,23,194,1,23,197,1,28,249, +22,48,23,195,2,39,20,13,144,80,144,44,46,40,26,35,80,144,8,40,47, +40,249,22,31,11,80,144,8,42,46,40,22,146,15,10,22,147,15,10,22,148, +15,10,22,149,15,11,22,150,15,11,22,154,15,10,22,153,15,11,22,155,15, +10,22,152,15,10,22,156,15,10,22,151,15,11,22,157,15,10,22,158,15,10, +22,159,15,10,22,160,15,11,22,161,15,10,22,144,15,11,247,23,193,1,250, +22,183,11,2,9,2,52,23,196,1,248,22,8,20,20,94,88,148,39,40,8, +49,16,4,8,128,6,8,128,104,8,240,0,128,0,0,39,9,224,1,2,33, +145,2,23,195,1,0,7,35,114,120,34,47,43,34,28,248,22,154,7,23,195, +2,27,249,22,174,16,2,147,2,23,197,2,28,23,193,2,28,249,22,129,4, +248,22,102,23,196,2,248,22,183,3,248,22,157,7,23,199,2,249,22,7,250, +22,176,7,23,200,1,39,248,22,102,23,199,1,23,198,1,249,22,7,250,22, +176,7,23,200,2,39,248,22,102,23,199,2,249,22,81,249,22,176,7,23,201, +1,248,22,104,23,200,1,23,200,1,86,94,23,193,1,249,22,7,23,197,1, +23,198,1,90,144,42,11,89,146,42,39,11,248,22,136,16,23,198,1,86,94, +23,195,1,28,249,22,170,9,23,195,2,2,49,86,94,23,193,1,249,22,7, +23,196,1,23,200,1,27,249,22,81,23,197,1,23,201,1,28,248,22,154,7, +23,195,2,27,249,22,174,16,2,147,2,23,197,2,28,23,193,2,28,249,22, +129,4,248,22,102,23,196,2,248,22,183,3,248,22,157,7,23,199,2,249,22, +7,250,22,176,7,23,200,1,39,248,22,102,23,199,1,23,196,1,249,22,7, +250,22,176,7,23,200,2,39,248,22,102,23,199,2,249,22,81,249,22,176,7, +23,201,1,248,22,104,23,200,1,23,198,1,86,94,23,193,1,249,22,7,23, +197,1,23,196,1,90,144,42,11,89,146,42,39,11,248,22,136,16,23,198,1, +86,94,23,195,1,28,249,22,170,9,23,195,2,2,49,86,94,23,193,1,249, +22,7,23,196,1,23,198,1,249,80,144,48,8,31,42,194,249,22,81,197,199, +28,248,22,89,23,196,2,9,28,248,22,82,23,196,2,28,248,22,150,2,248, +22,170,20,23,197,2,250,22,95,249,22,2,22,130,2,250,22,159,2,248,22, +170,20,23,204,2,23,202,2,9,250,22,159,2,248,22,170,20,23,202,2,11, +9,27,248,22,171,20,23,200,1,28,248,22,89,23,194,2,9,28,248,22,82, +23,194,2,28,248,22,150,2,248,22,170,20,23,195,2,250,22,95,249,22,2, +22,130,2,250,22,159,2,248,22,170,20,23,202,2,23,206,2,9,250,22,159, +2,248,22,170,20,23,200,2,11,9,249,80,144,48,8,48,42,23,203,1,248, +22,171,20,23,199,1,27,248,80,144,45,8,30,42,248,22,170,20,23,196,2, +250,22,95,250,22,159,2,23,199,2,23,205,2,9,250,22,159,2,23,199,1, +11,9,249,80,144,49,8,48,42,23,204,1,248,22,171,20,23,200,1,249,22, +95,247,22,160,16,249,80,144,47,8,48,42,23,202,1,248,22,171,20,23,198, +1,27,248,80,144,41,8,30,42,248,22,170,20,23,198,2,250,22,95,250,22, +159,2,23,199,2,23,201,2,9,250,22,159,2,23,199,1,11,9,27,248,22, +171,20,23,201,1,28,248,22,89,23,194,2,9,28,248,22,82,23,194,2,28, +248,22,150,2,248,22,170,20,23,195,2,250,22,95,249,22,2,22,130,2,250, +22,159,2,248,22,170,20,23,202,2,23,207,2,9,250,22,159,2,248,22,170, +20,23,200,2,11,9,249,80,144,49,8,48,42,23,204,1,248,22,171,20,23, +199,1,27,248,80,144,46,8,30,42,248,22,170,20,23,196,2,250,22,95,250, +22,159,2,23,199,2,23,206,2,9,250,22,159,2,23,199,1,11,9,249,80, +144,50,8,48,42,23,205,1,248,22,171,20,23,200,1,249,22,95,247,22,160, +16,249,80,144,48,8,48,42,23,203,1,248,22,171,20,23,198,1,249,22,95, +247,22,160,16,27,248,22,171,20,23,199,1,28,248,22,89,23,194,2,9,28, +248,22,82,23,194,2,28,248,22,150,2,248,22,170,20,23,195,2,250,22,95, +249,22,2,22,130,2,250,22,159,2,248,22,170,20,23,202,2,23,205,2,9, +250,22,159,2,248,22,170,20,23,200,2,11,9,249,80,144,47,8,48,42,23, +202,1,248,22,171,20,23,199,1,27,248,80,144,44,8,30,42,248,22,170,20, +23,196,2,250,22,95,250,22,159,2,23,199,2,23,204,2,9,250,22,159,2, +23,199,1,11,9,249,80,144,48,8,48,42,23,203,1,248,22,171,20,23,200, +1,249,22,95,247,22,160,16,249,80,144,46,8,48,42,23,201,1,248,22,171, +20,23,198,1,32,150,2,88,148,8,36,40,50,11,2,50,222,33,151,2,28, +248,22,89,248,22,83,23,195,2,248,22,91,27,248,22,170,20,195,28,248,22, +179,15,193,248,22,183,15,193,192,250,22,92,27,248,22,170,20,23,198,2,28, +248,22,179,15,193,248,22,183,15,193,192,2,67,248,2,150,2,248,22,171,20, +23,198,1,250,22,138,8,6,7,7,10,32,126,97,32,126,97,6,1,1,32, +23,196,1,249,22,138,8,6,6,6,10,32,32,32,126,97,248,22,133,2,23, +196,1,32,154,2,88,148,39,41,51,11,68,102,105,108,116,101,114,222,33,155, +2,28,248,22,89,23,195,2,9,28,248,23,194,2,248,22,82,23,196,2,249, +22,81,248,22,170,20,23,197,2,249,2,154,2,23,197,1,248,22,171,20,23, +199,1,249,2,154,2,23,195,1,248,22,171,20,23,197,1,28,248,22,89,23, +201,2,86,95,23,200,1,23,199,1,28,23,201,2,28,197,249,22,133,16,202, +199,200,86,95,23,201,1,23,198,1,27,28,248,22,89,23,198,2,2,66,249, +22,1,22,177,7,248,2,150,2,23,200,2,248,23,199,1,251,22,138,8,6, +70,70,99,111,108,108,101,99,116,105,111,110,32,110,111,116,32,102,111,117,110, +100,10,32,32,99,111,108,108,101,99,116,105,111,110,58,32,126,115,10,32,32, +105,110,32,99,111,108,108,101,99,116,105,111,110,32,100,105,114,101,99,116,111, +114,105,101,115,58,126,97,126,97,28,248,22,89,23,203,1,28,248,22,179,15, +23,202,2,248,22,183,15,23,202,1,23,201,1,250,22,177,7,28,248,22,179, +15,23,205,2,248,22,183,15,23,205,1,23,204,1,2,67,23,201,2,249,22, +1,22,177,7,249,22,2,32,0,88,148,8,36,40,48,11,9,222,33,152,2, +27,248,22,94,23,206,2,27,248,22,94,247,22,160,16,28,249,22,130,4,249, +22,185,3,23,198,2,23,197,2,44,23,206,2,249,22,95,247,22,160,16,248, +22,91,249,22,138,8,6,50,50,46,46,46,32,91,126,97,32,97,100,100,105, +116,105,111,110,97,108,32,108,105,110,107,101,100,32,97,110,100,32,112,97,99, +107,97,103,101,32,100,105,114,101,99,116,111,114,105,101,115,93,249,22,185,3, +23,201,1,23,200,1,28,249,22,5,22,132,2,23,202,2,250,22,138,8,6, +49,49,10,32,32,32,115,117,98,45,99,111,108,108,101,99,116,105,111,110,58, +32,126,115,10,32,32,105,110,32,112,97,114,101,110,116,32,100,105,114,101,99, +116,111,114,105,101,115,58,126,97,23,201,1,249,22,1,22,177,7,249,22,2, +32,0,88,148,8,36,40,48,11,9,222,33,153,2,249,2,154,2,22,132,2, +23,209,1,86,95,23,200,1,23,198,1,2,66,27,248,22,82,23,202,2,27, +28,248,22,179,15,23,195,2,249,22,133,16,23,196,1,23,199,2,248,22,133, +2,23,195,1,28,28,248,22,179,15,248,22,170,20,23,204,2,248,22,128,16, +23,194,2,10,27,250,22,1,22,133,16,23,197,1,23,202,2,28,28,248,22, +89,23,200,2,10,248,22,128,16,23,194,2,28,23,201,2,28,28,250,80,144, +45,8,32,42,195,203,204,10,27,28,248,22,179,15,202,248,22,183,15,202,201, +19,248,22,157,7,23,195,2,27,28,249,22,133,4,23,196,4,43,28,249,22, +160,7,6,4,4,46,114,107,116,249,22,176,7,23,199,2,249,22,185,3,23, +200,4,43,249,22,177,7,250,22,176,7,23,200,1,39,249,22,185,3,23,201, +4,43,6,3,3,46,115,115,86,94,23,195,1,11,86,94,23,195,1,11,28, 23,193,2,250,80,144,48,8,32,42,198,23,196,1,23,15,11,2,28,200,249, -22,129,16,194,202,192,26,8,80,144,50,8,49,42,204,205,206,23,15,23,16, -23,17,248,22,165,20,23,19,28,23,19,23,19,200,192,26,8,80,144,50,8, -49,42,204,205,206,23,15,23,16,23,17,248,22,165,20,23,19,23,19,26,8, -80,144,49,8,49,42,203,204,205,206,23,15,23,16,248,22,165,20,23,18,23, +22,133,16,194,202,192,26,8,80,144,50,8,49,42,204,205,206,23,15,23,16, +23,17,248,22,171,20,23,19,28,23,19,23,19,200,192,26,8,80,144,50,8, +49,42,204,205,206,23,15,23,16,23,17,248,22,171,20,23,19,23,19,26,8, +80,144,49,8,49,42,203,204,205,206,23,15,23,16,248,22,171,20,23,18,23, 18,90,144,41,11,89,146,41,39,11,249,80,144,43,8,31,42,23,199,1,23, -200,1,27,248,22,68,28,248,22,175,15,195,248,22,179,15,195,194,27,27,247, -22,157,16,28,248,22,88,23,194,2,9,28,248,22,81,23,194,2,28,248,22, -149,2,248,22,164,20,23,195,2,250,22,94,249,22,2,22,129,2,250,22,158, -2,248,22,164,20,23,202,2,23,203,2,9,250,22,158,2,248,22,164,20,23, -200,2,11,9,249,80,144,49,8,48,42,23,200,1,248,22,165,20,23,199,1, -27,248,80,144,46,8,30,42,248,22,164,20,23,196,2,250,22,94,250,22,158, -2,23,199,2,23,202,2,9,250,22,158,2,23,199,1,11,9,249,80,144,50, -8,48,42,23,201,1,248,22,165,20,23,200,1,249,22,94,247,22,156,16,249, -80,144,48,8,48,42,23,199,1,248,22,165,20,23,198,1,26,8,80,144,51, +200,1,27,248,22,69,28,248,22,179,15,195,248,22,183,15,195,194,27,27,247, +22,161,16,28,248,22,89,23,194,2,9,28,248,22,82,23,194,2,28,248,22, +150,2,248,22,170,20,23,195,2,250,22,95,249,22,2,22,130,2,250,22,159, +2,248,22,170,20,23,202,2,23,203,2,9,250,22,159,2,248,22,170,20,23, +200,2,11,9,249,80,144,49,8,48,42,23,200,1,248,22,171,20,23,199,1, +27,248,80,144,46,8,30,42,248,22,170,20,23,196,2,250,22,95,250,22,159, +2,23,199,2,23,202,2,9,250,22,159,2,23,199,1,11,9,249,80,144,50, +8,48,42,23,201,1,248,22,171,20,23,200,1,249,22,95,247,22,160,16,249, +80,144,48,8,48,42,23,199,1,248,22,171,20,23,198,1,26,8,80,144,51, 8,49,42,200,202,203,205,23,16,23,17,200,11,32,158,2,88,148,8,36,42, -59,11,2,50,222,33,159,2,28,248,22,133,4,23,196,2,86,94,23,195,1, -19,248,22,147,8,23,195,2,19,248,22,147,8,23,196,2,249,22,185,15,27, -251,22,154,8,250,22,153,8,23,205,2,39,23,204,4,2,51,249,22,153,8, -23,204,1,23,202,4,2,68,28,248,22,133,4,248,22,147,8,23,195,2,86, -94,23,193,1,251,22,184,11,2,37,2,69,2,70,202,192,28,248,22,176,15, -198,248,22,177,15,198,247,22,178,15,2,2,27,248,22,182,3,23,197,1,28, -249,22,169,9,8,46,249,22,148,8,23,198,2,23,197,2,27,248,22,181,3, -23,195,2,249,22,185,15,27,251,22,154,8,250,22,153,8,23,205,2,39,23, -204,1,2,71,249,22,153,8,23,204,1,23,202,1,2,68,28,248,22,133,4, -248,22,147,8,23,195,2,86,94,23,193,1,251,22,184,11,2,37,2,69,2, -70,202,192,28,248,22,176,15,198,248,22,177,15,198,247,22,178,15,250,2,158, -2,196,197,195,248,22,187,15,27,250,22,129,16,23,200,1,23,202,1,23,199, -1,28,249,22,169,9,23,197,2,66,115,97,109,101,192,28,248,22,134,16,23, -196,2,249,22,129,16,194,196,249,80,144,46,42,42,23,195,1,23,197,1,249, +59,11,2,50,222,33,159,2,28,248,22,134,4,23,196,2,86,94,23,195,1, +19,248,22,148,8,23,195,2,19,248,22,148,8,23,196,2,249,22,189,15,27, +251,22,155,8,250,22,154,8,23,205,2,39,23,204,4,2,51,249,22,154,8, +23,204,1,23,202,4,2,68,28,248,22,134,4,248,22,148,8,23,195,2,86, +94,23,193,1,251,22,185,11,2,37,2,69,2,70,202,192,28,248,22,180,15, +198,248,22,181,15,198,247,22,182,15,2,2,27,248,22,183,3,23,197,1,28, +249,22,170,9,8,46,249,22,149,8,23,198,2,23,197,2,27,248,22,182,3, +23,195,2,249,22,189,15,27,251,22,155,8,250,22,154,8,23,205,2,39,23, +204,1,2,71,249,22,154,8,23,204,1,23,202,1,2,68,28,248,22,134,4, +248,22,148,8,23,195,2,86,94,23,193,1,251,22,185,11,2,37,2,69,2, +70,202,192,28,248,22,180,15,198,248,22,181,15,198,247,22,182,15,250,2,158, +2,196,197,195,248,22,191,15,27,250,22,133,16,23,200,1,23,202,1,23,199, +1,28,249,22,170,9,23,197,2,66,115,97,109,101,192,28,248,22,138,16,23, +196,2,249,22,133,16,194,196,249,80,144,46,42,42,23,195,1,23,197,1,249, 22,5,20,20,96,88,148,39,40,54,47,9,226,5,4,2,6,33,160,2,23, -199,1,23,195,1,23,197,1,23,196,1,27,248,22,187,15,249,22,129,16,23, +199,1,23,195,1,23,197,1,23,196,1,27,248,22,191,15,249,22,133,16,23, 198,2,23,199,2,28,23,193,2,192,86,94,23,193,1,28,23,197,1,27,90, 144,41,11,89,146,41,39,11,250,80,144,46,8,34,42,23,202,2,2,68,2, -37,27,248,22,181,15,23,196,1,27,250,2,158,2,23,197,2,23,204,1,248, -22,147,8,23,198,1,28,248,22,176,15,195,249,22,129,16,196,194,192,27,247, -22,158,16,249,22,5,20,20,96,88,148,39,40,51,47,9,226,5,6,2,3, -33,161,2,23,196,1,23,195,1,23,199,1,247,22,159,16,11,86,95,28,28, -248,22,176,15,23,194,2,10,28,248,22,175,15,23,194,2,10,28,248,22,153, -7,23,194,2,28,248,22,134,16,23,194,2,10,248,22,135,16,23,194,2,11, -12,252,22,182,11,23,200,2,2,42,39,23,198,2,23,199,2,28,28,248,22, -153,7,23,195,2,10,248,22,142,8,23,195,2,86,94,23,194,1,12,252,22, -182,11,23,200,2,2,72,40,23,198,2,23,199,1,90,144,42,11,89,146,42, -39,11,248,22,132,16,23,197,2,86,94,23,195,1,86,94,28,23,193,2,86, -95,23,198,1,23,196,1,12,250,22,185,11,23,201,1,2,73,23,199,1,249, +37,27,248,22,185,15,23,196,1,27,250,2,158,2,23,197,2,23,204,1,248, +22,148,8,23,198,1,28,248,22,180,15,195,249,22,133,16,196,194,192,27,247, +22,162,16,249,22,5,20,20,96,88,148,39,40,51,47,9,226,5,6,2,3, +33,161,2,23,196,1,23,195,1,23,199,1,247,22,163,16,11,86,95,28,28, +248,22,180,15,23,194,2,10,28,248,22,179,15,23,194,2,10,28,248,22,154, +7,23,194,2,28,248,22,138,16,23,194,2,10,248,22,139,16,23,194,2,11, +12,252,22,183,11,23,200,2,2,42,39,23,198,2,23,199,2,28,28,248,22, +154,7,23,195,2,10,248,22,143,8,23,195,2,86,94,23,194,1,12,252,22, +183,11,23,200,2,2,72,40,23,198,2,23,199,1,90,144,42,11,89,146,42, +39,11,248,22,136,16,23,197,2,86,94,23,195,1,86,94,28,23,193,2,86, +95,23,198,1,23,196,1,12,250,22,186,11,23,201,1,2,73,23,199,1,249, 22,7,23,195,1,23,196,1,32,164,2,88,148,8,36,46,61,11,2,74,222, -33,165,2,249,22,185,15,27,251,22,154,8,250,22,153,8,23,203,2,39,23, -207,1,23,205,1,249,23,203,1,23,202,1,23,208,1,28,248,22,153,7,23, -204,2,249,22,168,8,23,205,1,8,63,23,203,1,28,248,22,133,4,248,22, -147,8,23,195,2,86,94,23,193,1,251,22,184,11,2,37,2,69,2,70,201, -192,28,248,22,176,15,197,248,22,177,15,197,247,22,178,15,32,166,2,88,148, -8,36,45,8,24,11,2,50,222,33,167,2,28,248,22,133,4,23,199,2,86, -95,23,198,1,23,194,1,19,248,22,147,8,23,195,2,19,248,22,147,8,23, -196,2,249,22,185,15,27,251,22,154,8,250,22,153,8,23,205,2,39,23,204, -4,2,51,249,23,206,1,23,204,1,23,202,4,28,248,22,153,7,23,207,2, -249,22,168,8,23,208,1,8,63,23,206,1,28,248,22,133,4,248,22,147,8, -23,195,2,86,94,23,193,1,251,22,184,11,2,37,2,69,2,70,204,192,28, -248,22,176,15,200,248,22,177,15,200,247,22,178,15,2,2,27,248,22,182,3, -23,200,1,28,249,22,169,9,8,46,249,22,148,8,23,198,2,23,197,2,27, -248,22,181,3,23,195,2,249,22,185,15,27,251,22,154,8,250,22,153,8,23, +33,165,2,249,22,189,15,27,251,22,155,8,250,22,154,8,23,203,2,39,23, +207,1,23,205,1,249,23,203,1,23,202,1,23,208,1,28,248,22,154,7,23, +204,2,249,22,169,8,23,205,1,8,63,23,203,1,28,248,22,134,4,248,22, +148,8,23,195,2,86,94,23,193,1,251,22,185,11,2,37,2,69,2,70,201, +192,28,248,22,180,15,197,248,22,181,15,197,247,22,182,15,32,166,2,88,148, +8,36,45,8,24,11,2,50,222,33,167,2,28,248,22,134,4,23,199,2,86, +95,23,198,1,23,194,1,19,248,22,148,8,23,195,2,19,248,22,148,8,23, +196,2,249,22,189,15,27,251,22,155,8,250,22,154,8,23,205,2,39,23,204, +4,2,51,249,23,206,1,23,204,1,23,202,4,28,248,22,154,7,23,207,2, +249,22,169,8,23,208,1,8,63,23,206,1,28,248,22,134,4,248,22,148,8, +23,195,2,86,94,23,193,1,251,22,185,11,2,37,2,69,2,70,204,192,28, +248,22,180,15,200,248,22,181,15,200,247,22,182,15,2,2,27,248,22,183,3, +23,200,1,28,249,22,170,9,8,46,249,22,149,8,23,198,2,23,197,2,27, +248,22,182,3,23,195,2,249,22,189,15,27,251,22,155,8,250,22,154,8,23, 205,2,39,23,204,1,23,203,1,249,23,206,1,23,204,1,23,202,1,28,248, -22,153,7,23,207,2,249,22,168,8,23,208,1,8,63,23,206,1,28,248,22, -133,4,248,22,147,8,23,195,2,86,94,23,193,1,251,22,184,11,2,37,2, -69,2,70,204,192,28,248,22,176,15,200,248,22,177,15,200,247,22,178,15,28, -248,22,133,4,23,194,2,86,95,23,195,1,23,193,1,19,248,22,147,8,23, -196,2,19,248,22,147,8,23,197,2,249,22,185,15,27,251,22,154,8,250,22, -153,8,23,206,2,39,23,204,4,2,51,249,23,207,1,23,205,1,23,202,4, -28,248,22,153,7,23,208,2,249,22,168,8,23,209,1,8,63,23,207,1,28, -248,22,133,4,248,22,147,8,23,195,2,86,94,23,193,1,251,22,184,11,2, -37,2,69,2,70,205,192,28,248,22,176,15,201,248,22,177,15,201,247,22,178, -15,2,2,27,248,22,182,3,23,195,1,28,249,22,169,9,8,46,249,22,148, -8,23,199,2,23,197,2,27,248,22,181,3,23,195,2,249,22,185,15,27,251, -22,154,8,250,22,153,8,23,206,2,39,23,204,1,23,204,1,249,23,207,1, -23,205,1,23,202,1,28,248,22,153,7,23,208,2,249,22,168,8,23,209,1, -8,63,23,207,1,28,248,22,133,4,248,22,147,8,23,195,2,86,94,23,193, -1,251,22,184,11,2,37,2,69,2,70,205,192,28,248,22,176,15,201,248,22, -177,15,201,247,22,178,15,28,248,22,133,4,193,254,2,164,2,201,203,204,205, -248,22,147,8,202,2,51,248,22,147,8,202,27,248,22,182,3,194,28,249,22, -169,9,8,46,249,22,148,8,199,196,254,2,164,2,202,204,205,206,199,203,248, -22,181,3,200,253,2,166,2,201,202,203,204,205,198,90,144,41,11,89,146,41, -39,11,86,95,28,28,248,22,176,15,23,199,2,10,28,248,22,175,15,23,199, -2,10,28,248,22,153,7,23,199,2,28,248,22,134,16,23,199,2,10,248,22, -135,16,23,199,2,11,12,252,22,182,11,23,200,2,2,42,39,23,203,2,23, -204,2,28,28,248,22,153,7,23,200,2,10,248,22,142,8,23,200,2,12,252, -22,182,11,23,200,2,2,72,40,23,203,2,23,204,2,90,144,42,11,89,146, -42,39,11,248,22,132,16,23,202,2,86,94,23,195,1,86,94,28,192,12,250, -22,185,11,23,201,1,2,73,23,204,2,249,22,7,194,195,27,248,22,181,15, -23,196,1,27,19,248,22,147,8,23,196,2,28,248,22,133,4,23,194,4,86, -94,23,199,1,19,248,22,147,8,23,197,2,19,248,22,147,8,23,198,2,249, -22,185,15,27,251,22,154,8,250,22,153,8,23,207,2,39,23,204,4,2,51, -249,23,211,1,23,206,1,23,202,4,28,248,22,153,7,23,212,2,249,22,168, -8,23,213,1,8,63,23,211,1,28,248,22,133,4,248,22,147,8,23,195,2, -86,94,23,193,1,251,22,184,11,2,37,2,69,2,70,23,17,192,28,248,22, -176,15,205,248,22,177,15,205,247,22,178,15,2,2,27,248,22,182,3,23,195, -4,28,249,22,169,9,8,46,249,22,148,8,23,200,2,23,197,2,27,248,22, -181,3,23,195,2,249,22,185,15,27,251,22,154,8,250,22,153,8,23,207,2, -39,23,204,1,23,208,1,249,23,211,1,23,206,1,23,202,1,28,248,22,153, -7,23,212,2,249,22,168,8,23,213,1,8,63,23,211,1,28,248,22,133,4, -248,22,147,8,23,195,2,86,94,23,193,1,251,22,184,11,2,37,2,69,2, -70,23,17,192,28,248,22,176,15,205,248,22,177,15,205,247,22,178,15,28,248, -22,133,4,23,194,2,86,95,23,200,1,23,193,1,254,2,164,2,23,203,2, -23,208,1,23,209,1,23,210,1,248,22,147,8,23,204,2,2,51,248,22,147, -8,23,204,1,27,248,22,182,3,23,195,1,28,249,22,169,9,8,46,249,22, -148,8,23,201,2,23,197,2,254,2,164,2,23,204,1,23,209,1,23,210,1, -23,211,1,23,200,2,23,208,1,248,22,181,3,23,201,1,253,2,166,2,23, +22,154,7,23,207,2,249,22,169,8,23,208,1,8,63,23,206,1,28,248,22, +134,4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,185,11,2,37,2, +69,2,70,204,192,28,248,22,180,15,200,248,22,181,15,200,247,22,182,15,28, +248,22,134,4,23,194,2,86,95,23,195,1,23,193,1,19,248,22,148,8,23, +196,2,19,248,22,148,8,23,197,2,249,22,189,15,27,251,22,155,8,250,22, +154,8,23,206,2,39,23,204,4,2,51,249,23,207,1,23,205,1,23,202,4, +28,248,22,154,7,23,208,2,249,22,169,8,23,209,1,8,63,23,207,1,28, +248,22,134,4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,185,11,2, +37,2,69,2,70,205,192,28,248,22,180,15,201,248,22,181,15,201,247,22,182, +15,2,2,27,248,22,183,3,23,195,1,28,249,22,170,9,8,46,249,22,149, +8,23,199,2,23,197,2,27,248,22,182,3,23,195,2,249,22,189,15,27,251, +22,155,8,250,22,154,8,23,206,2,39,23,204,1,23,204,1,249,23,207,1, +23,205,1,23,202,1,28,248,22,154,7,23,208,2,249,22,169,8,23,209,1, +8,63,23,207,1,28,248,22,134,4,248,22,148,8,23,195,2,86,94,23,193, +1,251,22,185,11,2,37,2,69,2,70,205,192,28,248,22,180,15,201,248,22, +181,15,201,247,22,182,15,28,248,22,134,4,193,254,2,164,2,201,203,204,205, +248,22,148,8,202,2,51,248,22,148,8,202,27,248,22,183,3,194,28,249,22, +170,9,8,46,249,22,149,8,199,196,254,2,164,2,202,204,205,206,199,203,248, +22,182,3,200,253,2,166,2,201,202,203,204,205,198,90,144,41,11,89,146,41, +39,11,86,95,28,28,248,22,180,15,23,199,2,10,28,248,22,179,15,23,199, +2,10,28,248,22,154,7,23,199,2,28,248,22,138,16,23,199,2,10,248,22, +139,16,23,199,2,11,12,252,22,183,11,23,200,2,2,42,39,23,203,2,23, +204,2,28,28,248,22,154,7,23,200,2,10,248,22,143,8,23,200,2,12,252, +22,183,11,23,200,2,2,72,40,23,203,2,23,204,2,90,144,42,11,89,146, +42,39,11,248,22,136,16,23,202,2,86,94,23,195,1,86,94,28,192,12,250, +22,186,11,23,201,1,2,73,23,204,2,249,22,7,194,195,27,248,22,185,15, +23,196,1,27,19,248,22,148,8,23,196,2,28,248,22,134,4,23,194,4,86, +94,23,199,1,19,248,22,148,8,23,197,2,19,248,22,148,8,23,198,2,249, +22,189,15,27,251,22,155,8,250,22,154,8,23,207,2,39,23,204,4,2,51, +249,23,211,1,23,206,1,23,202,4,28,248,22,154,7,23,212,2,249,22,169, +8,23,213,1,8,63,23,211,1,28,248,22,134,4,248,22,148,8,23,195,2, +86,94,23,193,1,251,22,185,11,2,37,2,69,2,70,23,17,192,28,248,22, +180,15,205,248,22,181,15,205,247,22,182,15,2,2,27,248,22,183,3,23,195, +4,28,249,22,170,9,8,46,249,22,149,8,23,200,2,23,197,2,27,248,22, +182,3,23,195,2,249,22,189,15,27,251,22,155,8,250,22,154,8,23,207,2, +39,23,204,1,23,208,1,249,23,211,1,23,206,1,23,202,1,28,248,22,154, +7,23,212,2,249,22,169,8,23,213,1,8,63,23,211,1,28,248,22,134,4, +248,22,148,8,23,195,2,86,94,23,193,1,251,22,185,11,2,37,2,69,2, +70,23,17,192,28,248,22,180,15,205,248,22,181,15,205,247,22,182,15,28,248, +22,134,4,23,194,2,86,95,23,200,1,23,193,1,254,2,164,2,23,203,2, +23,208,1,23,209,1,23,210,1,248,22,148,8,23,204,2,2,51,248,22,148, +8,23,204,1,27,248,22,183,3,23,195,1,28,249,22,170,9,8,46,249,22, +149,8,23,201,2,23,197,2,254,2,164,2,23,204,1,23,209,1,23,210,1, +23,211,1,23,200,2,23,208,1,248,22,182,3,23,201,1,253,2,166,2,23, 203,1,23,207,1,23,208,1,23,209,1,23,210,1,23,199,1,2,28,248,22, -176,15,195,249,22,129,16,196,194,192,32,169,2,88,148,8,36,43,61,11,2, -50,222,33,170,2,28,248,22,133,4,23,197,2,86,94,23,196,1,19,248,22, -147,8,23,195,2,35,248,22,147,8,23,196,2,249,22,185,15,27,251,22,154, -8,250,22,153,8,23,205,1,39,23,204,4,2,51,2,51,28,248,22,153,7, -23,205,2,249,22,168,8,23,206,1,8,63,23,204,1,28,248,22,133,4,248, -22,147,8,23,195,2,86,94,23,193,1,251,22,184,11,2,37,2,69,2,70, -202,192,28,248,22,176,15,198,248,22,177,15,198,247,22,178,15,2,27,248,22, -182,3,23,198,1,28,249,22,169,9,8,46,249,22,148,8,23,198,2,23,197, -2,35,248,22,181,3,23,195,2,249,22,185,15,27,251,22,154,8,250,22,153, -8,23,205,1,39,23,204,1,2,51,2,51,28,248,22,153,7,23,205,2,249, -22,168,8,23,206,1,8,63,23,204,1,28,248,22,133,4,248,22,147,8,23, -195,2,86,94,23,193,1,251,22,184,11,2,37,2,69,2,70,202,192,28,248, -22,176,15,198,248,22,177,15,198,247,22,178,15,28,248,22,133,4,23,194,2, -86,94,23,193,1,19,248,22,147,8,23,196,2,35,248,22,147,8,23,197,2, -249,22,185,15,27,251,22,154,8,250,22,153,8,23,206,1,39,23,204,4,2, -51,2,51,28,248,22,153,7,23,206,2,249,22,168,8,23,207,1,8,63,23, -205,1,28,248,22,133,4,248,22,147,8,23,195,2,86,94,23,193,1,251,22, -184,11,2,37,2,69,2,70,203,192,28,248,22,176,15,199,248,22,177,15,199, -247,22,178,15,2,27,248,22,182,3,23,195,1,28,249,22,169,9,8,46,249, -22,148,8,23,199,2,23,197,2,35,248,22,181,3,23,195,2,249,22,185,15, -27,251,22,154,8,250,22,153,8,23,206,1,39,23,204,1,2,51,2,51,28, -248,22,153,7,23,206,2,249,22,168,8,23,207,1,8,63,23,205,1,28,248, -22,133,4,248,22,147,8,23,195,2,86,94,23,193,1,251,22,184,11,2,37, -2,69,2,70,203,192,28,248,22,176,15,199,248,22,177,15,199,247,22,178,15, +180,15,195,249,22,133,16,196,194,192,32,169,2,88,148,8,36,43,61,11,2, +50,222,33,170,2,28,248,22,134,4,23,197,2,86,94,23,196,1,19,248,22, +148,8,23,195,2,35,248,22,148,8,23,196,2,249,22,189,15,27,251,22,155, +8,250,22,154,8,23,205,1,39,23,204,4,2,51,2,51,28,248,22,154,7, +23,205,2,249,22,169,8,23,206,1,8,63,23,204,1,28,248,22,134,4,248, +22,148,8,23,195,2,86,94,23,193,1,251,22,185,11,2,37,2,69,2,70, +202,192,28,248,22,180,15,198,248,22,181,15,198,247,22,182,15,2,27,248,22, +183,3,23,198,1,28,249,22,170,9,8,46,249,22,149,8,23,198,2,23,197, +2,35,248,22,182,3,23,195,2,249,22,189,15,27,251,22,155,8,250,22,154, +8,23,205,1,39,23,204,1,2,51,2,51,28,248,22,154,7,23,205,2,249, +22,169,8,23,206,1,8,63,23,204,1,28,248,22,134,4,248,22,148,8,23, +195,2,86,94,23,193,1,251,22,185,11,2,37,2,69,2,70,202,192,28,248, +22,180,15,198,248,22,181,15,198,247,22,182,15,28,248,22,134,4,23,194,2, +86,94,23,193,1,19,248,22,148,8,23,196,2,35,248,22,148,8,23,197,2, +249,22,189,15,27,251,22,155,8,250,22,154,8,23,206,1,39,23,204,4,2, +51,2,51,28,248,22,154,7,23,206,2,249,22,169,8,23,207,1,8,63,23, +205,1,28,248,22,134,4,248,22,148,8,23,195,2,86,94,23,193,1,251,22, +185,11,2,37,2,69,2,70,203,192,28,248,22,180,15,199,248,22,181,15,199, +247,22,182,15,2,27,248,22,183,3,23,195,1,28,249,22,170,9,8,46,249, +22,149,8,23,199,2,23,197,2,35,248,22,182,3,23,195,2,249,22,189,15, +27,251,22,155,8,250,22,154,8,23,206,1,39,23,204,1,2,51,2,51,28, +248,22,154,7,23,206,2,249,22,169,8,23,207,1,8,63,23,205,1,28,248, +22,134,4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,185,11,2,37, +2,69,2,70,203,192,28,248,22,180,15,199,248,22,181,15,199,247,22,182,15, 251,2,169,2,198,199,200,196,90,144,41,11,89,146,41,39,11,86,95,28,28, -248,22,176,15,23,196,2,10,28,248,22,175,15,23,196,2,10,28,248,22,153, -7,23,196,2,28,248,22,134,16,23,196,2,10,248,22,135,16,23,196,2,11, -12,252,22,182,11,2,37,2,42,39,23,200,2,23,201,2,28,28,248,22,153, -7,23,197,2,10,248,22,142,8,23,197,2,12,252,22,182,11,2,37,2,72, -40,23,200,2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,132,16,23, -199,2,86,94,23,195,1,86,94,28,192,12,250,22,185,11,2,37,2,73,23, -201,2,249,22,7,194,195,27,248,22,181,15,23,196,1,27,251,2,169,2,23, -198,2,23,201,1,23,202,1,248,22,147,8,23,199,1,28,248,22,176,15,195, -249,22,129,16,196,194,192,2,51,252,80,144,44,8,35,42,2,37,2,51,32, +248,22,180,15,23,196,2,10,28,248,22,179,15,23,196,2,10,28,248,22,154, +7,23,196,2,28,248,22,138,16,23,196,2,10,248,22,139,16,23,196,2,11, +12,252,22,183,11,2,37,2,42,39,23,200,2,23,201,2,28,28,248,22,154, +7,23,197,2,10,248,22,143,8,23,197,2,12,252,22,183,11,2,37,2,72, +40,23,200,2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,136,16,23, +199,2,86,94,23,195,1,86,94,28,192,12,250,22,186,11,2,37,2,73,23, +201,2,249,22,7,194,195,27,248,22,185,15,23,196,1,27,251,2,169,2,23, +198,2,23,201,1,23,202,1,248,22,148,8,23,199,1,28,248,22,180,15,195, +249,22,133,16,196,194,192,2,51,252,80,144,44,8,35,42,2,37,2,51,32, 0,88,148,8,36,41,46,11,9,222,33,172,2,198,199,32,174,2,88,148,8, 36,43,60,11,2,50,222,33,177,2,32,175,2,88,148,8,36,45,60,11,2, -74,222,33,176,2,249,22,185,15,27,251,22,154,8,250,22,153,8,23,203,2, -39,23,206,1,23,204,1,249,22,153,8,23,202,1,23,207,1,28,248,22,153, -7,23,203,2,249,22,168,8,23,204,1,8,63,23,202,1,28,248,22,133,4, -248,22,147,8,23,195,2,86,94,23,193,1,251,22,184,11,2,37,2,69,2, -70,200,192,28,248,22,176,15,196,248,22,177,15,196,247,22,178,15,28,248,22, -133,4,23,197,2,86,94,23,196,1,19,248,22,147,8,23,195,2,19,248,22, -147,8,23,196,2,249,22,185,15,27,251,22,154,8,250,22,153,8,23,205,2, -39,23,204,4,2,51,249,22,153,8,23,204,1,23,202,4,28,248,22,153,7, -23,205,2,249,22,168,8,23,206,1,8,63,23,204,1,28,248,22,133,4,248, -22,147,8,23,195,2,86,94,23,193,1,251,22,184,11,2,37,2,69,2,70, -202,192,28,248,22,176,15,198,248,22,177,15,198,247,22,178,15,2,2,27,248, -22,182,3,23,198,1,28,249,22,169,9,8,46,249,22,148,8,23,198,2,23, -197,2,27,248,22,181,3,23,195,2,249,22,185,15,27,251,22,154,8,250,22, -153,8,23,205,2,39,23,204,1,2,71,249,22,153,8,23,204,1,23,202,1, -28,248,22,153,7,23,205,2,249,22,168,8,23,206,1,8,63,23,204,1,28, -248,22,133,4,248,22,147,8,23,195,2,86,94,23,193,1,251,22,184,11,2, -37,2,69,2,70,202,192,28,248,22,176,15,198,248,22,177,15,198,247,22,178, -15,28,248,22,133,4,193,253,2,175,2,199,200,201,248,22,147,8,200,2,51, -248,22,147,8,200,27,248,22,182,3,194,28,249,22,169,9,8,46,249,22,148, -8,198,196,253,2,175,2,200,201,202,198,2,71,248,22,181,3,199,251,2,174, -2,198,199,200,196,90,144,41,11,89,146,41,39,11,86,95,28,28,248,22,176, -15,23,196,2,10,28,248,22,175,15,23,196,2,10,28,248,22,153,7,23,196, -2,28,248,22,134,16,23,196,2,10,248,22,135,16,23,196,2,11,12,252,22, -182,11,2,37,2,42,39,23,200,2,23,201,2,28,28,248,22,153,7,23,197, -2,10,248,22,142,8,23,197,2,12,252,22,182,11,2,37,2,72,40,23,200, -2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,132,16,23,199,2,86, -94,23,195,1,86,94,28,192,12,250,22,185,11,2,37,2,73,23,201,2,249, -22,7,194,195,27,248,22,181,15,23,196,1,27,251,2,174,2,23,198,2,23, -201,1,23,202,1,248,22,147,8,23,199,1,28,248,22,176,15,195,249,22,129, -16,196,194,192,252,80,144,44,8,35,42,2,37,2,71,22,153,8,198,199,249, -247,22,176,5,23,195,1,11,249,247,22,176,5,194,11,28,248,22,88,23,195, -2,9,27,27,248,22,81,23,197,2,28,248,22,136,16,23,194,2,248,22,139, -16,23,194,1,28,248,22,135,16,23,194,2,90,144,42,11,89,146,42,39,11, -248,22,132,16,249,22,137,16,250,80,144,50,43,42,248,22,152,16,2,56,11, -11,248,22,152,16,2,57,86,95,23,195,1,23,194,1,248,22,139,16,249,22, -137,16,23,199,1,23,196,1,27,250,80,144,45,43,42,248,22,152,16,2,56, -23,197,1,10,28,23,193,2,248,22,139,16,23,194,1,11,28,23,193,2,249, -22,80,248,22,139,16,249,22,137,16,23,198,1,247,22,153,16,27,248,22,165, -20,23,199,1,28,248,22,88,23,194,2,9,27,248,80,144,45,56,42,248,22, -81,23,196,2,28,23,193,2,249,22,80,248,22,139,16,249,22,137,16,23,198, -1,247,22,153,16,248,80,144,47,8,50,42,248,22,165,20,23,198,1,86,94, -23,193,1,248,80,144,45,8,50,42,248,22,165,20,23,196,1,86,94,23,193, -1,27,248,22,165,20,23,197,1,28,248,22,88,23,194,2,9,27,248,80,144, -43,56,42,248,22,81,23,196,2,28,23,193,2,249,22,80,248,22,139,16,249, -22,137,16,23,198,1,247,22,153,16,248,80,144,45,8,50,42,248,22,165,20, -23,198,1,86,94,23,193,1,248,80,144,43,8,50,42,248,22,165,20,23,196, -1,28,248,22,88,23,195,2,9,27,27,248,22,81,23,197,2,28,248,22,136, -16,23,194,2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2,90,144, -42,11,89,146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,50,43,42, -248,22,152,16,2,56,11,11,248,22,152,16,2,57,86,95,23,195,1,23,194, -1,248,22,139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144,45,43, -42,248,22,152,16,2,56,23,197,1,10,28,23,193,2,248,22,139,16,23,194, -1,11,28,23,193,2,249,22,80,248,22,139,16,249,22,137,16,23,198,1,247, -22,153,16,27,248,22,165,20,23,199,1,28,248,22,88,23,194,2,9,27,248, -80,144,45,56,42,248,22,81,23,196,2,28,23,193,2,249,22,80,248,22,139, -16,249,22,137,16,23,198,1,247,22,153,16,248,80,144,47,8,51,42,248,22, -165,20,23,198,1,86,94,23,193,1,248,80,144,45,8,51,42,248,22,165,20, -23,196,1,86,94,23,193,1,27,248,22,165,20,23,197,1,28,248,22,88,23, -194,2,9,27,248,80,144,43,56,42,248,22,81,23,196,2,28,23,193,2,249, -22,80,248,22,139,16,249,22,137,16,23,198,1,247,22,153,16,248,80,144,45, -8,51,42,248,22,165,20,23,198,1,86,94,23,193,1,248,80,144,43,8,51, -42,248,22,165,20,23,196,1,27,248,22,152,16,2,58,28,248,22,136,16,23, -194,2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2,90,144,42,11, -89,146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,49,43,42,248,22, -152,16,2,56,11,11,248,22,152,16,2,57,86,95,23,195,1,23,194,1,248, -22,139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144,44,43,42,248, -22,152,16,2,56,23,197,1,10,28,23,193,2,248,22,139,16,23,194,1,11, -28,248,22,88,23,195,2,9,27,27,248,22,81,23,197,2,28,248,22,136,16, -23,194,2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2,90,144,42, -11,89,146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,50,43,42,248, -22,152,16,2,56,11,11,248,22,152,16,2,57,86,95,23,195,1,23,194,1, -248,22,139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144,45,43,42, -248,22,152,16,2,56,23,197,1,10,28,23,193,2,248,22,139,16,23,194,1, -11,28,23,193,2,249,22,80,248,22,139,16,249,22,137,16,23,198,1,247,22, -153,16,27,248,22,165,20,23,199,1,28,248,22,88,23,194,2,9,27,27,248, -22,81,23,196,2,28,248,22,136,16,23,194,2,248,22,139,16,23,194,1,28, -248,22,135,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,132,16,249, -22,137,16,250,80,144,54,43,42,248,22,152,16,2,56,11,11,248,22,152,16, -2,57,86,95,23,195,1,23,194,1,248,22,139,16,249,22,137,16,23,199,1, -23,196,1,27,250,80,144,49,43,42,248,22,152,16,2,56,23,197,1,10,28, -23,193,2,248,22,139,16,23,194,1,11,28,23,193,2,249,22,80,248,22,139, -16,249,22,137,16,23,198,1,247,22,153,16,27,248,22,165,20,23,198,1,28, -248,22,88,23,194,2,9,27,248,80,144,49,56,42,248,22,81,23,196,2,28, -23,193,2,249,22,80,248,22,139,16,249,22,137,16,23,198,1,247,22,153,16, -248,80,144,51,8,53,42,248,22,165,20,23,198,1,86,94,23,193,1,248,80, -144,49,8,53,42,248,22,165,20,23,196,1,86,94,23,193,1,27,248,22,165, -20,23,196,1,28,248,22,88,23,194,2,9,27,248,80,144,47,56,42,248,22, -81,23,196,2,28,23,193,2,249,22,80,248,22,139,16,249,22,137,16,23,198, -1,247,22,153,16,248,80,144,49,8,53,42,248,22,165,20,23,198,1,86,94, -23,193,1,248,80,144,47,8,53,42,248,22,165,20,23,196,1,86,94,23,193, -1,27,248,22,165,20,23,197,1,28,248,22,88,23,194,2,9,27,27,248,22, -81,23,196,2,28,248,22,136,16,23,194,2,248,22,139,16,23,194,1,28,248, -22,135,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,132,16,249,22, -137,16,250,80,144,52,43,42,248,22,152,16,2,56,11,11,248,22,152,16,2, -57,86,95,23,195,1,23,194,1,248,22,139,16,249,22,137,16,23,199,1,23, -196,1,27,250,80,144,47,43,42,248,22,152,16,2,56,23,197,1,10,28,23, -193,2,248,22,139,16,23,194,1,11,28,23,193,2,249,22,80,248,22,139,16, -249,22,137,16,23,198,1,247,22,153,16,27,248,22,165,20,23,198,1,28,248, -22,88,23,194,2,9,27,248,80,144,47,56,42,248,22,81,23,196,2,28,23, -193,2,249,22,80,248,22,139,16,249,22,137,16,23,198,1,247,22,153,16,248, -80,144,49,8,53,42,248,22,165,20,23,198,1,86,94,23,193,1,248,80,144, -47,8,53,42,248,22,165,20,23,196,1,86,94,23,193,1,27,248,22,165,20, -23,196,1,28,248,22,88,23,194,2,9,27,248,80,144,45,56,42,248,22,81, -23,196,2,28,23,193,2,249,22,80,248,22,139,16,249,22,137,16,23,198,1, -247,22,153,16,248,80,144,47,8,53,42,248,22,165,20,23,198,1,86,94,23, -193,1,248,80,144,45,8,53,42,248,22,165,20,23,196,1,27,247,22,160,16, +74,222,33,176,2,249,22,189,15,27,251,22,155,8,250,22,154,8,23,203,2, +39,23,206,1,23,204,1,249,22,154,8,23,202,1,23,207,1,28,248,22,154, +7,23,203,2,249,22,169,8,23,204,1,8,63,23,202,1,28,248,22,134,4, +248,22,148,8,23,195,2,86,94,23,193,1,251,22,185,11,2,37,2,69,2, +70,200,192,28,248,22,180,15,196,248,22,181,15,196,247,22,182,15,28,248,22, +134,4,23,197,2,86,94,23,196,1,19,248,22,148,8,23,195,2,19,248,22, +148,8,23,196,2,249,22,189,15,27,251,22,155,8,250,22,154,8,23,205,2, +39,23,204,4,2,51,249,22,154,8,23,204,1,23,202,4,28,248,22,154,7, +23,205,2,249,22,169,8,23,206,1,8,63,23,204,1,28,248,22,134,4,248, +22,148,8,23,195,2,86,94,23,193,1,251,22,185,11,2,37,2,69,2,70, +202,192,28,248,22,180,15,198,248,22,181,15,198,247,22,182,15,2,2,27,248, +22,183,3,23,198,1,28,249,22,170,9,8,46,249,22,149,8,23,198,2,23, +197,2,27,248,22,182,3,23,195,2,249,22,189,15,27,251,22,155,8,250,22, +154,8,23,205,2,39,23,204,1,2,71,249,22,154,8,23,204,1,23,202,1, +28,248,22,154,7,23,205,2,249,22,169,8,23,206,1,8,63,23,204,1,28, +248,22,134,4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,185,11,2, +37,2,69,2,70,202,192,28,248,22,180,15,198,248,22,181,15,198,247,22,182, +15,28,248,22,134,4,193,253,2,175,2,199,200,201,248,22,148,8,200,2,51, +248,22,148,8,200,27,248,22,183,3,194,28,249,22,170,9,8,46,249,22,149, +8,198,196,253,2,175,2,200,201,202,198,2,71,248,22,182,3,199,251,2,174, +2,198,199,200,196,90,144,41,11,89,146,41,39,11,86,95,28,28,248,22,180, +15,23,196,2,10,28,248,22,179,15,23,196,2,10,28,248,22,154,7,23,196, +2,28,248,22,138,16,23,196,2,10,248,22,139,16,23,196,2,11,12,252,22, +183,11,2,37,2,42,39,23,200,2,23,201,2,28,28,248,22,154,7,23,197, +2,10,248,22,143,8,23,197,2,12,252,22,183,11,2,37,2,72,40,23,200, +2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,136,16,23,199,2,86, +94,23,195,1,86,94,28,192,12,250,22,186,11,2,37,2,73,23,201,2,249, +22,7,194,195,27,248,22,185,15,23,196,1,27,251,2,174,2,23,198,2,23, +201,1,23,202,1,248,22,148,8,23,199,1,28,248,22,180,15,195,249,22,133, +16,196,194,192,252,80,144,44,8,35,42,2,37,2,71,22,154,8,198,199,249, +247,22,177,5,23,195,1,11,249,247,22,177,5,194,11,28,248,22,89,23,195, +2,9,27,27,248,22,82,23,197,2,28,248,22,140,16,23,194,2,248,22,143, +16,23,194,1,28,248,22,139,16,23,194,2,90,144,42,11,89,146,42,39,11, +248,22,136,16,249,22,141,16,250,80,144,50,43,42,248,22,156,16,2,56,11, +11,248,22,156,16,2,57,86,95,23,195,1,23,194,1,248,22,143,16,249,22, +141,16,23,199,1,23,196,1,27,250,80,144,45,43,42,248,22,156,16,2,56, +23,197,1,10,28,23,193,2,248,22,143,16,23,194,1,11,28,23,193,2,249, +22,81,248,22,143,16,249,22,141,16,23,198,1,247,22,157,16,27,248,22,171, +20,23,199,1,28,248,22,89,23,194,2,9,27,248,80,144,45,56,42,248,22, +82,23,196,2,28,23,193,2,249,22,81,248,22,143,16,249,22,141,16,23,198, +1,247,22,157,16,248,80,144,47,8,50,42,248,22,171,20,23,198,1,86,94, +23,193,1,248,80,144,45,8,50,42,248,22,171,20,23,196,1,86,94,23,193, +1,27,248,22,171,20,23,197,1,28,248,22,89,23,194,2,9,27,248,80,144, +43,56,42,248,22,82,23,196,2,28,23,193,2,249,22,81,248,22,143,16,249, +22,141,16,23,198,1,247,22,157,16,248,80,144,45,8,50,42,248,22,171,20, +23,198,1,86,94,23,193,1,248,80,144,43,8,50,42,248,22,171,20,23,196, +1,28,248,22,89,23,195,2,9,27,27,248,22,82,23,197,2,28,248,22,140, +16,23,194,2,248,22,143,16,23,194,1,28,248,22,139,16,23,194,2,90,144, +42,11,89,146,42,39,11,248,22,136,16,249,22,141,16,250,80,144,50,43,42, +248,22,156,16,2,56,11,11,248,22,156,16,2,57,86,95,23,195,1,23,194, +1,248,22,143,16,249,22,141,16,23,199,1,23,196,1,27,250,80,144,45,43, +42,248,22,156,16,2,56,23,197,1,10,28,23,193,2,248,22,143,16,23,194, +1,11,28,23,193,2,249,22,81,248,22,143,16,249,22,141,16,23,198,1,247, +22,157,16,27,248,22,171,20,23,199,1,28,248,22,89,23,194,2,9,27,248, +80,144,45,56,42,248,22,82,23,196,2,28,23,193,2,249,22,81,248,22,143, +16,249,22,141,16,23,198,1,247,22,157,16,248,80,144,47,8,51,42,248,22, +171,20,23,198,1,86,94,23,193,1,248,80,144,45,8,51,42,248,22,171,20, +23,196,1,86,94,23,193,1,27,248,22,171,20,23,197,1,28,248,22,89,23, +194,2,9,27,248,80,144,43,56,42,248,22,82,23,196,2,28,23,193,2,249, +22,81,248,22,143,16,249,22,141,16,23,198,1,247,22,157,16,248,80,144,45, +8,51,42,248,22,171,20,23,198,1,86,94,23,193,1,248,80,144,43,8,51, +42,248,22,171,20,23,196,1,27,248,22,156,16,2,58,28,248,22,140,16,23, +194,2,248,22,143,16,23,194,1,28,248,22,139,16,23,194,2,90,144,42,11, +89,146,42,39,11,248,22,136,16,249,22,141,16,250,80,144,49,43,42,248,22, +156,16,2,56,11,11,248,22,156,16,2,57,86,95,23,195,1,23,194,1,248, +22,143,16,249,22,141,16,23,199,1,23,196,1,27,250,80,144,44,43,42,248, +22,156,16,2,56,23,197,1,10,28,23,193,2,248,22,143,16,23,194,1,11, +28,248,22,89,23,195,2,9,27,27,248,22,82,23,197,2,28,248,22,140,16, +23,194,2,248,22,143,16,23,194,1,28,248,22,139,16,23,194,2,90,144,42, +11,89,146,42,39,11,248,22,136,16,249,22,141,16,250,80,144,50,43,42,248, +22,156,16,2,56,11,11,248,22,156,16,2,57,86,95,23,195,1,23,194,1, +248,22,143,16,249,22,141,16,23,199,1,23,196,1,27,250,80,144,45,43,42, +248,22,156,16,2,56,23,197,1,10,28,23,193,2,248,22,143,16,23,194,1, +11,28,23,193,2,249,22,81,248,22,143,16,249,22,141,16,23,198,1,247,22, +157,16,27,248,22,171,20,23,199,1,28,248,22,89,23,194,2,9,27,27,248, +22,82,23,196,2,28,248,22,140,16,23,194,2,248,22,143,16,23,194,1,28, +248,22,139,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,136,16,249, +22,141,16,250,80,144,54,43,42,248,22,156,16,2,56,11,11,248,22,156,16, +2,57,86,95,23,195,1,23,194,1,248,22,143,16,249,22,141,16,23,199,1, +23,196,1,27,250,80,144,49,43,42,248,22,156,16,2,56,23,197,1,10,28, +23,193,2,248,22,143,16,23,194,1,11,28,23,193,2,249,22,81,248,22,143, +16,249,22,141,16,23,198,1,247,22,157,16,27,248,22,171,20,23,198,1,28, +248,22,89,23,194,2,9,27,248,80,144,49,56,42,248,22,82,23,196,2,28, +23,193,2,249,22,81,248,22,143,16,249,22,141,16,23,198,1,247,22,157,16, +248,80,144,51,8,53,42,248,22,171,20,23,198,1,86,94,23,193,1,248,80, +144,49,8,53,42,248,22,171,20,23,196,1,86,94,23,193,1,27,248,22,171, +20,23,196,1,28,248,22,89,23,194,2,9,27,248,80,144,47,56,42,248,22, +82,23,196,2,28,23,193,2,249,22,81,248,22,143,16,249,22,141,16,23,198, +1,247,22,157,16,248,80,144,49,8,53,42,248,22,171,20,23,198,1,86,94, +23,193,1,248,80,144,47,8,53,42,248,22,171,20,23,196,1,86,94,23,193, +1,27,248,22,171,20,23,197,1,28,248,22,89,23,194,2,9,27,27,248,22, +82,23,196,2,28,248,22,140,16,23,194,2,248,22,143,16,23,194,1,28,248, +22,139,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,136,16,249,22, +141,16,250,80,144,52,43,42,248,22,156,16,2,56,11,11,248,22,156,16,2, +57,86,95,23,195,1,23,194,1,248,22,143,16,249,22,141,16,23,199,1,23, +196,1,27,250,80,144,47,43,42,248,22,156,16,2,56,23,197,1,10,28,23, +193,2,248,22,143,16,23,194,1,11,28,23,193,2,249,22,81,248,22,143,16, +249,22,141,16,23,198,1,247,22,157,16,27,248,22,171,20,23,198,1,28,248, +22,89,23,194,2,9,27,248,80,144,47,56,42,248,22,82,23,196,2,28,23, +193,2,249,22,81,248,22,143,16,249,22,141,16,23,198,1,247,22,157,16,248, +80,144,49,8,53,42,248,22,171,20,23,198,1,86,94,23,193,1,248,80,144, +47,8,53,42,248,22,171,20,23,196,1,86,94,23,193,1,27,248,22,171,20, +23,196,1,28,248,22,89,23,194,2,9,27,248,80,144,45,56,42,248,22,82, +23,196,2,28,23,193,2,249,22,81,248,22,143,16,249,22,141,16,23,198,1, +247,22,157,16,248,80,144,47,8,53,42,248,22,171,20,23,198,1,86,94,23, +193,1,248,80,144,45,8,53,42,248,22,171,20,23,196,1,27,247,22,164,16, 27,248,80,144,42,58,42,247,80,144,42,57,42,249,80,144,43,44,41,28,23, -196,2,27,249,22,175,8,247,22,174,8,2,75,28,192,249,22,165,8,194,7, +196,2,27,249,22,176,8,247,22,175,8,2,75,28,192,249,22,166,8,194,7, 63,2,66,2,66,250,80,144,46,8,23,42,23,198,2,2,76,27,28,23,200, -1,250,22,129,16,248,22,152,16,2,61,250,22,158,2,23,205,1,2,59,247, -22,171,8,2,77,86,94,23,199,1,11,27,248,80,144,49,8,50,42,250,22, -94,9,248,22,90,248,22,152,16,2,55,9,28,193,249,22,80,195,194,192,27, -247,22,160,16,27,248,80,144,42,58,42,247,80,144,42,57,42,249,80,144,43, -44,41,28,23,196,2,27,249,22,175,8,247,22,174,8,2,75,28,192,249,22, -165,8,194,7,63,2,66,2,66,250,80,144,46,8,23,42,23,198,2,2,76, -27,28,23,200,1,250,22,129,16,248,22,152,16,2,61,250,22,158,2,23,205, -1,2,59,247,22,171,8,2,77,86,94,23,199,1,11,27,248,80,144,49,8, -51,42,250,22,94,23,207,1,248,22,90,248,22,152,16,2,55,9,28,193,249, -22,80,195,194,192,27,247,22,160,16,27,248,80,144,42,58,42,249,80,144,44, +1,250,22,133,16,248,22,156,16,2,61,250,22,159,2,23,205,1,2,59,247, +22,172,8,2,77,86,94,23,199,1,11,27,248,80,144,49,8,50,42,250,22, +95,9,248,22,91,248,22,156,16,2,55,9,28,193,249,22,81,195,194,192,27, +247,22,164,16,27,248,80,144,42,58,42,247,80,144,42,57,42,249,80,144,43, +44,41,28,23,196,2,27,249,22,176,8,247,22,175,8,2,75,28,192,249,22, +166,8,194,7,63,2,66,2,66,250,80,144,46,8,23,42,23,198,2,2,76, +27,28,23,200,1,250,22,133,16,248,22,156,16,2,61,250,22,159,2,23,205, +1,2,59,247,22,172,8,2,77,86,94,23,199,1,11,27,248,80,144,49,8, +51,42,250,22,95,23,207,1,248,22,91,248,22,156,16,2,55,9,28,193,249, +22,81,195,194,192,27,247,22,164,16,27,248,80,144,42,58,42,249,80,144,44, 55,40,40,80,144,44,8,52,42,249,80,144,43,44,41,28,23,196,2,27,249, -22,175,8,247,22,174,8,2,75,28,192,249,22,165,8,194,7,63,2,66,2, -66,250,80,144,46,8,23,42,23,198,2,2,76,27,28,23,200,1,250,22,129, -16,248,22,152,16,2,61,250,22,158,2,23,205,1,2,59,247,22,171,8,2, -77,86,94,23,199,1,11,27,27,250,22,94,23,207,1,248,22,90,248,22,152, -16,2,55,23,208,1,28,248,22,88,23,194,2,9,27,27,248,22,81,23,196, -2,28,248,22,136,16,23,194,2,248,22,139,16,23,194,1,28,248,22,135,16, -23,194,2,90,144,42,11,89,146,42,39,11,248,22,132,16,249,22,137,16,250, -80,144,60,43,42,248,22,152,16,2,56,11,11,248,22,152,16,2,57,86,95, -23,195,1,23,194,1,248,22,139,16,249,22,137,16,23,199,1,23,196,1,27, -250,80,144,55,43,42,248,22,152,16,2,56,23,197,1,10,28,23,193,2,248, -22,139,16,23,194,1,11,28,23,193,2,249,22,80,248,22,139,16,249,22,137, -16,23,198,1,247,22,153,16,27,248,22,165,20,23,198,1,28,248,22,88,23, -194,2,9,27,248,80,144,55,56,42,248,22,81,23,196,2,28,23,193,2,249, -22,80,248,22,139,16,249,22,137,16,23,198,1,247,22,153,16,248,80,144,57, -8,53,42,248,22,165,20,23,198,1,86,94,23,193,1,248,80,144,55,8,53, -42,248,22,165,20,23,196,1,86,94,23,193,1,27,248,22,165,20,23,196,1, -28,248,22,88,23,194,2,9,27,248,80,144,53,56,42,248,22,81,23,196,2, -28,23,193,2,249,22,80,248,22,139,16,249,22,137,16,23,198,1,247,22,153, -16,248,80,144,55,8,53,42,248,22,165,20,23,198,1,86,94,23,193,1,248, -80,144,53,8,53,42,248,22,165,20,23,196,1,28,193,249,22,80,195,194,192, +22,176,8,247,22,175,8,2,75,28,192,249,22,166,8,194,7,63,2,66,2, +66,250,80,144,46,8,23,42,23,198,2,2,76,27,28,23,200,1,250,22,133, +16,248,22,156,16,2,61,250,22,159,2,23,205,1,2,59,247,22,172,8,2, +77,86,94,23,199,1,11,27,27,250,22,95,23,207,1,248,22,91,248,22,156, +16,2,55,23,208,1,28,248,22,89,23,194,2,9,27,27,248,22,82,23,196, +2,28,248,22,140,16,23,194,2,248,22,143,16,23,194,1,28,248,22,139,16, +23,194,2,90,144,42,11,89,146,42,39,11,248,22,136,16,249,22,141,16,250, +80,144,60,43,42,248,22,156,16,2,56,11,11,248,22,156,16,2,57,86,95, +23,195,1,23,194,1,248,22,143,16,249,22,141,16,23,199,1,23,196,1,27, +250,80,144,55,43,42,248,22,156,16,2,56,23,197,1,10,28,23,193,2,248, +22,143,16,23,194,1,11,28,23,193,2,249,22,81,248,22,143,16,249,22,141, +16,23,198,1,247,22,157,16,27,248,22,171,20,23,198,1,28,248,22,89,23, +194,2,9,27,248,80,144,55,56,42,248,22,82,23,196,2,28,23,193,2,249, +22,81,248,22,143,16,249,22,141,16,23,198,1,247,22,157,16,248,80,144,57, +8,53,42,248,22,171,20,23,198,1,86,94,23,193,1,248,80,144,55,8,53, +42,248,22,171,20,23,196,1,86,94,23,193,1,27,248,22,171,20,23,196,1, +28,248,22,89,23,194,2,9,27,248,80,144,53,56,42,248,22,82,23,196,2, +28,23,193,2,249,22,81,248,22,143,16,249,22,141,16,23,198,1,247,22,157, +16,248,80,144,55,8,53,42,248,22,171,20,23,198,1,86,94,23,193,1,248, +80,144,53,8,53,42,248,22,171,20,23,196,1,28,193,249,22,81,195,194,192, 27,20,13,144,80,144,40,46,40,26,9,80,144,49,47,40,249,22,31,11,80, -144,51,46,40,22,149,15,10,22,156,15,10,22,157,15,10,22,158,15,10,248, -22,148,6,23,196,2,28,248,22,148,7,23,194,2,12,86,94,248,22,177,9, +144,51,46,40,22,153,15,10,22,160,15,10,22,161,15,10,22,162,15,10,248, +22,149,6,23,196,2,28,248,22,149,7,23,194,2,12,86,94,248,22,178,9, 23,194,1,27,20,13,144,80,144,41,46,40,26,9,80,144,50,47,40,249,22, -31,11,80,144,52,46,40,22,149,15,10,22,156,15,10,22,157,15,10,22,158, -15,10,248,22,148,6,23,197,2,28,248,22,148,7,23,194,2,12,86,94,248, -22,177,9,23,194,1,27,20,13,144,80,144,42,46,40,26,9,80,144,51,47, -40,249,22,31,11,80,144,53,46,40,22,149,15,10,22,156,15,10,22,157,15, -10,22,158,15,10,248,22,148,6,23,198,2,28,248,22,148,7,23,194,2,12, -86,94,248,22,177,9,23,194,1,248,80,144,43,8,54,42,197,86,94,249,22, -139,7,247,22,172,5,23,196,2,248,22,163,6,249,22,136,4,39,249,22,184, -3,28,23,198,2,23,198,1,86,94,23,198,1,39,23,199,1,27,248,22,189, +31,11,80,144,52,46,40,22,153,15,10,22,160,15,10,22,161,15,10,22,162, +15,10,248,22,149,6,23,197,2,28,248,22,149,7,23,194,2,12,86,94,248, +22,178,9,23,194,1,27,20,13,144,80,144,42,46,40,26,9,80,144,51,47, +40,249,22,31,11,80,144,53,46,40,22,153,15,10,22,160,15,10,22,161,15, +10,22,162,15,10,248,22,149,6,23,198,2,28,248,22,149,7,23,194,2,12, +86,94,248,22,178,9,23,194,1,248,80,144,43,8,54,42,197,86,94,249,22, +140,7,247,22,173,5,23,196,2,248,22,164,6,249,22,137,4,39,249,22,185, +3,28,23,198,2,23,198,1,86,94,23,198,1,39,23,199,1,27,248,22,190, 5,28,23,198,2,86,95,23,197,1,23,196,1,23,198,1,86,94,23,198,1, -27,250,80,144,45,43,42,248,22,152,16,2,56,11,11,27,248,22,139,4,23, -199,1,27,28,23,194,2,23,194,1,86,94,23,194,1,39,27,248,22,139,4, -23,202,1,249,22,140,6,23,198,1,20,20,95,88,148,8,36,39,51,11,9, +27,250,80,144,45,43,42,248,22,156,16,2,56,11,11,27,248,22,140,4,23, +199,1,27,28,23,194,2,23,194,1,86,94,23,194,1,39,27,248,22,140,4, +23,202,1,249,22,141,6,23,198,1,20,20,95,88,148,8,36,39,51,11,9, 224,3,2,33,190,2,23,195,1,23,196,1,248,80,144,41,8,54,42,193,145, 39,9,20,121,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2, 2,29,11,11,11,11,11,11,11,9,9,11,11,11,10,46,80,143,39,39,20, @@ -968,16 +971,16 @@ 2,18,2,20,2,38,2,5,2,34,2,8,2,37,2,3,2,6,56,56,40, 12,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16,0,16,0, 39,39,16,51,20,15,16,2,32,0,88,148,8,36,40,48,11,2,3,222,33, -78,80,144,39,39,40,20,15,16,2,249,22,155,7,7,92,7,92,80,144,39, +78,80,144,39,39,40,20,15,16,2,249,22,156,7,7,92,7,92,80,144,39, 40,40,20,15,16,2,88,148,8,36,40,57,41,2,5,223,0,33,83,80,144, 39,41,40,20,15,16,2,88,148,8,36,41,61,41,2,6,223,0,33,85,80, 144,39,42,40,20,15,16,2,20,26,96,2,7,88,148,8,36,42,8,24,8, 32,9,223,0,33,92,88,148,8,36,41,50,55,9,223,0,33,93,88,148,8, 36,40,49,55,9,223,0,33,94,80,144,39,43,40,20,15,16,2,27,248,22, -164,16,248,22,167,8,27,28,249,22,169,9,247,22,180,8,2,43,6,1,1, -59,6,1,1,58,250,22,137,8,6,14,14,40,91,94,126,97,93,42,41,126, +168,16,248,22,168,8,27,28,249,22,170,9,247,22,181,8,2,43,6,1,1, +59,6,1,1,58,250,22,138,8,6,14,14,40,91,94,126,97,93,42,41,126, 97,40,46,42,41,23,196,2,23,196,1,88,148,8,36,41,51,11,2,8,223, -0,33,98,80,144,39,44,40,20,15,16,2,88,148,39,40,8,38,8,128,6, +0,33,98,80,144,39,44,40,20,15,16,2,88,148,39,40,8,44,8,128,6, 2,9,223,0,33,99,80,144,39,45,40,20,15,16,2,32,0,88,148,8,36, 41,50,11,2,12,222,33,100,80,144,39,48,40,20,15,16,2,32,0,88,148, 8,36,42,51,11,2,13,222,33,102,80,144,39,49,40,20,15,16,2,32,0, @@ -989,7 +992,7 @@ 33,109,80,144,39,54,40,20,15,16,2,88,148,39,39,56,55,9,223,0,33, 110,80,144,39,8,41,42,20,15,16,2,88,148,39,39,47,16,4,39,40,8, 128,8,39,2,20,223,0,33,111,80,144,39,57,40,20,15,16,2,88,148,8, -36,39,8,38,8,128,6,9,223,0,33,112,80,144,39,8,42,42,20,15,16, +36,39,8,44,8,128,6,9,223,0,33,112,80,144,39,8,42,42,20,15,16, 2,88,148,8,36,40,50,16,4,39,39,8,128,16,39,2,21,223,0,33,113, 80,144,39,58,40,20,15,16,2,20,28,143,32,0,88,148,39,40,48,11,2, 22,222,33,114,32,0,88,148,39,40,48,11,2,22,222,33,115,80,144,39,59, @@ -1003,7 +1006,7 @@ 39,39,8,128,64,39,2,25,223,0,33,121,80,144,39,8,23,40,20,15,16, 2,88,148,39,39,56,55,9,223,0,33,122,80,144,39,8,45,42,20,15,16, 2,88,148,8,36,39,57,16,4,8,240,0,128,0,0,8,137,2,8,128,128, -39,2,26,223,0,33,123,80,144,39,8,24,40,20,15,16,2,247,22,140,2, +39,2,26,223,0,33,123,80,144,39,8,24,40,20,15,16,2,247,22,141,2, 80,144,39,8,25,40,20,15,16,2,248,22,16,67,115,116,97,109,112,80,144, 39,8,26,40,20,15,16,2,88,148,39,40,49,8,240,0,0,0,4,9,223, 0,33,125,80,144,39,8,46,42,20,15,16,2,88,148,39,41,51,16,4,39, @@ -1044,531 +1047,534 @@ 144,39,8,39,40,95,29,94,2,10,70,35,37,107,101,114,110,101,108,11,29, 94,2,10,71,35,37,109,105,110,45,115,116,120,11,2,11,9,9,9,39,9, 0}; - EVAL_ONE_SIZED_STR((char *)expr, 19761); + EVAL_ONE_SIZED_STR((char *)expr, 19824); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,10,54,46,50,46,57,48,48,46,49,53,84,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,0,0,15,0,0,0,1,0,0,8, -0,23,0,48,0,65,0,83,0,105,0,128,0,149,0,171,0,180,0,189,0, -196,0,205,0,212,0,0,0,248,1,0,0,3,1,5,105,110,115,112,48,76, -35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115,116,114,117,99, -116,58,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,78,84,72, -45,112,108,97,99,101,45,99,104,97,110,110,101,108,79,84,72,45,112,108,97, -99,101,45,99,104,97,110,110,101,108,63,1,20,84,72,45,112,108,97,99,101, -45,99,104,97,110,110,101,108,45,114,101,102,1,21,84,72,45,112,108,97,99, -101,45,99,104,97,110,110,101,108,45,115,101,116,33,1,19,84,72,45,112,108, -97,99,101,45,99,104,97,110,110,101,108,45,105,110,1,20,84,72,45,112,108, -97,99,101,45,99,104,97,110,110,101,108,45,111,117,116,249,80,143,41,42,23, -196,1,39,249,80,143,41,42,23,196,1,39,249,80,143,41,42,195,39,249,80, -143,41,42,23,196,1,40,249,80,143,41,42,195,40,145,39,9,20,121,145,2, -1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,29,11,11,11,11, -11,11,11,9,9,11,11,11,10,48,80,143,39,39,20,121,145,2,1,39,16, -7,2,3,2,4,2,5,2,6,2,7,2,8,2,9,16,0,40,42,39,16, -0,39,16,2,2,6,2,7,41,11,11,11,16,5,2,4,2,8,2,9,2, -5,2,3,16,5,11,11,11,11,11,16,5,2,4,2,8,2,9,2,5,2, -3,44,44,40,12,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0, -16,0,16,0,39,39,16,3,20,15,16,6,253,22,190,10,2,4,11,41,39, -11,248,22,90,249,22,80,22,175,10,88,148,39,40,48,47,9,223,9,33,10, -80,144,39,39,40,80,144,39,40,40,80,144,39,41,40,80,144,39,42,40,80, -144,39,43,40,20,15,16,2,20,28,143,88,148,39,40,48,47,9,223,0,33, -11,88,148,39,40,48,47,9,223,0,33,12,80,144,39,44,40,20,15,16,2, -20,28,143,88,148,39,40,48,47,9,223,0,33,13,88,148,39,40,48,47,9, -223,0,33,14,80,144,39,45,40,93,29,94,67,113,117,111,116,101,70,35,37, -107,101,114,110,101,108,11,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 579); + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,51,46,48,46,49,48,84,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,15,0,0,0,1,0,0,8,0,23, +0,48,0,65,0,83,0,105,0,128,0,149,0,171,0,180,0,189,0,196,0, +205,0,212,0,0,0,248,1,0,0,3,1,5,105,110,115,112,48,76,35,37, +112,108,97,99,101,45,115,116,114,117,99,116,1,23,115,116,114,117,99,116,58, +84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,78,84,72,45,112, +108,97,99,101,45,99,104,97,110,110,101,108,79,84,72,45,112,108,97,99,101, +45,99,104,97,110,110,101,108,63,1,20,84,72,45,112,108,97,99,101,45,99, +104,97,110,110,101,108,45,114,101,102,1,21,84,72,45,112,108,97,99,101,45, +99,104,97,110,110,101,108,45,115,101,116,33,1,19,84,72,45,112,108,97,99, +101,45,99,104,97,110,110,101,108,45,105,110,1,20,84,72,45,112,108,97,99, +101,45,99,104,97,110,110,101,108,45,111,117,116,249,80,143,41,42,23,196,1, +39,249,80,143,41,42,23,196,1,39,249,80,143,41,42,195,39,249,80,143,41, +42,23,196,1,40,249,80,143,41,42,195,40,145,39,9,20,121,145,2,1,39, +16,1,11,16,0,20,27,15,56,9,2,2,2,2,29,11,11,11,11,11,11, +11,9,9,11,11,11,10,48,80,143,39,39,20,121,145,2,1,39,16,7,2, +3,2,4,2,5,2,6,2,7,2,8,2,9,16,0,40,42,39,16,0,39, +16,2,2,6,2,7,41,11,11,11,16,5,2,4,2,8,2,9,2,5,2, +3,16,5,11,11,11,11,11,16,5,2,4,2,8,2,9,2,5,2,3,44, +44,40,12,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16,0, +16,0,39,39,16,3,20,15,16,6,253,22,191,10,2,4,11,41,39,11,248, +22,91,249,22,81,22,176,10,88,148,39,40,48,47,9,223,9,33,10,80,144, +39,39,40,80,144,39,40,40,80,144,39,41,40,80,144,39,42,40,80,144,39, +43,40,20,15,16,2,20,28,143,88,148,39,40,48,47,9,223,0,33,11,88, +148,39,40,48,47,9,223,0,33,12,80,144,39,44,40,20,15,16,2,20,28, +143,88,148,39,40,48,47,9,223,0,33,13,88,148,39,40,48,47,9,223,0, +33,14,80,144,39,45,40,93,29,94,67,113,117,111,116,101,70,35,37,107,101, +114,110,101,108,11,9,9,9,39,9,0}; + EVAL_ONE_SIZED_STR((char *)expr, 577); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,10,54,46,50,46,57,48,48,46,49,53,84,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,0,0,100,0,0,0,1,0,0,8, -0,15,0,26,0,53,0,59,0,73,0,86,0,112,0,129,0,151,0,159,0, -171,0,186,0,202,0,220,0,241,0,253,0,13,1,36,1,60,1,72,1,103, -1,108,1,113,1,131,1,137,1,142,1,151,1,156,1,162,1,167,1,171,1, -186,1,193,1,198,1,202,1,207,1,214,1,225,1,232,1,240,1,87,2,122, -2,225,2,4,3,98,3,133,3,227,3,6,4,7,11,37,11,88,11,163,11, -179,11,195,11,209,11,225,11,44,12,60,12,76,12,92,12,167,12,74,13,90, -13,165,13,160,14,40,15,115,15,22,16,35,16,188,16,116,17,159,17,241,17, -113,18,174,18,182,18,193,18,227,19,74,20,102,20,115,20,36,21,43,21,203, -21,223,21,67,22,89,22,99,22,113,22,151,22,250,22,254,22,5,23,211,23, -104,32,157,32,181,32,205,32,0,0,254,36,0,0,3,1,5,105,110,115,112, -48,68,35,37,98,111,111,116,72,100,108,108,45,115,117,102,102,105,120,1,25, -100,101,102,97,117,108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112, -105,108,101,100,67,113,117,111,116,101,29,94,2,5,70,35,37,112,97,114,97, -109,122,11,29,94,2,5,69,35,37,117,116,105,108,115,11,1,24,45,109,111, -100,117,108,101,45,104,97,115,104,45,116,97,98,108,101,45,116,97,98,108,101, -78,114,101,103,105,115,116,101,114,45,122,111,45,112,97,116,104,1,20,100,101, -102,97,117,108,116,45,114,101,97,100,101,114,45,103,117,97,114,100,69,67,65, -67,72,69,45,78,73,45,112,97,116,104,45,99,97,99,104,101,76,112,97,116, -104,45,99,97,99,104,101,45,103,101,116,77,112,97,116,104,45,99,97,99,104, -101,45,115,101,116,33,79,45,108,111,97,100,105,110,103,45,102,105,108,101,110, -97,109,101,1,19,45,108,111,97,100,105,110,103,45,112,114,111,109,112,116,45, -116,97,103,73,45,112,114,101,118,45,114,101,108,116,111,77,45,112,114,101,118, -45,114,101,108,116,111,45,100,105,114,1,21,115,112,108,105,116,45,114,101,108, -97,116,105,118,101,45,115,116,114,105,110,103,1,22,102,111,114,109,97,116,45, -115,111,117,114,99,101,45,108,111,99,97,116,105,111,110,73,111,114,105,103,45, -112,97,114,97,109,122,1,29,115,116,97,110,100,97,114,100,45,109,111,100,117, -108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,66,98,111,111,116, -66,115,101,97,108,79,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108, -101,100,5,4,46,114,107,116,66,115,97,109,101,6,6,6,110,97,116,105,118, -101,5,3,46,122,111,67,105,108,111,111,112,66,108,111,111,112,65,108,105,98, -6,12,12,109,111,100,117,108,101,45,112,97,116,104,63,68,115,117,98,109,111, -100,6,2,2,46,46,6,1,1,46,66,102,105,108,101,68,112,108,97,110,101, -116,6,8,8,109,97,105,110,46,114,107,116,6,4,4,46,114,107,116,69,105, -103,110,111,114,101,100,27,252,22,129,16,28,249,22,169,9,23,201,2,2,27, -86,94,23,199,1,23,200,1,28,248,22,134,16,23,200,2,249,22,129,16,23, -202,1,23,201,1,249,80,144,50,45,42,23,202,1,23,201,1,23,203,1,2, -28,247,22,181,8,249,80,144,50,46,42,23,203,1,80,144,50,39,41,27,250, -22,147,16,196,11,32,0,88,148,8,36,39,44,11,9,222,11,28,192,249,22, -80,195,194,11,249,22,5,20,20,96,88,148,8,36,40,57,8,129,3,9,226, -5,4,3,6,33,42,23,199,1,23,196,1,23,197,1,23,195,1,27,252,22, -129,16,28,249,22,169,9,23,201,2,2,27,86,94,23,199,1,23,200,1,28, -248,22,134,16,23,200,2,249,22,129,16,23,202,1,23,201,1,249,80,144,50, -45,42,23,202,1,23,201,1,23,203,1,2,28,247,22,181,8,249,80,144,50, -46,42,23,203,1,80,144,50,39,41,27,250,22,147,16,196,11,32,0,88,148, -8,36,39,44,11,9,222,11,28,192,249,22,80,195,194,11,249,22,5,20,20, -96,88,148,8,36,40,57,8,129,3,9,226,5,4,3,6,33,44,23,199,1, -23,196,1,23,197,1,23,195,1,27,250,22,129,16,28,249,22,169,9,23,199, -2,2,27,86,94,23,197,1,23,198,1,28,248,22,134,16,23,198,2,249,22, -129,16,23,200,1,23,199,1,249,80,144,48,45,42,23,200,1,23,199,1,23, -201,1,249,80,144,48,46,42,23,201,1,2,29,27,250,22,147,16,196,11,32, -0,88,148,8,36,39,44,11,9,222,11,28,192,249,22,80,195,194,11,249,22, -5,20,20,96,88,148,8,36,40,55,8,128,3,9,226,5,4,3,6,33,46, -23,199,1,23,196,1,23,197,1,23,195,1,27,250,22,129,16,28,249,22,169, -9,23,199,2,2,27,86,94,23,197,1,23,198,1,28,248,22,134,16,23,198, -2,249,22,129,16,23,200,1,23,199,1,249,80,144,48,45,42,23,200,1,23, -199,1,23,201,1,249,80,144,48,46,42,23,201,1,2,29,27,250,22,147,16, -196,11,32,0,88,148,8,36,39,44,11,9,222,11,28,192,249,22,80,195,194, -11,249,22,5,20,20,96,88,148,8,36,40,55,8,128,3,9,226,5,4,3, -6,33,48,23,199,1,23,196,1,23,197,1,23,195,1,86,95,28,248,80,144, -40,43,42,23,195,2,12,250,22,182,11,2,25,6,12,12,112,97,116,104,45, -115,116,114,105,110,103,63,23,197,2,28,28,23,195,2,28,248,22,64,23,196, -2,10,28,248,22,89,23,196,2,28,249,22,130,4,248,22,93,23,198,2,40, -28,28,248,22,64,248,22,81,23,197,2,10,248,22,167,9,248,22,164,20,23, -197,2,249,22,4,22,64,248,22,165,20,23,198,2,11,11,11,10,12,250,22, -182,11,2,25,6,71,71,40,111,114,47,99,32,35,102,32,115,121,109,98,111, -108,63,32,40,99,111,110,115,47,99,32,40,111,114,47,99,32,35,102,32,115, -121,109,98,111,108,63,41,32,40,110,111,110,45,101,109,112,116,121,45,108,105, -115,116,111,102,32,115,121,109,98,111,108,63,41,41,41,23,197,2,27,28,23, -196,2,247,22,191,4,11,27,28,23,194,2,250,22,158,2,80,143,44,44,248, -22,129,17,247,22,145,14,11,11,27,28,23,194,2,250,22,158,2,248,22,82, -23,198,2,23,198,2,11,11,28,23,193,2,86,96,23,197,1,23,195,1,23, -194,1,20,13,144,80,144,42,41,40,250,80,144,45,42,40,249,22,31,11,80, -144,47,41,40,22,128,5,248,22,102,23,197,2,27,248,22,111,23,195,2,20, -13,144,80,144,43,41,40,250,80,144,46,42,40,249,22,31,11,80,144,48,41, -40,22,177,5,28,248,22,175,15,23,197,2,23,196,1,86,94,23,196,1,247, -22,153,16,249,247,22,175,5,248,22,164,20,23,197,1,23,201,1,86,94,23, -193,1,27,28,248,22,136,16,23,199,2,23,198,2,27,247,22,177,5,28,192, -249,22,137,16,23,201,2,194,23,199,2,90,144,42,11,89,146,42,39,11,248, -22,132,16,23,202,1,86,94,23,195,1,90,144,41,11,89,146,41,39,11,28, -23,204,2,27,248,22,180,15,23,198,2,19,248,22,147,8,194,28,28,249,22, -132,4,23,195,4,43,249,22,150,8,2,26,249,22,153,8,197,249,22,184,3, -23,199,4,43,11,249,22,7,23,200,2,248,22,184,15,249,22,154,8,250,22, -153,8,201,39,249,22,184,3,23,203,4,43,5,3,46,115,115,249,22,7,23, -200,2,11,2,249,22,7,23,198,2,11,27,28,249,22,169,9,23,196,2,23, -199,2,23,199,2,249,22,129,16,23,198,2,23,196,2,27,28,23,196,2,28, -249,22,169,9,23,198,2,23,200,1,23,200,1,86,94,23,200,1,249,22,129, -16,23,199,2,23,198,2,86,94,23,198,1,11,27,28,249,22,169,9,23,200, -2,70,114,101,108,97,116,105,118,101,86,94,23,198,1,2,27,23,198,1,27, -247,22,158,16,27,247,22,159,16,27,250,22,147,16,23,201,2,11,32,0,88, -148,8,36,39,44,11,9,222,11,27,28,23,194,2,249,22,80,23,201,2,23, -196,1,86,94,23,194,1,11,27,28,23,199,2,28,23,194,2,11,27,250,22, -147,16,23,203,2,11,32,0,88,148,8,36,39,44,11,9,222,11,28,192,249, -22,80,23,202,2,194,11,11,27,28,23,195,2,23,195,2,23,194,2,27,28, -23,196,2,23,196,2,248,22,167,9,23,196,2,27,28,23,205,2,28,23,196, -2,86,94,23,197,1,23,196,2,248,22,167,9,23,198,1,11,27,28,23,195, -2,27,249,22,5,88,148,39,40,51,8,129,3,9,226,24,15,12,11,33,43, -23,203,2,27,28,23,198,2,11,193,28,192,192,28,193,28,23,198,2,28,249, -22,132,4,248,22,82,196,248,22,82,23,201,2,193,11,11,11,11,28,23,193, -2,86,105,23,213,1,23,212,1,23,206,1,23,205,1,23,204,1,23,203,1, -23,201,1,23,200,1,23,197,1,23,196,1,23,195,1,23,194,1,20,13,144, -80,144,60,41,40,250,80,144,8,24,42,40,249,22,31,11,80,144,8,26,41, -40,22,128,5,11,20,13,144,80,144,60,41,40,250,80,144,8,24,42,40,249, -22,31,11,80,144,8,26,41,40,22,177,5,28,248,22,175,15,23,206,2,23, -205,1,86,94,23,205,1,247,22,153,16,249,247,22,163,16,248,22,81,23,196, -1,23,218,1,86,94,23,193,1,27,28,23,195,2,27,249,22,5,88,148,39, -40,51,8,129,3,9,226,25,17,13,12,33,45,23,204,2,27,28,23,200,2, -11,193,28,192,192,28,193,28,199,28,249,22,132,4,248,22,82,196,248,22,82, -202,193,11,11,11,11,28,23,193,2,86,103,23,214,1,23,213,1,23,207,1, -23,206,1,23,205,1,23,202,1,23,201,1,23,197,1,23,196,1,23,195,1, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,51,46,48,46,49,48,84,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,100,0,0,0,1,0,0,8,0,15, +0,26,0,53,0,59,0,73,0,86,0,112,0,129,0,151,0,159,0,171,0, +186,0,202,0,220,0,241,0,253,0,13,1,36,1,60,1,72,1,103,1,108, +1,113,1,131,1,137,1,142,1,151,1,156,1,162,1,167,1,171,1,186,1, +193,1,198,1,202,1,207,1,214,1,225,1,232,1,240,1,87,2,122,2,225, +2,4,3,98,3,133,3,227,3,6,4,29,11,59,11,110,11,185,11,201,11, +217,11,231,11,247,11,66,12,82,12,98,12,114,12,189,12,96,13,112,13,187, +13,182,14,62,15,137,15,44,16,57,16,210,16,138,17,181,17,7,18,140,18, +201,18,209,18,220,18,254,19,101,20,129,20,142,20,63,21,70,21,230,21,250, +21,94,22,116,22,126,22,140,22,178,22,21,23,25,23,32,23,238,23,157,32, +210,32,234,32,2,33,0,0,51,37,0,0,3,1,5,105,110,115,112,48,68, +35,37,98,111,111,116,72,100,108,108,45,115,117,102,102,105,120,1,25,100,101, +102,97,117,108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108, +101,100,67,113,117,111,116,101,29,94,2,5,70,35,37,112,97,114,97,109,122, +11,29,94,2,5,69,35,37,117,116,105,108,115,11,1,24,45,109,111,100,117, +108,101,45,104,97,115,104,45,116,97,98,108,101,45,116,97,98,108,101,78,114, +101,103,105,115,116,101,114,45,122,111,45,112,97,116,104,1,20,100,101,102,97, +117,108,116,45,114,101,97,100,101,114,45,103,117,97,114,100,69,67,65,67,72, +69,45,78,73,45,112,97,116,104,45,99,97,99,104,101,76,112,97,116,104,45, +99,97,99,104,101,45,103,101,116,77,112,97,116,104,45,99,97,99,104,101,45, +115,101,116,33,79,45,108,111,97,100,105,110,103,45,102,105,108,101,110,97,109, +101,1,19,45,108,111,97,100,105,110,103,45,112,114,111,109,112,116,45,116,97, +103,73,45,112,114,101,118,45,114,101,108,116,111,77,45,112,114,101,118,45,114, +101,108,116,111,45,100,105,114,1,21,115,112,108,105,116,45,114,101,108,97,116, +105,118,101,45,115,116,114,105,110,103,1,22,102,111,114,109,97,116,45,115,111, +117,114,99,101,45,108,111,99,97,116,105,111,110,73,111,114,105,103,45,112,97, +114,97,109,122,1,29,115,116,97,110,100,97,114,100,45,109,111,100,117,108,101, +45,110,97,109,101,45,114,101,115,111,108,118,101,114,66,98,111,111,116,66,115, +101,97,108,79,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100, +5,4,46,114,107,116,66,115,97,109,101,6,6,6,110,97,116,105,118,101,5, +3,46,122,111,67,105,108,111,111,112,66,108,111,111,112,65,108,105,98,6,12, +12,109,111,100,117,108,101,45,112,97,116,104,63,68,115,117,98,109,111,100,6, +2,2,46,46,6,1,1,46,66,102,105,108,101,68,112,108,97,110,101,116,6, +8,8,109,97,105,110,46,114,107,116,6,4,4,46,114,107,116,69,105,103,110, +111,114,101,100,27,252,22,133,16,28,249,22,170,9,23,201,2,2,27,86,94, +23,199,1,23,200,1,28,248,22,138,16,23,200,2,249,22,133,16,23,202,1, +23,201,1,249,80,144,50,45,42,23,202,1,23,201,1,23,203,1,2,28,247, +22,182,8,249,80,144,50,46,42,23,203,1,80,144,50,39,41,27,250,22,151, +16,196,11,32,0,88,148,8,36,39,44,11,9,222,11,28,192,249,22,81,195, +194,11,249,22,5,20,20,96,88,148,8,36,40,57,8,129,3,9,226,5,4, +3,6,33,42,23,199,1,23,196,1,23,197,1,23,195,1,27,252,22,133,16, +28,249,22,170,9,23,201,2,2,27,86,94,23,199,1,23,200,1,28,248,22, +138,16,23,200,2,249,22,133,16,23,202,1,23,201,1,249,80,144,50,45,42, +23,202,1,23,201,1,23,203,1,2,28,247,22,182,8,249,80,144,50,46,42, +23,203,1,80,144,50,39,41,27,250,22,151,16,196,11,32,0,88,148,8,36, +39,44,11,9,222,11,28,192,249,22,81,195,194,11,249,22,5,20,20,96,88, +148,8,36,40,57,8,129,3,9,226,5,4,3,6,33,44,23,199,1,23,196, +1,23,197,1,23,195,1,27,250,22,133,16,28,249,22,170,9,23,199,2,2, +27,86,94,23,197,1,23,198,1,28,248,22,138,16,23,198,2,249,22,133,16, +23,200,1,23,199,1,249,80,144,48,45,42,23,200,1,23,199,1,23,201,1, +249,80,144,48,46,42,23,201,1,2,29,27,250,22,151,16,196,11,32,0,88, +148,8,36,39,44,11,9,222,11,28,192,249,22,81,195,194,11,249,22,5,20, +20,96,88,148,8,36,40,55,8,128,3,9,226,5,4,3,6,33,46,23,199, +1,23,196,1,23,197,1,23,195,1,27,250,22,133,16,28,249,22,170,9,23, +199,2,2,27,86,94,23,197,1,23,198,1,28,248,22,138,16,23,198,2,249, +22,133,16,23,200,1,23,199,1,249,80,144,48,45,42,23,200,1,23,199,1, +23,201,1,249,80,144,48,46,42,23,201,1,2,29,27,250,22,151,16,196,11, +32,0,88,148,8,36,39,44,11,9,222,11,28,192,249,22,81,195,194,11,249, +22,5,20,20,96,88,148,8,36,40,55,8,128,3,9,226,5,4,3,6,33, +48,23,199,1,23,196,1,23,197,1,23,195,1,86,95,28,248,80,144,40,43, +42,23,195,2,12,250,22,183,11,2,25,6,12,12,112,97,116,104,45,115,116, +114,105,110,103,63,23,197,2,28,28,23,195,2,28,248,22,65,23,196,2,10, +28,248,22,90,23,196,2,28,249,22,131,4,248,22,94,23,198,2,40,28,28, +248,22,65,248,22,82,23,197,2,10,248,22,168,9,248,22,170,20,23,197,2, +249,22,4,22,65,248,22,171,20,23,198,2,11,11,11,10,12,250,22,183,11, +2,25,6,71,71,40,111,114,47,99,32,35,102,32,115,121,109,98,111,108,63, +32,40,99,111,110,115,47,99,32,40,111,114,47,99,32,35,102,32,115,121,109, +98,111,108,63,41,32,40,110,111,110,45,101,109,112,116,121,45,108,105,115,116, +111,102,32,115,121,109,98,111,108,63,41,41,41,23,197,2,27,28,23,196,2, +247,22,128,5,11,27,28,23,194,2,250,22,159,2,80,143,44,44,248,22,133, +17,247,22,146,14,11,11,27,28,23,194,2,250,22,159,2,248,22,83,23,198, +2,23,198,2,11,11,28,23,193,2,86,96,23,197,1,23,195,1,23,194,1, +20,13,144,80,144,42,41,40,250,80,144,45,42,40,249,22,31,11,80,144,47, +41,40,22,129,5,248,22,103,23,197,2,27,248,22,112,23,195,2,20,13,144, +80,144,43,41,40,250,80,144,46,42,40,249,22,31,11,80,144,48,41,40,22, +178,5,28,248,22,179,15,23,197,2,23,196,1,86,94,23,196,1,247,22,157, +16,249,247,22,176,5,248,22,170,20,23,197,1,23,201,1,86,94,23,193,1, +27,28,248,22,140,16,23,199,2,23,198,2,27,247,22,178,5,28,192,249,22, +141,16,23,201,2,194,23,199,2,90,144,42,11,89,146,42,39,11,248,22,136, +16,23,202,1,86,94,23,195,1,90,144,41,11,89,146,41,39,11,28,23,204, +2,27,248,22,184,15,23,198,2,19,248,22,148,8,194,28,28,249,22,133,4, +23,195,4,43,249,22,151,8,2,26,249,22,154,8,197,249,22,185,3,23,199, +4,43,11,249,22,7,23,200,2,248,22,188,15,249,22,155,8,250,22,154,8, +201,39,249,22,185,3,23,203,4,43,5,3,46,115,115,249,22,7,23,200,2, +11,2,249,22,7,23,198,2,11,27,28,249,22,170,9,23,196,2,23,199,2, +23,199,2,249,22,133,16,23,198,2,23,196,2,27,28,23,196,2,28,249,22, +170,9,23,198,2,23,200,1,23,200,1,86,94,23,200,1,249,22,133,16,23, +199,2,23,198,2,86,95,23,200,1,23,198,1,11,27,28,249,22,170,9,23, +200,2,70,114,101,108,97,116,105,118,101,86,94,23,198,1,2,27,23,198,1, +27,247,22,162,16,27,247,22,163,16,27,250,22,151,16,23,201,2,11,32,0, +88,148,8,36,39,44,11,9,222,11,27,28,23,194,2,249,22,81,23,201,2, +23,196,1,86,94,23,194,1,11,27,28,23,199,2,28,23,194,2,11,27,250, +22,151,16,23,203,2,11,32,0,88,148,8,36,39,44,11,9,222,11,28,192, +249,22,81,23,202,2,194,11,11,27,28,23,195,2,23,195,2,23,194,2,27, +28,23,196,2,23,196,2,248,22,168,9,23,196,2,27,28,23,205,2,28,23, +196,2,86,94,23,197,1,23,196,2,248,22,168,9,23,198,1,86,94,23,197, +1,11,27,28,23,195,2,27,249,22,5,88,148,39,40,51,8,129,3,9,226, +24,15,12,11,33,43,23,203,2,27,28,23,198,2,11,193,28,192,192,28,193, +28,23,198,2,28,249,22,133,4,248,22,83,196,248,22,83,23,201,2,193,11, +11,11,11,28,23,193,2,86,105,23,213,1,23,212,1,23,206,1,23,205,1, +23,204,1,23,203,1,23,201,1,23,200,1,23,197,1,23,196,1,23,195,1, +23,194,1,20,13,144,80,144,60,41,40,250,80,144,8,24,42,40,249,22,31, +11,80,144,8,26,41,40,22,129,5,11,20,13,144,80,144,60,41,40,250,80, +144,8,24,42,40,249,22,31,11,80,144,8,26,41,40,22,178,5,28,248,22, +179,15,23,206,2,23,205,1,86,94,23,205,1,247,22,157,16,249,247,22,167, +16,248,22,82,23,196,1,23,218,1,86,94,23,193,1,27,28,23,195,2,27, +249,22,5,88,148,39,40,51,8,129,3,9,226,25,17,13,12,33,45,23,204, +2,27,28,23,200,2,11,193,28,192,192,28,193,28,199,28,249,22,133,4,248, +22,83,196,248,22,83,202,193,11,11,11,86,94,23,198,1,11,28,23,193,2, +86,103,23,214,1,23,213,1,23,207,1,23,206,1,23,205,1,23,202,1,23, +201,1,23,197,1,23,196,1,23,195,1,20,13,144,80,144,61,41,40,250,80, +144,8,25,42,40,249,22,31,11,80,144,8,27,41,40,22,129,5,23,207,1, 20,13,144,80,144,61,41,40,250,80,144,8,25,42,40,249,22,31,11,80,144, -8,27,41,40,22,128,5,23,207,1,20,13,144,80,144,61,41,40,250,80,144, -8,25,42,40,249,22,31,11,80,144,8,27,41,40,22,177,5,28,248,22,175, -15,23,207,2,23,206,1,86,94,23,206,1,247,22,153,16,249,247,22,163,16, -248,22,81,23,196,1,23,219,1,86,94,23,193,1,27,28,23,197,2,27,249, -22,5,20,20,94,88,148,39,40,51,8,128,3,9,226,26,17,14,13,33,47, -23,210,1,23,205,2,27,28,23,200,2,11,193,28,192,192,28,193,28,23,200, -2,28,249,22,132,4,248,22,82,196,248,22,82,23,203,2,193,11,11,11,86, -94,23,207,1,11,28,23,193,2,86,101,23,208,1,23,206,1,23,205,1,23, -203,1,23,202,1,23,198,1,23,197,1,23,196,1,86,94,27,248,22,81,23, -195,2,28,23,215,2,250,22,156,2,248,22,82,23,219,1,23,219,1,250,22, -90,23,199,1,11,23,211,2,12,20,13,144,80,144,8,23,41,40,250,80,144, -8,26,42,40,249,22,31,11,80,144,8,28,41,40,22,128,5,11,20,13,144, -80,144,8,23,41,40,250,80,144,8,26,42,40,249,22,31,11,80,144,8,28, -41,40,22,177,5,28,248,22,175,15,23,208,2,23,207,1,86,94,23,207,1, -247,22,153,16,249,247,22,175,5,248,22,164,20,23,196,1,23,220,1,86,94, -23,193,1,27,28,23,197,1,27,249,22,5,20,20,95,88,148,39,40,51,8, -128,3,9,226,27,19,15,14,33,49,23,207,1,23,212,1,23,206,1,27,28, -23,201,2,11,193,28,192,192,28,193,28,200,28,249,22,132,4,248,22,82,196, -248,22,82,203,193,11,11,11,86,96,23,209,1,23,204,1,23,203,1,11,28, -23,193,2,86,95,23,207,1,23,198,1,86,94,27,248,22,81,23,195,2,28, -23,216,2,250,22,156,2,248,22,82,23,220,1,23,220,1,250,22,90,23,199, -1,23,213,2,23,212,2,12,20,13,144,80,144,8,24,41,40,250,80,144,8, -27,42,40,249,22,31,11,80,144,8,29,41,40,22,128,5,23,209,1,20,13, -144,80,144,8,24,41,40,250,80,144,8,27,42,40,249,22,31,11,80,144,8, -29,41,40,22,177,5,28,248,22,175,15,23,209,2,23,208,1,86,94,23,208, -1,247,22,153,16,249,247,22,175,5,248,22,164,20,23,196,1,23,221,1,86, -94,23,193,1,28,28,248,22,78,23,220,2,248,22,164,20,23,220,2,10,27, -28,23,199,2,86,94,23,207,1,23,208,1,86,94,23,208,1,23,207,1,28, -28,248,22,78,23,221,2,248,22,167,9,248,22,187,15,23,195,2,11,12,20, -13,144,80,144,8,25,41,40,250,80,144,8,28,42,40,249,22,31,11,80,144, -8,30,41,40,22,128,5,28,23,223,2,28,23,202,1,11,23,196,2,86,94, -23,202,1,11,20,13,144,80,144,8,25,41,40,250,80,144,8,28,42,40,249, -22,31,11,80,144,8,30,41,40,22,177,5,28,248,22,175,15,23,210,2,23, -209,1,86,94,23,209,1,247,22,153,16,249,247,22,175,5,23,195,1,23,222, -1,12,28,23,194,2,250,22,156,2,248,22,82,23,198,1,23,196,1,250,22, -90,23,201,1,23,202,1,23,203,1,12,27,249,22,189,8,80,144,42,50,41, -249,22,191,3,248,22,187,3,248,22,173,2,200,8,128,8,27,28,193,248,22, -176,2,194,11,28,192,27,249,22,100,198,195,28,192,248,22,82,193,11,11,27, -249,22,191,3,248,22,187,3,248,22,173,2,23,199,2,8,128,8,27,249,22, -189,8,80,144,43,50,41,23,196,2,250,22,190,8,80,144,44,50,41,23,197, -1,248,22,175,2,249,22,80,249,22,80,23,204,1,23,205,1,27,28,23,200, -2,248,22,176,2,200,11,28,192,192,9,32,54,88,149,8,38,42,54,11,2, -30,39,223,3,33,69,32,55,88,149,8,38,42,53,11,2,30,39,223,3,33, -68,32,56,88,148,8,36,40,53,11,2,31,222,33,67,32,57,88,149,8,38, -42,53,11,2,30,39,223,3,33,58,28,249,22,128,4,23,197,2,23,195,4, -248,22,90,194,28,249,22,136,9,7,47,249,22,157,7,23,198,2,23,199,2, -249,22,80,250,22,175,7,23,199,2,39,23,200,2,248,2,56,249,22,175,7, -23,199,1,248,22,181,3,23,201,1,250,2,57,23,196,4,196,248,22,181,3, -198,32,59,88,149,8,38,42,55,11,2,30,39,223,3,33,66,32,60,88,149, -8,38,42,54,11,2,30,39,223,3,33,63,32,61,88,149,8,38,42,53,11, -2,30,39,223,3,33,62,28,249,22,128,4,23,197,2,23,195,4,248,22,90, -194,28,249,22,136,9,7,47,249,22,157,7,23,198,2,23,199,2,249,22,80, -250,22,175,7,23,199,2,39,23,200,2,248,2,56,249,22,175,7,23,199,1, -248,22,181,3,23,201,1,250,2,61,23,196,4,196,248,22,181,3,198,28,249, -22,128,4,23,197,2,23,195,4,248,22,90,194,28,249,22,136,9,7,47,249, -22,157,7,23,198,2,23,199,2,249,22,80,250,22,175,7,23,199,2,39,23, -200,2,27,249,22,175,7,23,199,1,248,22,181,3,23,201,1,19,248,22,156, -7,23,195,2,250,2,61,23,196,4,23,197,1,39,2,27,248,22,181,3,23, -197,1,28,249,22,128,4,23,195,2,23,196,4,248,22,90,195,28,249,22,136, -9,7,47,249,22,157,7,23,199,2,23,197,2,249,22,80,250,22,175,7,23, -200,2,39,23,198,2,248,2,56,249,22,175,7,23,200,1,248,22,181,3,23, -199,1,250,2,60,23,197,4,197,248,22,181,3,196,32,64,88,149,8,38,42, -53,11,2,30,39,223,3,33,65,28,249,22,128,4,23,197,2,23,195,4,248, -22,90,194,28,249,22,136,9,7,47,249,22,157,7,23,198,2,23,199,2,249, -22,80,250,22,175,7,23,199,2,39,23,200,2,248,2,56,249,22,175,7,23, -199,1,248,22,181,3,23,201,1,250,2,64,23,196,4,196,248,22,181,3,198, -28,249,22,128,4,23,197,2,23,195,4,248,22,90,194,28,249,22,136,9,7, -47,249,22,157,7,23,198,2,23,199,2,249,22,80,250,22,175,7,23,199,2, -39,23,200,2,27,249,22,175,7,23,199,1,248,22,181,3,23,201,1,19,248, -22,156,7,23,195,2,250,2,60,23,196,4,23,197,1,39,2,27,248,22,181, -3,23,197,1,28,249,22,128,4,23,195,2,23,196,4,248,22,90,195,28,249, -22,136,9,7,47,249,22,157,7,23,199,2,23,197,2,249,22,80,250,22,175, -7,23,200,2,39,23,198,2,27,249,22,175,7,23,200,1,248,22,181,3,23, -199,1,19,248,22,156,7,23,195,2,250,2,64,23,196,4,23,197,1,39,2, -27,248,22,181,3,23,195,1,28,249,22,128,4,23,195,2,23,197,4,248,22, -90,196,28,249,22,136,9,7,47,249,22,157,7,23,200,2,23,197,2,249,22, -80,250,22,175,7,23,201,2,39,23,198,2,248,2,56,249,22,175,7,23,201, -1,248,22,181,3,23,199,1,250,2,59,23,198,4,198,248,22,181,3,196,19, -248,22,156,7,23,195,2,28,249,22,128,4,39,23,195,4,248,22,90,194,28, -249,22,136,9,7,47,249,22,157,7,23,198,2,39,249,22,80,250,22,175,7, -23,199,2,39,39,27,249,22,175,7,23,199,1,40,19,248,22,156,7,23,195, -2,250,2,57,23,196,4,23,197,1,39,2,28,249,22,128,4,40,23,195,4, -248,22,90,194,28,249,22,136,9,7,47,249,22,157,7,23,198,2,40,249,22, -80,250,22,175,7,23,199,2,39,40,248,2,56,249,22,175,7,23,199,1,41, -250,2,59,23,196,4,196,41,2,28,249,22,128,4,23,197,2,23,195,4,248, -22,90,194,28,249,22,136,9,7,47,249,22,157,7,23,198,2,23,199,2,249, -22,80,250,22,175,7,23,199,2,39,23,200,2,248,2,56,249,22,175,7,23, -199,1,248,22,181,3,23,201,1,250,2,55,23,196,4,196,248,22,181,3,198, -28,249,22,128,4,23,197,2,23,195,4,248,22,90,194,28,249,22,136,9,7, -47,249,22,157,7,23,198,2,23,199,2,249,22,80,250,22,175,7,23,199,2, -39,23,200,2,27,249,22,175,7,23,199,1,248,22,181,3,23,201,1,19,248, -22,156,7,23,195,2,250,2,55,23,196,4,23,197,1,39,2,27,248,22,181, -3,23,197,1,28,249,22,128,4,23,195,2,23,196,4,248,22,90,195,28,249, -22,136,9,7,47,249,22,157,7,23,199,2,23,197,2,249,22,80,250,22,175, -7,23,200,2,39,23,198,2,248,2,56,249,22,175,7,23,200,1,248,22,181, -3,23,199,1,250,2,54,23,197,4,197,248,22,181,3,196,32,70,88,148,39, -40,58,11,2,31,222,33,71,28,248,22,88,248,22,82,23,195,2,249,22,7, -9,248,22,164,20,23,196,1,90,144,41,11,89,146,41,39,11,27,248,22,165, -20,23,197,2,28,248,22,88,248,22,82,23,195,2,249,22,7,9,248,22,164, -20,195,90,144,41,11,89,146,41,39,11,27,248,22,165,20,196,28,248,22,88, -248,22,82,23,195,2,249,22,7,9,248,22,164,20,195,90,144,41,11,89,146, -41,39,11,248,2,70,248,22,165,20,196,249,22,7,249,22,80,248,22,164,20, -199,196,195,249,22,7,249,22,80,248,22,164,20,199,196,195,249,22,7,249,22, -80,248,22,164,20,23,200,1,23,197,1,23,196,1,27,19,248,22,156,7,23, -196,2,250,2,54,23,196,4,23,198,1,39,2,28,23,195,1,192,28,248,22, -88,248,22,82,23,195,2,249,22,7,9,248,22,164,20,23,196,1,27,248,22, -165,20,23,195,2,90,144,41,11,89,146,41,39,11,28,248,22,88,248,22,82, -23,197,2,249,22,7,9,248,22,164,20,23,198,1,27,248,22,165,20,23,197, -2,90,144,41,11,89,146,41,39,11,28,248,22,88,248,22,82,23,197,2,249, -22,7,9,248,22,164,20,197,90,144,41,11,89,146,41,39,11,248,2,70,248, -22,165,20,198,249,22,7,249,22,80,248,22,164,20,201,196,195,249,22,7,249, -22,80,248,22,164,20,23,203,1,196,195,249,22,7,249,22,80,248,22,164,20, -23,201,1,23,197,1,23,196,1,248,22,144,12,252,22,162,10,248,22,163,4, -23,200,2,248,22,159,4,23,200,2,248,22,160,4,23,200,2,248,22,161,4, -23,200,2,248,22,162,4,23,200,1,28,24,194,2,12,20,13,144,80,144,39, -41,40,80,143,39,59,89,146,40,40,10,249,22,130,5,21,94,2,32,6,19, -19,112,108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,114,107,116,1, -27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45,114, -101,115,111,108,118,101,114,12,27,28,23,195,2,28,249,22,169,9,23,197,2, -80,143,42,55,86,94,23,195,1,80,143,40,56,27,248,22,153,5,23,197,2, -27,28,248,22,78,23,195,2,248,22,164,20,23,195,1,23,194,1,28,248,22, -175,15,23,194,2,90,144,42,11,89,146,42,39,11,248,22,132,16,23,197,1, -86,95,20,18,144,11,80,143,45,55,199,20,18,144,11,80,143,45,56,192,192, -11,11,28,23,193,2,192,86,94,23,193,1,27,247,22,177,5,28,23,193,2, -192,86,94,23,193,1,247,22,153,16,90,144,42,11,89,146,42,39,11,248,22, -132,16,23,198,2,86,95,23,195,1,23,193,1,28,249,22,168,16,0,11,35, -114,120,34,91,46,93,115,115,36,34,248,22,180,15,23,197,1,249,80,144,44, -61,42,23,199,1,2,26,196,249,80,144,41,57,42,195,10,249,22,12,23,196, -1,80,144,41,54,41,86,96,28,248,22,151,5,23,196,2,12,250,22,182,11, -2,22,6,21,21,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45, -112,97,116,104,63,23,198,2,28,28,23,196,2,248,22,146,14,23,197,2,10, -12,250,22,182,11,2,22,6,20,20,40,111,114,47,99,32,35,102,32,110,97, -109,101,115,112,97,99,101,63,41,23,199,2,28,24,193,2,248,24,194,1,23, -196,2,86,94,23,193,1,12,27,250,22,158,2,80,144,44,44,41,248,22,129, -17,247,22,145,14,11,27,28,23,194,2,23,194,1,86,94,23,194,1,27,249, -22,80,247,22,138,2,247,22,138,2,86,94,250,22,156,2,80,144,46,44,41, -248,22,129,17,247,22,145,14,195,192,86,94,250,22,156,2,248,22,81,23,197, -2,23,200,2,70,100,101,99,108,97,114,101,100,28,23,198,2,27,28,248,22, -78,248,22,153,5,23,200,2,248,22,152,5,248,22,81,248,22,153,5,23,201, -1,23,198,1,27,250,22,158,2,80,144,47,44,41,248,22,129,17,23,204,1, -11,28,23,193,2,27,250,22,158,2,248,22,82,23,198,1,23,198,2,11,28, -23,193,2,250,22,156,2,248,22,165,20,23,200,1,23,198,1,23,196,1,12, -12,12,86,94,251,22,139,12,247,22,143,12,67,101,114,114,111,114,6,69,69, -100,101,102,97,117,108,116,32,109,111,100,117,108,101,32,110,97,109,101,32,114, -101,115,111,108,118,101,114,32,99,97,108,108,101,100,32,119,105,116,104,32,116, -104,114,101,101,32,97,114,103,117,109,101,110,116,115,32,40,100,101,112,114,101, -99,97,116,101,100,41,11,251,24,197,1,23,198,1,23,199,1,23,200,1,10, -32,81,88,148,39,41,50,11,78,102,108,97,116,116,101,110,45,115,117,98,45, -112,97,116,104,222,33,84,32,82,88,148,39,43,57,11,2,31,222,33,83,28, -248,22,88,23,197,2,28,248,22,88,195,192,249,22,80,194,248,22,95,197,28, -249,22,171,9,248,22,81,23,199,2,2,35,28,248,22,88,23,196,2,86,95, -23,196,1,23,195,1,250,22,178,11,2,22,6,37,37,116,111,111,32,109,97, -110,121,32,34,46,46,34,115,32,105,110,32,115,117,98,109,111,100,117,108,101, -32,112,97,116,104,58,32,126,46,115,250,22,91,2,34,28,249,22,171,9,23, -201,2,2,36,23,199,1,28,248,22,175,15,23,200,2,23,199,1,249,22,90, -28,248,22,64,23,202,2,2,5,2,37,23,201,1,23,200,1,251,2,82,196, -197,248,22,82,199,248,22,165,20,200,251,2,82,196,197,249,22,80,248,22,164, -20,202,200,248,22,165,20,200,251,2,82,196,197,9,197,27,250,22,176,7,27, -28,23,199,2,28,247,22,131,12,248,80,144,47,58,42,23,200,2,11,11,28, -192,192,6,29,29,115,116,97,110,100,97,114,100,45,109,111,100,117,108,101,45, -110,97,109,101,45,114,101,115,111,108,118,101,114,6,2,2,58,32,250,22,179, -16,0,7,35,114,120,34,92,110,34,23,203,1,249,22,137,8,6,23,23,10, -32,32,102,111,114,32,109,111,100,117,108,101,32,112,97,116,104,58,32,126,115, -10,23,202,2,248,22,174,13,28,23,196,2,251,22,182,12,23,198,1,247,22, -27,248,22,90,23,201,1,23,199,1,86,94,23,196,1,250,22,145,13,23,197, -1,247,22,27,23,198,1,32,86,88,148,8,36,40,53,11,69,115,115,45,62, -114,107,116,222,33,87,19,248,22,156,7,194,28,249,22,132,4,23,195,4,42, -28,249,22,169,9,7,46,249,22,157,7,197,249,22,184,3,23,199,4,42,28, -28,249,22,169,9,7,115,249,22,157,7,197,249,22,184,3,23,199,4,41,249, -22,169,9,7,115,249,22,157,7,197,249,22,184,3,23,199,4,40,11,249,22, -176,7,250,22,175,7,198,39,249,22,184,3,23,200,4,42,2,40,193,193,193, -2,28,249,22,159,7,194,2,36,2,27,28,249,22,159,7,194,2,35,64,117, -112,192,0,8,35,114,120,34,91,46,93,34,32,90,88,148,8,36,40,50,11, -2,31,222,33,91,28,248,22,88,23,194,2,9,250,22,91,6,4,4,10,32, -32,32,248,22,179,15,248,22,103,23,198,2,248,2,90,248,22,165,20,23,198, -1,28,249,22,171,9,248,22,82,23,200,2,23,197,1,28,249,22,169,9,248, -22,164,20,23,200,1,23,196,1,251,22,178,11,2,22,6,41,41,99,121,99, -108,101,32,105,110,32,108,111,97,100,105,110,103,10,32,32,97,116,32,112,97, -116,104,58,32,126,97,10,32,32,112,97,116,104,115,58,126,97,23,200,1,249, -22,1,22,176,7,248,2,90,248,22,95,23,201,1,12,12,247,23,193,1,250, -22,157,4,11,196,195,20,13,144,80,144,49,53,41,249,22,80,249,22,80,23, -198,1,23,202,1,23,195,1,20,13,144,80,144,49,41,40,252,80,144,54,42, -40,249,22,31,11,80,144,56,41,40,22,191,4,23,201,2,22,129,5,248,28, -23,208,2,20,20,94,88,148,8,36,40,49,11,9,223,15,33,94,23,208,1, -86,94,23,208,1,22,7,28,248,22,64,23,207,2,23,206,1,28,28,248,22, -78,23,207,2,249,22,169,9,248,22,164,20,23,209,2,2,32,11,23,206,1, -86,94,23,206,1,28,248,22,151,5,23,203,2,27,248,22,153,5,23,204,2, -28,248,22,64,193,249,22,90,2,5,194,192,23,202,2,249,247,22,176,5,23, -201,1,27,248,22,68,248,22,179,15,23,202,1,28,23,204,2,28,250,22,158, -2,248,22,164,20,23,202,1,23,202,1,11,249,22,80,11,205,249,22,80,194, -205,192,86,96,28,248,22,161,5,23,196,2,12,28,248,22,155,4,23,198,2, -250,22,180,11,11,6,15,15,98,97,100,32,109,111,100,117,108,101,32,112,97, -116,104,23,200,2,250,22,182,11,2,22,2,33,23,198,2,28,28,23,196,2, -248,22,151,5,23,197,2,10,12,250,22,182,11,2,22,6,31,31,40,111,114, -47,99,32,35,102,32,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101, -45,112,97,116,104,63,41,23,199,2,28,28,23,197,2,248,22,155,4,23,198, -2,10,12,250,22,182,11,2,22,6,17,17,40,111,114,47,99,32,35,102,32, -115,121,110,116,97,120,63,41,23,200,2,28,28,248,22,78,23,196,2,249,22, -169,9,248,22,164,20,23,198,2,2,5,11,86,97,23,198,1,23,197,1,23, -196,1,23,193,1,248,22,152,5,248,22,102,23,197,1,28,28,248,22,78,23, -196,2,28,249,22,169,9,248,22,164,20,23,198,2,2,34,28,248,22,78,248, -22,102,23,197,2,249,22,169,9,248,22,106,23,198,2,2,5,11,11,11,86, -97,23,198,1,23,197,1,23,196,1,23,193,1,248,22,152,5,249,2,81,248, -22,119,23,199,2,248,22,104,23,199,1,28,28,248,22,78,23,196,2,28,249, -22,169,9,248,22,164,20,23,198,2,2,34,28,28,249,22,171,9,248,22,102, -23,198,2,2,36,10,249,22,171,9,248,22,102,23,198,2,2,35,28,23,196, -2,27,248,22,153,5,23,198,2,28,248,22,64,193,10,28,248,22,78,193,248, -22,64,248,22,164,20,194,11,11,11,11,11,86,96,23,198,1,23,197,1,23, -193,1,27,248,22,153,5,23,198,1,248,22,152,5,249,2,81,28,248,22,78, -23,197,2,248,22,164,20,23,197,2,23,196,2,27,28,249,22,171,9,248,22, -102,23,203,2,2,35,248,22,165,20,200,248,22,104,200,28,248,22,78,23,198, -2,249,22,94,248,22,165,20,199,194,192,28,28,248,22,78,23,196,2,249,22, -169,9,248,22,164,20,23,198,2,2,38,11,86,94,248,80,144,41,8,28,42, -23,194,2,253,24,199,1,23,201,1,23,202,1,23,203,1,23,204,1,11,80, -143,46,59,28,28,248,22,78,23,196,2,28,249,22,169,9,248,22,164,20,23, -198,2,2,34,28,248,22,78,248,22,102,23,197,2,249,22,169,9,248,22,106, -23,198,2,2,38,11,11,11,86,94,248,80,144,41,8,28,42,23,194,2,253, -24,199,1,248,22,102,23,202,2,23,202,1,23,203,1,23,204,1,248,22,104, -23,202,1,80,143,46,59,86,94,23,193,1,27,88,148,8,36,40,57,8,240, -0,0,8,0,1,19,115,104,111,119,45,99,111,108,108,101,99,116,105,111,110, -45,101,114,114,225,2,5,3,33,85,27,28,248,22,78,23,198,2,28,249,22, -169,9,2,34,248,22,164,20,23,200,2,27,248,22,102,23,199,2,28,28,249, -22,171,9,23,195,2,2,36,10,249,22,171,9,23,195,2,2,35,86,94,23, -193,1,28,23,199,2,27,248,22,153,5,23,201,2,28,248,22,78,193,248,22, -164,20,193,192,250,22,178,11,2,22,6,45,45,110,111,32,98,97,115,101,32, -112,97,116,104,32,102,111,114,32,114,101,108,97,116,105,118,101,32,115,117,98, -109,111,100,117,108,101,32,112,97,116,104,58,32,126,46,115,23,201,2,192,23, -197,2,23,197,2,27,28,248,22,78,23,199,2,28,249,22,169,9,2,34,248, -22,164,20,23,201,2,27,28,28,28,249,22,171,9,248,22,102,23,202,2,2, -36,10,249,22,171,9,248,22,102,23,202,2,2,35,23,200,2,11,27,248,22, -153,5,23,202,2,27,28,249,22,171,9,248,22,102,23,204,2,2,35,248,22, -165,20,23,202,1,248,22,104,23,202,1,28,248,22,78,23,195,2,249,2,81, -248,22,164,20,23,197,2,249,22,94,248,22,165,20,23,199,1,23,197,1,249, -2,81,23,196,1,23,195,1,249,2,81,2,36,28,249,22,171,9,248,22,102, -23,204,2,2,35,248,22,165,20,23,202,1,248,22,104,23,202,1,28,248,22, -78,193,248,22,165,20,193,11,11,11,27,28,248,22,64,23,196,2,27,248,80, -144,46,51,42,249,22,80,23,199,2,248,22,129,17,247,22,145,14,28,23,193, -2,192,86,94,23,193,1,90,144,41,11,89,146,41,39,11,249,80,144,49,57, -42,248,22,71,23,201,2,11,27,28,248,22,88,23,195,2,2,39,249,22,176, -7,23,197,2,2,40,252,80,144,53,8,23,42,23,205,1,28,248,22,88,23, -200,2,23,200,1,86,94,23,200,1,248,22,81,23,200,2,28,248,22,88,23, -200,2,86,94,23,199,1,9,248,22,82,23,200,1,23,198,1,10,28,248,22, -153,7,23,196,2,86,94,23,196,1,27,248,80,144,46,8,29,42,23,202,2, -27,248,80,144,47,51,42,249,22,80,23,200,2,23,197,2,28,23,193,2,192, -86,94,23,193,1,90,144,41,11,89,146,41,39,11,249,80,144,50,57,42,23, -201,2,11,28,248,22,88,23,194,2,86,94,23,193,1,249,22,129,16,23,198, -1,248,2,86,23,197,1,250,22,1,22,129,16,23,199,1,249,22,94,249,22, -2,32,0,88,148,8,36,40,47,11,9,222,33,88,23,200,1,248,22,90,248, -2,86,23,201,1,28,248,22,175,15,23,196,2,86,94,23,196,1,248,80,144, -45,8,30,42,248,22,139,16,28,248,22,136,16,23,198,2,23,197,2,249,22, -137,16,23,199,2,248,80,144,49,8,29,42,23,205,2,28,249,22,169,9,248, -22,81,23,198,2,2,32,27,248,80,144,46,51,42,249,22,80,23,199,2,248, -22,129,17,247,22,145,14,28,23,193,2,192,86,94,23,193,1,90,144,41,11, -89,146,41,39,11,249,80,144,49,57,42,248,22,102,23,201,2,11,27,28,248, -22,88,248,22,104,23,201,2,28,248,22,88,23,195,2,249,22,172,16,2,89, -23,197,2,11,10,27,28,23,194,2,248,2,86,23,197,2,28,248,22,88,23, -196,2,2,39,28,249,22,172,16,2,89,23,198,2,248,2,86,23,197,2,249, -22,176,7,23,198,2,2,40,27,28,23,195,1,86,94,23,197,1,249,22,94, -28,248,22,88,248,22,104,23,205,2,21,93,6,5,5,109,122,108,105,98,249, -22,1,22,94,249,22,2,80,144,56,8,31,42,248,22,104,23,208,2,23,198, -1,28,248,22,88,23,197,2,86,94,23,196,1,248,22,90,23,198,1,86,94, -23,197,1,23,196,1,252,80,144,55,8,23,42,23,207,1,248,22,81,23,199, -2,248,22,165,20,23,199,1,23,199,1,10,28,249,22,169,9,248,22,164,20, -23,198,2,2,37,248,80,144,45,8,30,42,248,22,139,16,249,22,137,16,248, -22,141,16,248,22,102,23,201,2,248,80,144,49,8,29,42,23,205,2,12,86, -94,28,28,248,22,175,15,23,194,2,10,248,22,184,8,23,194,2,12,28,23, -201,2,250,22,180,11,69,114,101,113,117,105,114,101,249,22,137,8,6,17,17, -98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2, -248,22,81,23,199,2,6,0,0,23,204,2,250,22,182,11,2,22,2,33,23, -198,2,27,28,248,22,184,8,23,195,2,249,22,189,8,23,196,2,39,249,22, -139,16,248,22,140,16,23,197,2,11,27,28,248,22,184,8,23,196,2,249,22, -189,8,23,197,2,40,248,80,144,47,8,24,42,23,195,2,90,144,42,11,89, -146,42,39,11,28,248,22,184,8,23,199,2,250,22,7,2,41,249,22,189,8, -23,203,2,41,2,41,248,22,132,16,23,198,2,86,95,23,195,1,23,193,1, -27,28,248,22,184,8,23,200,2,249,22,189,8,23,201,2,42,249,80,144,52, -61,42,23,197,2,5,0,27,28,248,22,184,8,23,201,2,249,22,189,8,23, -202,2,43,248,22,152,5,23,200,2,27,250,22,158,2,80,144,55,44,41,248, -22,129,17,247,22,145,14,11,27,28,23,194,2,23,194,1,86,94,23,194,1, -27,249,22,80,247,22,138,2,247,22,138,2,86,94,250,22,156,2,80,144,57, -44,41,248,22,129,17,247,22,145,14,195,192,27,28,23,204,2,248,22,152,5, -249,22,80,248,22,153,5,23,200,2,23,207,2,23,196,2,86,95,28,23,212, -2,28,250,22,158,2,248,22,81,23,198,2,195,11,86,96,23,211,1,23,204, -1,23,194,1,12,27,251,22,31,11,80,144,59,53,41,9,28,248,22,15,80, -144,60,54,41,80,144,59,54,41,247,22,17,27,248,22,129,17,247,22,145,14, -86,94,249,22,3,88,148,8,36,40,57,11,9,226,13,12,2,3,33,92,23, -196,2,248,28,248,22,15,80,144,58,54,41,32,0,88,148,39,40,45,11,9, -222,33,93,80,144,57,8,32,42,20,20,98,88,148,39,39,8,25,8,240,12, -64,0,0,9,233,18,21,14,15,12,11,7,6,4,1,2,33,95,23,195,1, -23,194,1,23,197,1,23,207,1,23,214,1,12,28,28,248,22,184,8,23,204, -1,86,94,23,212,1,11,28,23,212,1,28,248,22,153,7,23,206,2,10,28, -248,22,64,23,206,2,10,28,248,22,78,23,206,2,249,22,169,9,248,22,164, -20,23,208,2,2,32,11,11,249,80,144,56,52,42,28,248,22,153,7,23,208, -2,249,22,80,23,209,1,248,80,144,59,8,29,42,23,215,1,86,94,23,212, -1,249,22,80,23,209,1,248,22,129,17,247,22,145,14,252,22,186,8,23,209, -1,23,208,1,23,206,1,23,204,1,23,203,1,12,192,86,96,20,18,144,11, -80,143,39,59,248,80,144,40,8,27,40,249,22,31,11,80,144,42,41,40,248, -22,190,4,80,144,40,60,41,248,22,176,5,80,144,40,40,42,248,22,144,15, -80,144,40,48,42,20,18,144,11,80,143,39,59,248,80,144,40,8,27,40,249, -22,31,11,80,144,42,41,40,20,18,144,11,80,143,39,59,248,80,144,40,8, -27,40,249,22,31,11,80,144,42,41,40,145,39,9,20,121,145,2,1,39,16, -1,11,16,0,20,27,15,56,9,2,2,2,2,29,11,11,11,11,11,11,11, -9,9,11,11,11,10,41,80,143,39,39,20,121,145,2,1,44,16,28,2,3, -2,4,30,2,6,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105, -111,110,45,107,101,121,11,6,30,2,6,1,23,101,120,116,101,110,100,45,112, -97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,11,4,30,2,7,74, -112,97,116,104,45,115,116,114,105,110,103,63,42,196,15,2,8,30,2,7,73, -114,101,114,111,111,116,45,112,97,116,104,44,196,16,30,2,7,77,112,97,116, -104,45,97,100,100,45,115,117,102,102,105,120,44,196,12,2,9,2,10,2,11, -2,12,2,13,2,14,2,15,2,16,2,17,2,18,2,19,2,20,2,21,2, -22,30,2,7,1,19,112,97,116,104,45,114,101,112,108,97,99,101,45,115,117, -102,102,105,120,44,196,14,30,2,7,75,102,105,110,100,45,99,111,108,45,102, -105,108,101,49,196,4,30,2,7,78,110,111,114,109,97,108,45,99,97,115,101, -45,112,97,116,104,42,196,11,2,23,2,24,30,2,6,76,114,101,112,97,114, -97,109,101,116,101,114,105,122,101,11,7,16,0,40,42,39,16,0,39,16,16, -2,15,2,16,2,8,2,12,2,17,2,18,2,11,2,4,2,10,2,3,2, -20,2,13,2,14,2,9,2,19,2,22,55,11,11,11,16,3,2,23,2,21, -2,24,16,3,11,11,11,16,3,2,23,2,21,2,24,42,42,40,12,11,11, -16,0,16,0,16,0,39,39,11,12,11,11,16,0,16,0,16,0,39,39,16, -24,20,15,16,2,248,22,180,8,71,115,111,45,115,117,102,102,105,120,80,144, -39,39,40,20,15,16,2,88,148,39,41,8,39,8,189,3,2,4,223,0,33, -50,80,144,39,40,40,20,15,16,2,32,0,88,148,8,36,44,55,11,2,9, -222,33,51,80,144,39,47,40,20,15,16,2,20,28,143,32,0,88,148,8,36, -40,45,11,2,10,222,192,32,0,88,148,8,36,40,45,11,2,10,222,192,80, -144,39,48,40,20,15,16,2,247,22,141,2,80,144,39,44,40,20,15,16,2, -8,128,8,80,144,39,49,40,20,15,16,2,249,22,185,8,8,128,8,11,80, -144,39,50,40,20,15,16,2,88,148,8,36,40,53,8,128,32,2,13,223,0, -33,52,80,144,39,51,40,20,15,16,2,88,148,8,36,41,57,8,128,32,2, -14,223,0,33,53,80,144,39,52,40,20,15,16,2,247,22,76,80,144,39,53, -40,20,15,16,2,248,22,16,76,109,111,100,117,108,101,45,108,111,97,100,105, -110,103,80,144,39,54,40,20,15,16,2,11,80,143,39,55,20,15,16,2,11, -80,143,39,56,20,15,16,2,32,0,88,148,39,41,60,11,2,19,222,33,72, -80,144,39,57,40,20,15,16,2,32,0,88,148,8,36,40,52,11,2,20,222, -33,73,80,144,39,58,40,20,15,16,2,11,80,143,39,59,20,15,16,2,88, -149,8,34,40,48,8,240,4,0,16,0,1,21,112,114,101,112,45,112,108,97, -110,101,116,45,114,101,115,111,108,118,101,114,33,40,224,1,0,33,74,80,144, -39,8,28,42,20,15,16,2,88,148,39,40,53,8,240,0,0,3,0,69,103, -101,116,45,100,105,114,223,0,33,75,80,144,39,8,29,42,20,15,16,2,88, -148,39,40,52,8,240,0,0,64,0,74,112,97,116,104,45,115,115,45,62,114, -107,116,223,0,33,76,80,144,39,8,30,42,20,15,16,2,88,148,8,36,40, -48,8,240,0,0,4,0,9,223,0,33,77,80,144,39,8,31,42,20,15,16, -2,88,148,39,40,48,8,240,0,128,0,0,9,223,0,33,78,80,144,39,8, -32,42,20,15,16,2,27,11,20,19,143,39,90,144,40,10,89,146,40,39,10, -20,26,96,2,22,88,148,8,36,41,57,8,32,9,224,2,1,33,79,88,148, -39,42,52,11,9,223,0,33,80,88,148,39,43,8,32,16,4,8,240,44,240, -0,0,8,240,220,241,0,0,40,39,9,224,2,1,33,96,207,80,144,39,60, -40,20,15,16,2,88,148,39,39,48,16,2,8,134,8,8,176,32,2,23,223, -0,33,97,80,144,39,8,25,40,20,15,16,2,20,28,143,88,148,8,36,39, -48,16,2,43,8,144,32,2,24,223,0,33,98,88,148,8,36,39,48,16,2, -43,8,144,32,2,24,223,0,33,99,80,144,39,8,26,40,96,29,94,2,5, -70,35,37,107,101,114,110,101,108,11,29,94,2,5,71,35,37,109,105,110,45, -115,116,120,11,2,7,2,6,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 9715); +8,27,41,40,22,178,5,28,248,22,179,15,23,207,2,23,206,1,86,94,23, +206,1,247,22,157,16,249,247,22,167,16,248,22,82,23,196,1,23,219,1,86, +94,23,193,1,27,28,23,197,2,27,249,22,5,20,20,94,88,148,39,40,51, +8,128,3,9,226,26,17,14,13,33,47,23,210,1,23,205,2,27,28,23,200, +2,11,193,28,192,192,28,193,28,23,200,2,28,249,22,133,4,248,22,83,196, +248,22,83,23,203,2,193,11,11,11,86,94,23,207,1,11,28,23,193,2,86, +101,23,208,1,23,206,1,23,205,1,23,203,1,23,202,1,23,198,1,23,197, +1,23,196,1,86,94,27,248,22,82,23,195,2,28,23,215,2,250,22,157,2, +248,22,83,23,219,1,23,219,1,250,22,91,23,199,1,11,23,211,2,12,20, +13,144,80,144,8,23,41,40,250,80,144,8,26,42,40,249,22,31,11,80,144, +8,28,41,40,22,129,5,11,20,13,144,80,144,8,23,41,40,250,80,144,8, +26,42,40,249,22,31,11,80,144,8,28,41,40,22,178,5,28,248,22,179,15, +23,208,2,23,207,1,86,94,23,207,1,247,22,157,16,249,247,22,176,5,248, +22,170,20,23,196,1,23,220,1,86,94,23,193,1,27,28,23,197,1,27,249, +22,5,20,20,95,88,148,39,40,51,8,128,3,9,226,27,19,15,14,33,49, +23,207,1,23,212,1,23,206,1,27,28,23,201,2,11,193,28,192,192,28,193, +28,200,28,249,22,133,4,248,22,83,196,248,22,83,203,193,11,11,11,86,97, +23,209,1,23,204,1,23,203,1,23,199,1,11,28,23,193,2,86,95,23,207, +1,23,198,1,86,94,27,248,22,82,23,195,2,28,23,216,2,250,22,157,2, +248,22,83,23,220,1,23,220,1,250,22,91,23,199,1,23,213,2,23,212,2, +12,20,13,144,80,144,8,24,41,40,250,80,144,8,27,42,40,249,22,31,11, +80,144,8,29,41,40,22,129,5,23,209,1,20,13,144,80,144,8,24,41,40, +250,80,144,8,27,42,40,249,22,31,11,80,144,8,29,41,40,22,178,5,28, +248,22,179,15,23,209,2,23,208,1,86,94,23,208,1,247,22,157,16,249,247, +22,176,5,248,22,170,20,23,196,1,23,221,1,86,96,23,216,1,23,215,1, +23,193,1,28,28,248,22,79,23,220,2,248,22,170,20,23,220,2,10,27,28, +23,199,2,86,94,23,207,1,23,208,1,86,94,23,208,1,23,207,1,28,28, +248,22,79,23,221,2,248,22,168,9,248,22,191,15,23,195,2,11,12,20,13, +144,80,144,8,25,41,40,250,80,144,8,28,42,40,249,22,31,11,80,144,8, +30,41,40,22,129,5,28,23,223,2,28,23,202,1,11,23,196,2,86,94,23, +202,1,11,20,13,144,80,144,8,25,41,40,250,80,144,8,28,42,40,249,22, +31,11,80,144,8,30,41,40,22,178,5,28,248,22,179,15,23,210,2,23,209, +1,86,94,23,209,1,247,22,157,16,249,247,22,176,5,23,195,1,23,222,1, +12,28,23,194,2,250,22,157,2,248,22,83,23,198,1,23,196,1,250,22,91, +23,201,1,23,202,1,23,203,1,12,27,249,22,190,8,80,144,42,50,41,249, +22,128,4,248,22,188,3,248,22,174,2,200,8,128,8,27,28,193,248,22,177, +2,194,11,28,192,27,249,22,101,198,195,28,192,248,22,83,193,11,11,27,249, +22,128,4,248,22,188,3,248,22,174,2,23,199,2,8,128,8,27,249,22,190, +8,80,144,43,50,41,23,196,2,250,22,191,8,80,144,44,50,41,23,197,1, +248,22,176,2,249,22,81,249,22,81,23,204,1,23,205,1,27,28,23,200,2, +248,22,177,2,200,11,28,192,192,9,32,54,88,149,8,38,42,54,11,2,30, +39,223,3,33,69,32,55,88,149,8,38,42,53,11,2,30,39,223,3,33,68, +32,56,88,148,8,36,40,53,11,2,31,222,33,67,32,57,88,149,8,38,42, +53,11,2,30,39,223,3,33,58,28,249,22,129,4,23,197,2,23,195,4,248, +22,91,194,28,249,22,137,9,7,47,249,22,158,7,23,198,2,23,199,2,249, +22,81,250,22,176,7,23,199,2,39,23,200,2,248,2,56,249,22,176,7,23, +199,1,248,22,182,3,23,201,1,250,2,57,23,196,4,196,248,22,182,3,198, +32,59,88,149,8,38,42,55,11,2,30,39,223,3,33,66,32,60,88,149,8, +38,42,54,11,2,30,39,223,3,33,63,32,61,88,149,8,38,42,53,11,2, +30,39,223,3,33,62,28,249,22,129,4,23,197,2,23,195,4,248,22,91,194, +28,249,22,137,9,7,47,249,22,158,7,23,198,2,23,199,2,249,22,81,250, +22,176,7,23,199,2,39,23,200,2,248,2,56,249,22,176,7,23,199,1,248, +22,182,3,23,201,1,250,2,61,23,196,4,196,248,22,182,3,198,28,249,22, +129,4,23,197,2,23,195,4,248,22,91,194,28,249,22,137,9,7,47,249,22, +158,7,23,198,2,23,199,2,249,22,81,250,22,176,7,23,199,2,39,23,200, +2,27,249,22,176,7,23,199,1,248,22,182,3,23,201,1,19,248,22,157,7, +23,195,2,250,2,61,23,196,4,23,197,1,39,2,27,248,22,182,3,23,197, +1,28,249,22,129,4,23,195,2,23,196,4,248,22,91,195,28,249,22,137,9, +7,47,249,22,158,7,23,199,2,23,197,2,249,22,81,250,22,176,7,23,200, +2,39,23,198,2,248,2,56,249,22,176,7,23,200,1,248,22,182,3,23,199, +1,250,2,60,23,197,4,197,248,22,182,3,196,32,64,88,149,8,38,42,53, +11,2,30,39,223,3,33,65,28,249,22,129,4,23,197,2,23,195,4,248,22, +91,194,28,249,22,137,9,7,47,249,22,158,7,23,198,2,23,199,2,249,22, +81,250,22,176,7,23,199,2,39,23,200,2,248,2,56,249,22,176,7,23,199, +1,248,22,182,3,23,201,1,250,2,64,23,196,4,196,248,22,182,3,198,28, +249,22,129,4,23,197,2,23,195,4,248,22,91,194,28,249,22,137,9,7,47, +249,22,158,7,23,198,2,23,199,2,249,22,81,250,22,176,7,23,199,2,39, +23,200,2,27,249,22,176,7,23,199,1,248,22,182,3,23,201,1,19,248,22, +157,7,23,195,2,250,2,60,23,196,4,23,197,1,39,2,27,248,22,182,3, +23,197,1,28,249,22,129,4,23,195,2,23,196,4,248,22,91,195,28,249,22, +137,9,7,47,249,22,158,7,23,199,2,23,197,2,249,22,81,250,22,176,7, +23,200,2,39,23,198,2,27,249,22,176,7,23,200,1,248,22,182,3,23,199, +1,19,248,22,157,7,23,195,2,250,2,64,23,196,4,23,197,1,39,2,27, +248,22,182,3,23,195,1,28,249,22,129,4,23,195,2,23,197,4,248,22,91, +196,28,249,22,137,9,7,47,249,22,158,7,23,200,2,23,197,2,249,22,81, +250,22,176,7,23,201,2,39,23,198,2,248,2,56,249,22,176,7,23,201,1, +248,22,182,3,23,199,1,250,2,59,23,198,4,198,248,22,182,3,196,19,248, +22,157,7,23,195,2,28,249,22,129,4,39,23,195,4,248,22,91,194,28,249, +22,137,9,7,47,249,22,158,7,23,198,2,39,249,22,81,250,22,176,7,23, +199,2,39,39,27,249,22,176,7,23,199,1,40,19,248,22,157,7,23,195,2, +250,2,57,23,196,4,23,197,1,39,2,28,249,22,129,4,40,23,195,4,248, +22,91,194,28,249,22,137,9,7,47,249,22,158,7,23,198,2,40,249,22,81, +250,22,176,7,23,199,2,39,40,248,2,56,249,22,176,7,23,199,1,41,250, +2,59,23,196,4,196,41,2,28,249,22,129,4,23,197,2,23,195,4,248,22, +91,194,28,249,22,137,9,7,47,249,22,158,7,23,198,2,23,199,2,249,22, +81,250,22,176,7,23,199,2,39,23,200,2,248,2,56,249,22,176,7,23,199, +1,248,22,182,3,23,201,1,250,2,55,23,196,4,196,248,22,182,3,198,28, +249,22,129,4,23,197,2,23,195,4,248,22,91,194,28,249,22,137,9,7,47, +249,22,158,7,23,198,2,23,199,2,249,22,81,250,22,176,7,23,199,2,39, +23,200,2,27,249,22,176,7,23,199,1,248,22,182,3,23,201,1,19,248,22, +157,7,23,195,2,250,2,55,23,196,4,23,197,1,39,2,27,248,22,182,3, +23,197,1,28,249,22,129,4,23,195,2,23,196,4,248,22,91,195,28,249,22, +137,9,7,47,249,22,158,7,23,199,2,23,197,2,249,22,81,250,22,176,7, +23,200,2,39,23,198,2,248,2,56,249,22,176,7,23,200,1,248,22,182,3, +23,199,1,250,2,54,23,197,4,197,248,22,182,3,196,32,70,88,148,39,40, +58,11,2,31,222,33,71,28,248,22,89,248,22,83,23,195,2,249,22,7,9, +248,22,170,20,23,196,1,90,144,41,11,89,146,41,39,11,27,248,22,171,20, +23,197,2,28,248,22,89,248,22,83,23,195,2,249,22,7,9,248,22,170,20, +195,90,144,41,11,89,146,41,39,11,27,248,22,171,20,196,28,248,22,89,248, +22,83,23,195,2,249,22,7,9,248,22,170,20,195,90,144,41,11,89,146,41, +39,11,248,2,70,248,22,171,20,196,249,22,7,249,22,81,248,22,170,20,199, +196,195,249,22,7,249,22,81,248,22,170,20,199,196,195,249,22,7,249,22,81, +248,22,170,20,23,200,1,23,197,1,23,196,1,27,19,248,22,157,7,23,196, +2,250,2,54,23,196,4,23,198,1,39,2,28,23,195,1,192,28,248,22,89, +248,22,83,23,195,2,249,22,7,9,248,22,170,20,23,196,1,27,248,22,171, +20,23,195,2,90,144,41,11,89,146,41,39,11,28,248,22,89,248,22,83,23, +197,2,249,22,7,9,248,22,170,20,23,198,1,27,248,22,171,20,23,197,2, +90,144,41,11,89,146,41,39,11,28,248,22,89,248,22,83,23,197,2,249,22, +7,9,248,22,170,20,197,90,144,41,11,89,146,41,39,11,248,2,70,248,22, +171,20,198,249,22,7,249,22,81,248,22,170,20,201,196,195,249,22,7,249,22, +81,248,22,170,20,23,203,1,196,195,249,22,7,249,22,81,248,22,170,20,23, +201,1,23,197,1,23,196,1,248,22,145,12,252,22,163,10,248,22,164,4,23, +200,2,248,22,160,4,23,200,2,248,22,161,4,23,200,2,248,22,162,4,23, +200,2,248,22,163,4,23,200,1,28,24,194,2,12,20,13,144,80,144,39,41, +40,80,143,39,59,89,146,40,40,10,249,22,131,5,21,94,2,32,6,19,19, +112,108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,114,107,116,1,27, +112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101, +115,111,108,118,101,114,12,27,28,23,195,2,28,249,22,170,9,23,197,2,80, +143,42,55,86,94,23,195,1,80,143,40,56,27,248,22,154,5,23,197,2,27, +28,248,22,79,23,195,2,248,22,170,20,23,195,1,23,194,1,28,248,22,179, +15,23,194,2,90,144,42,11,89,146,42,39,11,248,22,136,16,23,197,1,86, +95,20,18,144,11,80,143,45,55,199,20,18,144,11,80,143,45,56,192,192,11, +86,94,23,195,1,11,28,23,193,2,192,86,94,23,193,1,27,247,22,178,5, +28,23,193,2,192,86,94,23,193,1,247,22,157,16,90,144,42,11,89,146,42, +39,11,248,22,136,16,23,198,2,86,95,23,195,1,23,193,1,28,249,22,172, +16,0,11,35,114,120,34,91,46,93,115,115,36,34,248,22,184,15,23,197,1, +249,80,144,44,61,42,23,199,1,2,26,196,249,80,144,41,57,42,195,10,249, +22,12,23,196,1,80,144,41,54,41,86,96,28,248,22,152,5,23,196,2,12, +250,22,183,11,2,22,6,21,21,114,101,115,111,108,118,101,100,45,109,111,100, +117,108,101,45,112,97,116,104,63,23,198,2,28,28,23,196,2,248,22,147,14, +23,197,2,10,12,250,22,183,11,2,22,6,20,20,40,111,114,47,99,32,35, +102,32,110,97,109,101,115,112,97,99,101,63,41,23,199,2,28,24,193,2,248, +24,194,1,23,196,2,86,94,23,193,1,12,27,250,22,159,2,80,144,44,44, +41,248,22,133,17,247,22,146,14,11,27,28,23,194,2,23,194,1,86,94,23, +194,1,27,249,22,81,247,22,139,2,247,22,139,2,86,94,250,22,157,2,80, +144,46,44,41,248,22,133,17,247,22,146,14,195,192,86,94,250,22,157,2,248, +22,82,23,197,2,23,200,2,70,100,101,99,108,97,114,101,100,28,23,198,2, +27,28,248,22,79,248,22,154,5,23,200,2,248,22,153,5,248,22,82,248,22, +154,5,23,201,1,23,198,1,27,250,22,159,2,80,144,47,44,41,248,22,133, +17,23,204,1,11,28,23,193,2,27,250,22,159,2,248,22,83,23,198,1,23, +198,2,11,28,23,193,2,250,22,157,2,248,22,171,20,23,200,1,23,198,1, +23,196,1,12,12,12,86,94,251,22,140,12,247,22,144,12,67,101,114,114,111, +114,6,69,69,100,101,102,97,117,108,116,32,109,111,100,117,108,101,32,110,97, +109,101,32,114,101,115,111,108,118,101,114,32,99,97,108,108,101,100,32,119,105, +116,104,32,116,104,114,101,101,32,97,114,103,117,109,101,110,116,115,32,40,100, +101,112,114,101,99,97,116,101,100,41,11,251,24,197,1,23,198,1,23,199,1, +23,200,1,10,32,81,88,148,39,41,50,11,78,102,108,97,116,116,101,110,45, +115,117,98,45,112,97,116,104,222,33,84,32,82,88,148,39,43,57,11,2,31, +222,33,83,28,248,22,89,23,197,2,28,248,22,89,195,192,249,22,81,194,248, +22,96,197,28,249,22,172,9,248,22,82,23,199,2,2,35,28,248,22,89,23, +196,2,86,95,23,196,1,23,195,1,250,22,179,11,2,22,6,37,37,116,111, +111,32,109,97,110,121,32,34,46,46,34,115,32,105,110,32,115,117,98,109,111, +100,117,108,101,32,112,97,116,104,58,32,126,46,115,250,22,92,2,34,28,249, +22,172,9,23,201,2,2,36,23,199,1,28,248,22,179,15,23,200,2,23,199, +1,249,22,91,28,248,22,65,23,202,2,2,5,2,37,23,201,1,23,200,1, +251,2,82,196,197,248,22,83,199,248,22,171,20,200,251,2,82,196,197,249,22, +81,248,22,170,20,202,200,248,22,171,20,200,251,2,82,196,197,9,197,27,250, +22,177,7,27,28,23,199,2,28,247,22,132,12,248,80,144,47,58,42,23,200, +2,11,11,28,192,192,6,29,29,115,116,97,110,100,97,114,100,45,109,111,100, +117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,6,2,2,58, +32,250,22,183,16,0,7,35,114,120,34,92,110,34,23,203,1,249,22,138,8, +6,23,23,10,32,32,102,111,114,32,109,111,100,117,108,101,32,112,97,116,104, +58,32,126,115,10,23,202,2,248,22,175,13,28,23,196,2,251,22,183,12,23, +198,1,247,22,27,248,22,91,23,201,1,23,199,1,86,94,23,196,1,250,22, +146,13,23,197,1,247,22,27,23,198,1,32,86,88,148,8,36,40,53,11,69, +115,115,45,62,114,107,116,222,33,87,19,248,22,157,7,194,28,249,22,133,4, +23,195,4,42,28,249,22,170,9,7,46,249,22,158,7,197,249,22,185,3,23, +199,4,42,28,28,249,22,170,9,7,115,249,22,158,7,197,249,22,185,3,23, +199,4,41,249,22,170,9,7,115,249,22,158,7,197,249,22,185,3,23,199,4, +40,11,249,22,177,7,250,22,176,7,198,39,249,22,185,3,23,200,4,42,2, +40,193,193,193,2,28,249,22,160,7,194,2,36,2,27,28,249,22,160,7,194, +2,35,64,117,112,192,0,8,35,114,120,34,91,46,93,34,32,90,88,148,8, +36,40,50,11,2,31,222,33,91,28,248,22,89,23,194,2,9,250,22,92,6, +4,4,10,32,32,32,248,22,183,15,248,22,104,23,198,2,248,2,90,248,22, +171,20,23,198,1,28,249,22,172,9,248,22,83,23,200,2,23,197,1,28,249, +22,170,9,248,22,170,20,23,200,1,23,196,1,251,22,179,11,2,22,6,41, +41,99,121,99,108,101,32,105,110,32,108,111,97,100,105,110,103,10,32,32,97, +116,32,112,97,116,104,58,32,126,97,10,32,32,112,97,116,104,115,58,126,97, +23,200,1,249,22,1,22,177,7,248,2,90,248,22,96,23,201,1,12,12,247, +23,193,1,250,22,158,4,11,196,195,20,13,144,80,144,49,53,41,249,22,81, +249,22,81,23,198,1,23,202,1,23,195,1,20,13,144,80,144,49,41,40,252, +80,144,54,42,40,249,22,31,11,80,144,56,41,40,22,128,5,23,201,2,22, +130,5,248,28,23,208,2,20,20,94,88,148,8,36,40,49,11,9,223,15,33, +94,23,208,1,86,94,23,208,1,22,7,28,248,22,65,23,207,2,23,206,1, +28,28,248,22,79,23,207,2,249,22,170,9,248,22,170,20,23,209,2,2,32, +11,23,206,1,86,94,23,206,1,28,248,22,152,5,23,203,2,27,248,22,154, +5,23,204,2,28,248,22,65,193,249,22,91,2,5,194,192,23,202,2,249,247, +22,177,5,23,201,1,27,248,22,69,248,22,183,15,23,202,1,28,23,204,2, +28,250,22,159,2,248,22,170,20,23,202,1,23,202,1,11,249,22,81,11,205, +249,22,81,194,205,192,86,96,28,248,22,162,5,23,196,2,12,28,248,22,156, +4,23,198,2,250,22,181,11,11,6,15,15,98,97,100,32,109,111,100,117,108, +101,32,112,97,116,104,23,200,2,250,22,183,11,2,22,2,33,23,198,2,28, +28,23,196,2,248,22,152,5,23,197,2,10,12,250,22,183,11,2,22,6,31, +31,40,111,114,47,99,32,35,102,32,114,101,115,111,108,118,101,100,45,109,111, +100,117,108,101,45,112,97,116,104,63,41,23,199,2,28,28,23,197,2,248,22, +156,4,23,198,2,10,12,250,22,183,11,2,22,6,17,17,40,111,114,47,99, +32,35,102,32,115,121,110,116,97,120,63,41,23,200,2,28,28,248,22,79,23, +196,2,249,22,170,9,248,22,170,20,23,198,2,2,5,11,86,97,23,198,1, +23,197,1,23,196,1,23,193,1,248,22,153,5,248,22,103,23,197,1,28,28, +248,22,79,23,196,2,28,249,22,170,9,248,22,170,20,23,198,2,2,34,28, +248,22,79,248,22,103,23,197,2,249,22,170,9,248,22,107,23,198,2,2,5, +11,11,11,86,97,23,198,1,23,197,1,23,196,1,23,193,1,248,22,153,5, +249,2,81,248,22,120,23,199,2,248,22,105,23,199,1,28,28,248,22,79,23, +196,2,28,249,22,170,9,248,22,170,20,23,198,2,2,34,28,28,249,22,172, +9,248,22,103,23,198,2,2,36,10,249,22,172,9,248,22,103,23,198,2,2, +35,28,23,196,2,27,248,22,154,5,23,198,2,28,248,22,65,193,10,28,248, +22,79,193,248,22,65,248,22,170,20,194,11,11,11,11,11,86,96,23,198,1, +23,197,1,23,193,1,27,248,22,154,5,23,198,1,248,22,153,5,249,2,81, +28,248,22,79,23,197,2,248,22,170,20,23,197,2,23,196,2,27,28,249,22, +172,9,248,22,103,23,203,2,2,35,248,22,171,20,200,248,22,105,200,28,248, +22,79,23,198,2,249,22,95,248,22,171,20,199,194,192,28,28,248,22,79,23, +196,2,249,22,170,9,248,22,170,20,23,198,2,2,38,11,86,94,248,80,144, +41,8,28,42,23,194,2,253,24,199,1,23,201,1,23,202,1,23,203,1,23, +204,1,11,80,143,46,59,28,28,248,22,79,23,196,2,28,249,22,170,9,248, +22,170,20,23,198,2,2,34,28,248,22,79,248,22,103,23,197,2,249,22,170, +9,248,22,107,23,198,2,2,38,11,11,11,86,94,248,80,144,41,8,28,42, +23,194,2,253,24,199,1,248,22,103,23,202,2,23,202,1,23,203,1,23,204, +1,248,22,105,23,202,1,80,143,46,59,86,94,23,193,1,27,88,148,8,36, +40,57,8,240,0,0,8,0,1,19,115,104,111,119,45,99,111,108,108,101,99, +116,105,111,110,45,101,114,114,225,2,5,3,33,85,27,28,248,22,79,23,198, +2,28,249,22,170,9,2,34,248,22,170,20,23,200,2,27,248,22,103,23,199, +2,28,28,249,22,172,9,23,195,2,2,36,10,249,22,172,9,23,195,2,2, +35,86,94,23,193,1,28,23,199,2,27,248,22,154,5,23,201,2,28,248,22, +79,193,248,22,170,20,193,192,250,22,179,11,2,22,6,45,45,110,111,32,98, +97,115,101,32,112,97,116,104,32,102,111,114,32,114,101,108,97,116,105,118,101, +32,115,117,98,109,111,100,117,108,101,32,112,97,116,104,58,32,126,46,115,23, +201,2,192,23,197,2,23,197,2,27,28,248,22,79,23,199,2,28,249,22,170, +9,2,34,248,22,170,20,23,201,2,27,28,28,28,249,22,172,9,248,22,103, +23,202,2,2,36,10,249,22,172,9,248,22,103,23,202,2,2,35,23,200,2, +11,27,248,22,154,5,23,202,2,27,28,249,22,172,9,248,22,103,23,204,2, +2,35,248,22,171,20,23,202,1,248,22,105,23,202,1,28,248,22,79,23,195, +2,249,2,81,248,22,170,20,23,197,2,249,22,95,248,22,171,20,23,199,1, +23,197,1,249,2,81,23,196,1,23,195,1,249,2,81,2,36,28,249,22,172, +9,248,22,103,23,204,2,2,35,248,22,171,20,23,202,1,248,22,105,23,202, +1,28,248,22,79,193,248,22,171,20,193,11,86,94,23,198,1,11,86,94,23, +198,1,11,27,28,248,22,65,23,196,2,27,248,80,144,46,51,42,249,22,81, +23,199,2,248,22,133,17,247,22,146,14,28,23,193,2,192,86,94,23,193,1, +90,144,41,11,89,146,41,39,11,249,80,144,49,57,42,248,22,72,23,201,2, +11,27,28,248,22,89,23,195,2,2,39,249,22,177,7,23,197,2,2,40,252, +80,144,53,8,23,42,23,205,1,28,248,22,89,23,200,2,23,200,1,86,94, +23,200,1,248,22,82,23,200,2,28,248,22,89,23,200,2,86,94,23,199,1, +9,248,22,83,23,200,1,23,198,1,10,28,248,22,154,7,23,196,2,86,94, +23,196,1,27,248,80,144,46,8,29,42,23,202,2,27,248,80,144,47,51,42, +249,22,81,23,200,2,23,197,2,28,23,193,2,192,86,94,23,193,1,90,144, +41,11,89,146,41,39,11,249,80,144,50,57,42,23,201,2,11,28,248,22,89, +23,194,2,86,94,23,193,1,249,22,133,16,23,198,1,248,2,86,23,197,1, +250,22,1,22,133,16,23,199,1,249,22,95,249,22,2,32,0,88,148,8,36, +40,47,11,9,222,33,88,23,200,1,248,22,91,248,2,86,23,201,1,28,248, +22,179,15,23,196,2,86,94,23,196,1,248,80,144,45,8,30,42,248,22,143, +16,28,248,22,140,16,23,198,2,23,197,2,249,22,141,16,23,199,2,248,80, +144,49,8,29,42,23,205,2,28,249,22,170,9,248,22,82,23,198,2,2,32, +27,248,80,144,46,51,42,249,22,81,23,199,2,248,22,133,17,247,22,146,14, +28,23,193,2,192,86,94,23,193,1,90,144,41,11,89,146,41,39,11,249,80, +144,49,57,42,248,22,103,23,201,2,11,27,28,248,22,89,248,22,105,23,201, +2,28,248,22,89,23,195,2,249,22,176,16,2,89,23,197,2,11,10,27,28, +23,194,2,248,2,86,23,197,2,28,248,22,89,23,196,2,2,39,28,249,22, +176,16,2,89,23,198,2,248,2,86,23,197,2,249,22,177,7,23,198,2,2, +40,27,28,23,195,1,86,94,23,197,1,249,22,95,28,248,22,89,248,22,105, +23,205,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,95,249,22,2, +80,144,56,8,31,42,248,22,105,23,208,2,23,198,1,28,248,22,89,23,197, +2,86,94,23,196,1,248,22,91,23,198,1,86,94,23,197,1,23,196,1,252, +80,144,55,8,23,42,23,207,1,248,22,82,23,199,2,248,22,171,20,23,199, +1,23,199,1,10,86,94,23,196,1,28,249,22,170,9,248,22,170,20,23,198, +2,2,37,248,80,144,45,8,30,42,248,22,143,16,249,22,141,16,248,22,145, +16,248,22,103,23,201,2,248,80,144,49,8,29,42,23,205,2,12,86,94,28, +28,248,22,179,15,23,194,2,10,248,22,185,8,23,194,2,12,28,23,201,2, +250,22,181,11,69,114,101,113,117,105,114,101,249,22,138,8,6,17,17,98,97, +100,32,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,248,22, +82,23,199,2,6,0,0,23,204,2,250,22,183,11,2,22,2,33,23,198,2, +27,28,248,22,185,8,23,195,2,249,22,190,8,23,196,2,39,249,22,143,16, +248,22,144,16,23,197,2,11,27,28,248,22,185,8,23,196,2,249,22,190,8, +23,197,2,40,248,80,144,47,8,24,42,23,195,2,90,144,42,11,89,146,42, +39,11,28,248,22,185,8,23,199,2,250,22,7,2,41,249,22,190,8,23,203, +2,41,2,41,248,22,136,16,23,198,2,86,95,23,195,1,23,193,1,27,28, +248,22,185,8,23,200,2,249,22,190,8,23,201,2,42,249,80,144,52,61,42, +23,197,2,5,0,27,28,248,22,185,8,23,201,2,249,22,190,8,23,202,2, +43,248,22,153,5,23,200,2,27,250,22,159,2,80,144,55,44,41,248,22,133, +17,247,22,146,14,11,27,28,23,194,2,23,194,1,86,94,23,194,1,27,249, +22,81,247,22,139,2,247,22,139,2,86,94,250,22,157,2,80,144,57,44,41, +248,22,133,17,247,22,146,14,195,192,27,28,23,204,2,248,22,153,5,249,22, +81,248,22,154,5,23,200,2,23,207,2,23,196,2,86,95,28,23,212,2,28, +250,22,159,2,248,22,82,23,198,2,195,11,86,96,23,211,1,23,204,1,23, +194,1,12,27,251,22,31,11,80,144,59,53,41,9,28,248,22,15,80,144,60, +54,41,80,144,59,54,41,247,22,17,27,248,22,133,17,247,22,146,14,86,94, +249,22,3,88,148,8,36,40,57,11,9,226,13,12,2,3,33,92,23,196,2, +248,28,248,22,15,80,144,58,54,41,32,0,88,148,39,40,45,11,9,222,33, +93,80,144,57,8,32,42,20,20,98,88,148,39,39,8,25,8,240,12,64,0, +0,9,233,18,21,14,15,12,11,7,6,4,1,2,33,95,23,195,1,23,194, +1,23,197,1,23,207,1,23,214,1,86,96,23,211,1,23,204,1,23,194,1, +12,28,28,248,22,185,8,23,204,1,86,94,23,212,1,11,28,23,212,1,28, +248,22,154,7,23,206,2,10,28,248,22,65,23,206,2,10,28,248,22,79,23, +206,2,249,22,170,9,248,22,170,20,23,208,2,2,32,11,11,249,80,144,56, +52,42,28,248,22,154,7,23,208,2,249,22,81,23,209,1,248,80,144,59,8, +29,42,23,215,1,86,94,23,212,1,249,22,81,23,209,1,248,22,133,17,247, +22,146,14,252,22,187,8,23,209,1,23,208,1,23,206,1,23,204,1,23,203, +1,12,192,86,96,20,18,144,11,80,143,39,59,248,80,144,40,8,27,40,249, +22,31,11,80,144,42,41,40,248,22,191,4,80,144,40,60,41,248,22,177,5, +80,144,40,40,42,248,22,145,15,80,144,40,48,42,20,18,144,11,80,143,39, +59,248,80,144,40,8,27,40,249,22,31,11,80,144,42,41,40,20,18,144,11, +80,143,39,59,248,80,144,40,8,27,40,249,22,31,11,80,144,42,41,40,145, +39,9,20,121,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2, +2,29,11,11,11,11,11,11,11,9,9,11,11,11,10,41,80,143,39,39,20, +121,145,2,1,44,16,28,2,3,2,4,30,2,6,1,20,112,97,114,97,109, +101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,6,30,2,6,1, +23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116, +105,111,110,11,4,30,2,7,74,112,97,116,104,45,115,116,114,105,110,103,63, +42,196,15,2,8,30,2,7,73,114,101,114,111,111,116,45,112,97,116,104,44, +196,16,30,2,7,77,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120, +44,196,12,2,9,2,10,2,11,2,12,2,13,2,14,2,15,2,16,2,17, +2,18,2,19,2,20,2,21,2,22,30,2,7,1,19,112,97,116,104,45,114, +101,112,108,97,99,101,45,115,117,102,102,105,120,44,196,14,30,2,7,75,102, +105,110,100,45,99,111,108,45,102,105,108,101,49,196,4,30,2,7,78,110,111, +114,109,97,108,45,99,97,115,101,45,112,97,116,104,42,196,11,2,23,2,24, +30,2,6,76,114,101,112,97,114,97,109,101,116,101,114,105,122,101,11,7,16, +0,40,42,39,16,0,39,16,16,2,15,2,16,2,8,2,12,2,17,2,18, +2,11,2,4,2,10,2,3,2,20,2,13,2,14,2,9,2,19,2,22,55, +11,11,11,16,3,2,23,2,21,2,24,16,3,11,11,11,16,3,2,23,2, +21,2,24,42,42,40,12,11,11,16,0,16,0,16,0,39,39,11,12,11,11, +16,0,16,0,16,0,39,39,16,24,20,15,16,2,248,22,181,8,71,115,111, +45,115,117,102,102,105,120,80,144,39,39,40,20,15,16,2,88,148,39,41,8, +39,8,189,3,2,4,223,0,33,50,80,144,39,40,40,20,15,16,2,32,0, +88,148,8,36,44,55,11,2,9,222,33,51,80,144,39,47,40,20,15,16,2, +20,28,143,32,0,88,148,8,36,40,45,11,2,10,222,192,32,0,88,148,8, +36,40,45,11,2,10,222,192,80,144,39,48,40,20,15,16,2,247,22,142,2, +80,144,39,44,40,20,15,16,2,8,128,8,80,144,39,49,40,20,15,16,2, +249,22,186,8,8,128,8,11,80,144,39,50,40,20,15,16,2,88,148,8,36, +40,53,8,128,32,2,13,223,0,33,52,80,144,39,51,40,20,15,16,2,88, +148,8,36,41,57,8,128,32,2,14,223,0,33,53,80,144,39,52,40,20,15, +16,2,247,22,77,80,144,39,53,40,20,15,16,2,248,22,16,76,109,111,100, +117,108,101,45,108,111,97,100,105,110,103,80,144,39,54,40,20,15,16,2,11, +80,143,39,55,20,15,16,2,11,80,143,39,56,20,15,16,2,32,0,88,148, +39,41,60,11,2,19,222,33,72,80,144,39,57,40,20,15,16,2,32,0,88, +148,8,36,40,52,11,2,20,222,33,73,80,144,39,58,40,20,15,16,2,11, +80,143,39,59,20,15,16,2,88,149,8,34,40,48,8,240,4,0,16,0,1, +21,112,114,101,112,45,112,108,97,110,101,116,45,114,101,115,111,108,118,101,114, +33,40,224,1,0,33,74,80,144,39,8,28,42,20,15,16,2,88,148,39,40, +53,8,240,0,0,3,0,69,103,101,116,45,100,105,114,223,0,33,75,80,144, +39,8,29,42,20,15,16,2,88,148,39,40,52,8,240,0,0,64,0,74,112, +97,116,104,45,115,115,45,62,114,107,116,223,0,33,76,80,144,39,8,30,42, +20,15,16,2,88,148,8,36,40,48,8,240,0,0,4,0,9,223,0,33,77, +80,144,39,8,31,42,20,15,16,2,88,148,39,40,48,8,240,0,128,0,0, +9,223,0,33,78,80,144,39,8,32,42,20,15,16,2,27,11,20,19,143,39, +90,144,40,10,89,146,40,39,10,20,26,96,2,22,88,148,8,36,41,57,8, +32,9,224,2,1,33,79,88,148,39,42,52,11,9,223,0,33,80,88,148,39, +43,8,32,16,4,8,240,44,240,0,0,8,240,220,241,0,0,40,39,9,224, +2,1,33,96,207,80,144,39,60,40,20,15,16,2,88,148,39,39,48,16,2, +8,134,8,8,176,32,2,23,223,0,33,97,80,144,39,8,25,40,20,15,16, +2,20,28,143,88,148,8,36,39,48,16,2,43,8,144,32,2,24,223,0,33, +98,88,148,8,36,39,48,16,2,43,8,144,32,2,24,223,0,33,99,80,144, +39,8,26,40,96,29,94,2,5,70,35,37,107,101,114,110,101,108,11,29,94, +2,5,71,35,37,109,105,110,45,115,116,120,11,2,7,2,6,9,9,9,39, +9,0}; + EVAL_ONE_SIZED_STR((char *)expr, 9766); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,10,54,46,50,46,57,48,48,46,49,53,84,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,0,0,0,17,0,0,0,1,0,0,8, -0,18,0,24,0,38,0,52,0,64,0,84,0,98,0,113,0,126,0,131,0, -135,0,147,0,231,0,238,0,8,1,0,0,199,1,0,0,3,1,5,105,110, -115,112,48,71,35,37,98,117,105,108,116,105,110,67,113,117,111,116,101,29,94, -2,3,70,35,37,107,101,114,110,101,108,11,29,94,2,3,70,35,37,101,120, -112,111,98,115,11,29,94,2,3,68,35,37,98,111,111,116,11,29,94,2,3, -76,35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,3,70, -35,37,112,97,114,97,109,122,11,29,94,2,3,71,35,37,110,101,116,119,111, -114,107,11,29,94,2,3,69,35,37,117,116,105,108,115,11,38,11,93,2,12, -36,12,0,39,38,13,93,143,16,3,39,2,14,2,2,39,36,14,1,150,40, -143,2,15,16,4,2,4,39,39,2,1,143,2,15,16,4,2,5,39,39,2, -1,143,2,15,16,4,2,6,39,39,2,1,143,2,15,16,4,2,7,39,39, -2,1,143,2,15,16,4,2,8,39,39,2,1,143,2,15,16,4,2,9,39, -39,2,1,143,2,15,16,4,2,10,39,39,2,1,16,0,38,15,143,2,14, -2,11,18,143,16,2,143,10,16,3,9,2,11,2,13,143,11,16,3,9,9, -2,13,16,3,9,9,9,145,39,9,20,121,145,2,1,39,16,1,11,16,0, -20,27,15,56,9,2,2,2,2,29,11,11,11,11,11,11,11,9,9,11,11, -11,33,16,39,80,143,39,39,20,121,145,2,1,39,16,0,16,0,40,42,39, -16,0,39,16,0,39,11,11,11,16,0,16,0,16,0,39,39,40,12,11,11, -16,0,16,0,16,0,39,39,11,12,11,11,16,0,16,0,16,0,39,39,16, -0,104,2,4,2,5,29,94,2,3,71,35,37,102,111,114,101,105,103,110,11, -29,94,2,3,70,35,37,117,110,115,97,102,101,11,29,94,2,3,71,35,37, -102,108,102,120,110,117,109,11,2,6,2,7,2,8,2,9,2,10,29,94,2, -3,69,35,37,112,108,97,99,101,11,29,94,2,3,71,35,37,102,117,116,117, -114,101,115,11,9,9,9,39,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 534); + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,54,46,51,46,48,46,49,48,84,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,17,0,0,0,1,0,0,8,0,18, +0,24,0,38,0,52,0,64,0,84,0,98,0,113,0,126,0,131,0,135,0, +147,0,231,0,238,0,8,1,0,0,199,1,0,0,3,1,5,105,110,115,112, +48,71,35,37,98,117,105,108,116,105,110,67,113,117,111,116,101,29,94,2,3, +70,35,37,107,101,114,110,101,108,11,29,94,2,3,70,35,37,101,120,112,111, +98,115,11,29,94,2,3,68,35,37,98,111,111,116,11,29,94,2,3,76,35, +37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,3,70,35,37, +112,97,114,97,109,122,11,29,94,2,3,71,35,37,110,101,116,119,111,114,107, +11,29,94,2,3,69,35,37,117,116,105,108,115,11,38,11,93,2,12,36,12, +0,39,38,13,93,143,16,3,39,2,14,2,2,39,36,14,1,150,40,143,2, +15,16,4,2,4,39,39,2,1,143,2,15,16,4,2,5,39,39,2,1,143, +2,15,16,4,2,6,39,39,2,1,143,2,15,16,4,2,7,39,39,2,1, +143,2,15,16,4,2,8,39,39,2,1,143,2,15,16,4,2,9,39,39,2, +1,143,2,15,16,4,2,10,39,39,2,1,16,0,38,15,143,2,14,2,11, +18,143,16,2,143,10,16,3,9,2,11,2,13,143,11,16,3,9,9,2,13, +16,3,9,9,9,145,39,9,20,121,145,2,1,39,16,1,11,16,0,20,27, +15,56,9,2,2,2,2,29,11,11,11,11,11,11,11,9,9,11,11,11,33, +16,39,80,143,39,39,20,121,145,2,1,39,16,0,16,0,40,42,39,16,0, +39,16,0,39,11,11,11,16,0,16,0,16,0,39,39,40,12,11,11,16,0, +16,0,16,0,39,39,11,12,11,11,16,0,16,0,16,0,39,39,16,0,104, +2,4,2,5,29,94,2,3,71,35,37,102,111,114,101,105,103,110,11,29,94, +2,3,70,35,37,117,110,115,97,102,101,11,29,94,2,3,71,35,37,102,108, +102,120,110,117,109,11,2,6,2,7,2,8,2,9,2,10,29,94,2,3,69, +35,37,112,108,97,99,101,11,29,94,2,3,71,35,37,102,117,116,117,114,101, +115,11,9,9,9,39,9,0}; + EVAL_ONE_SIZED_STR((char *)expr, 532); } diff --git a/racket/src/racket/src/dynext.c b/racket/src/racket/src/dynext.c index 42f24b9380..d2176c24eb 100644 --- a/racket/src/racket/src/dynext.c +++ b/racket/src/racket/src/dynext.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2002 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/env.c b/racket/src/racket/src/env.c index c68ae63652..34ec6d26f5 100644 --- a/racket/src/racket/src/env.c +++ b/racket/src/racket/src/env.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -92,6 +92,7 @@ static Scheme_Object *variable_base_phase(int, Scheme_Object *[]); static Scheme_Object *variable_inspector(int, Scheme_Object *[]); static Scheme_Object *variable_const_p(int, Scheme_Object *[]); static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]); +static Scheme_Object *now_transforming_with_lifts(int argc, Scheme_Object *argv[]); static Scheme_Object *now_transforming_module(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]); @@ -102,6 +103,7 @@ static Scheme_Object *local_make_intdef_context(int argc, Scheme_Object *argv[]) static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]); static Scheme_Object *intdef_context_intro(int argc, Scheme_Object *argv[]); static Scheme_Object *intdef_context_p(int argc, Scheme_Object *argv[]); +static Scheme_Object *intdef_context_ids(int argc, Scheme_Object *argv[]); static Scheme_Object *id_intdef_remove(int argc, Scheme_Object *argv[]); static Scheme_Object *local_introduce(int argc, Scheme_Object *argv[]); static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]); @@ -654,6 +656,10 @@ void scheme_place_instance_destroy(int force) else scheme_run_atexit_closers_on_all(force_more_closed_after); +#ifdef WINDOWS_PROCESSES + scheme_release_process_job_object(); +#endif + scheme_release_file_descriptor(); scheme_end_futures_per_place(); @@ -771,6 +777,7 @@ static void make_kernel_env(void) scheme_add_global_constant("variable-reference-constant?", scheme_varref_const_p_proc, env); GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env); + GLOBAL_PRIM_W_ARITY("syntax-transforming-with-lifts?", now_transforming_with_lifts, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-transforming-module-expression?", now_transforming_module, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env); GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env); @@ -781,6 +788,7 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("internal-definition-context-seal", intdef_context_seal, 1, 1, env); GLOBAL_PRIM_W_ARITY("internal-definition-context-introduce", intdef_context_intro, 2, 3, env); GLOBAL_PRIM_W_ARITY("internal-definition-context?", intdef_context_p, 1, 1, env); + GLOBAL_PRIM_W_ARITY("internal-definition-context-binding-identifiers", intdef_context_ids, 1, 1, env); GLOBAL_PRIM_W_ARITY("identifier-remove-from-definition-context", id_intdef_remove, 2, 2, env); GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 2, env); GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env); @@ -2240,6 +2248,24 @@ now_transforming(int argc, Scheme_Object *argv[]) : scheme_false); } +static Scheme_Object * +now_transforming_with_lifts(int argc, Scheme_Object *argv[]) +{ + Scheme_Comp_Env *env = scheme_current_thread->current_local_env; + + while (env && !env->lifts) { + env = env->next; + } + + if (env) + if (SCHEME_FALSEP(SCHEME_VEC_ELS(env->lifts)[0])) + env = NULL; + + return (env + ? scheme_true + : scheme_false); +} + static Scheme_Object * now_transforming_module(int argc, Scheme_Object *argv[]) { @@ -2564,6 +2590,16 @@ id_intdef_remove(int argc, Scheme_Object *argv[]) return res; } +static Scheme_Object *intdef_context_ids(int argc, Scheme_Object *argv[]) +{ + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)) + scheme_wrong_contract("internal-definition-context-binding-identifiers", + "internal-definition-context?", + 0, argc, argv); + + return scheme_intdef_bind_identifiers(argv[0]); +} + static Scheme_Object * local_introduce(int argc, Scheme_Object *argv[]) { diff --git a/racket/src/racket/src/error.c b/racket/src/racket/src/error.c index fd768f074f..21f7ddbca1 100644 --- a/racket/src/racket/src/error.c +++ b/racket/src/racket/src/error.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -2175,7 +2175,7 @@ void scheme_read_err(Scheme_Object *port, if (port) { Scheme_Object *pn; - pn = SCHEME_IPORT_NAME(port); + pn = scheme_input_port_record(port)->name; if (SCHEME_PATHP(pn)) { pn = scheme_remove_current_directory_prefix(pn); fn = SCHEME_PATH_VAL(pn); diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index e7aa77c07a..c00b679ded 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -272,6 +272,7 @@ void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Obj #ifdef MZ_PRECISE_GC static void mark_pruned_prefixes(struct NewGC *gc); +static int check_pruned_prefix(void *p); #endif #define cons(x,y) scheme_make_pair(x,y) @@ -414,6 +415,7 @@ void scheme_init_eval_places() scheme_prefix_finalize = (Scheme_Prefix *)0x1; /* 0x1 acts as a sentenel */ scheme_inc_prefix_finalize = (Scheme_Prefix *)0x1; GC_set_post_propagate_hook(mark_pruned_prefixes); + GC_set_treat_as_incremental_mark(scheme_prefix_type, check_pruned_prefix); #endif #ifdef DEBUG_CHECK_STACK_FRAME_SIZE (void)scheme_do_eval(SCHEME_TAIL_CALL_WAITING, 0, NULL, 0); @@ -518,7 +520,7 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void)) } #ifdef LINUX_FIND_STACK_BASE -static uintptr_t adjust_stack_base(uintptr_t bnd) { +static uintptr_t adjust_stack_base(uintptr_t bnd, uintptr_t lim) { if (bnd == scheme_get_primordial_thread_stack_base()) { /* The address `base' might be far from the actual stack base if Exec Shield is enabled (in some versions)? Use @@ -553,7 +555,11 @@ static uintptr_t adjust_stack_base(uintptr_t bnd) { break; } /* printf("%p vs. %p: %d\n", (void*)bnd, (void*)p, p - bnd); */ - bnd = p; + if ((p > bnd) && ((p - lim) < bnd)) { + bnd = p; + } else { + /* bnd is too far from the expected range; on another thread? */ + } break; } } @@ -717,16 +723,16 @@ void scheme_init_stack_check() getrlimit(RLIMIT_STACK, &rl); -# ifdef LINUX_FIND_STACK_BASE - bnd = adjust_stack_base(bnd); -# endif - lim = (uintptr_t)rl.rlim_cur; # ifdef UNIX_STACK_MAXIMUM if (lim > UNIX_STACK_MAXIMUM) lim = UNIX_STACK_MAXIMUM; # endif +# ifdef LINUX_FIND_STACK_BASE + bnd = adjust_stack_base(bnd, lim); +# endif + if (stack_grows_up) bnd += (lim - STACK_SAFETY_MARGIN); else @@ -5890,6 +5896,26 @@ local_eval(int argc, Scheme_Object **argv) return scheme_void; } +Scheme_Object *scheme_intdef_bind_identifiers(Scheme_Object *intdef) +{ + Scheme_Comp_Env *stx_env, *init_env; + Scheme_Object *l = scheme_null; + int i; + + update_intdef_chain(intdef); + stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[0]; + init_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[3]; + + while (stx_env != init_env) { + for (i = stx_env->num_bindings; i--; ) { + l = scheme_make_pair(stx_env->binders[i], l); + } + stx_env = stx_env->next; + } + + return l; +} + /*========================================================================*/ /* cloning prefix information */ /*========================================================================*/ @@ -6074,7 +6100,7 @@ static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC if (scheme_prefix_finalize != (Scheme_Prefix *)0x1) { Scheme_Prefix *pf = scheme_prefix_finalize, *next; Scheme_Object *clo; - int i, *use_bits, maxpos, inc_fixup_mode; + int i, *use_bits, maxpos; scheme_prefix_finalize = (Scheme_Prefix *)0x1; while (pf != (Scheme_Prefix *)0x1) { @@ -6129,24 +6155,17 @@ static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC /* Fix up closures that reference this prefix: */ clo = (Scheme_Object *)GC_resolve2(pf->fixup_chain, gc); pf->fixup_chain = NULL; - inc_fixup_mode = SCHEME_PREFIX_FLAGS(pf) & 0x1; while (clo) { Scheme_Object *next; - if (inc_fixup_mode) { - next = ((Scheme_Object **)clo)[1]; - clo = ((Scheme_Object **)clo)[0]; - } if (SCHEME_TYPE(clo) == scheme_closure_type) { Scheme_Closure *cl = (Scheme_Closure *)clo; int closure_size = ((Scheme_Closure_Data *)GC_resolve2(cl->code, gc))->closure_size; - if (!inc_fixup_mode) - next = cl->vals[closure_size - 1]; + next = cl->vals[closure_size - 1]; cl->vals[closure_size-1] = (Scheme_Object *)pf; } else if (SCHEME_TYPE(clo) == scheme_native_closure_type) { Scheme_Native_Closure *cl = (Scheme_Native_Closure *)clo; int closure_size = ((Scheme_Native_Closure_Data *)GC_resolve2(cl->code, gc))->closure_size; - if (!inc_fixup_mode) - next = cl->vals[closure_size - 1]; + next = cl->vals[closure_size - 1]; cl->vals[closure_size-1] = (Scheme_Object *)pf; } else { MZ_ASSERT(0); @@ -6154,7 +6173,7 @@ static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC } clo = (Scheme_Object *)GC_resolve2(next, gc); } - if (inc_fixup_mode) + if (SCHEME_PREFIX_FLAGS(pf) & 0x1) SCHEME_PREFIX_FLAGS(pf) -= 0x1; /* Next */ @@ -6165,6 +6184,12 @@ static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC } } } + +int check_pruned_prefix(void *p) XFORM_SKIP_PROC +{ + Scheme_Prefix *pf = (Scheme_Prefix *)p; + return SCHEME_PREFIX_FLAGS(pf) & 0x1; +} #endif /*========================================================================*/ diff --git a/racket/src/racket/src/file.c b/racket/src/racket/src/file.c index 1d0c40f16d..4792da8f25 100644 --- a/racket/src/racket/src/file.c +++ b/racket/src/racket/src/file.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 540d03fb97..889cc2008e 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -79,6 +79,7 @@ READ_ONLY Scheme_Object scheme_void[1]; /* the void constant */ READ_ONLY Scheme_Object *scheme_values_func; /* the function bound to `values' */ READ_ONLY Scheme_Object *scheme_procedure_p_proc; READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc; +READ_ONLY Scheme_Object *scheme_procedure_specialize_proc; READ_ONLY Scheme_Object *scheme_void_proc; READ_ONLY Scheme_Object *scheme_void_p_proc; READ_ONLY Scheme_Object *scheme_check_not_undefined_proc; @@ -104,6 +105,7 @@ ROSYM static Scheme_Object *is_method_symbol; ROSYM static Scheme_Object *cont_key; /* uninterned */ ROSYM static Scheme_Object *barrier_prompt_key; /* uninterned */ ROSYM static Scheme_Object *prompt_cc_guard_key; /* uninterned */ +ROSYM static Scheme_Object *mark_symbol; READ_ONLY static Scheme_Prompt *original_default_prompt; /* for escapes, represents the implicit initial prompt */ READ_ONLY static Scheme_Object *call_with_prompt_proc; READ_ONLY static Scheme_Object *abort_continuation_proc; @@ -178,6 +180,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]); static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]); +static Scheme_Object *procedure_specialize(int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]); static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[]); @@ -592,6 +595,14 @@ scheme_init_fun (Scheme_Env *env) "procedure-closure-contents-eq?", 2, 2, 1), env); + + REGISTER_SO(scheme_procedure_specialize_proc); + o = scheme_make_prim_w_arity(procedure_specialize, + "procedure-specialize", + 1, 1); + scheme_procedure_specialize_proc = o; + scheme_add_global_constant("procedure-specialize", o, env); + scheme_add_global_constant("chaperone-procedure", scheme_make_prim_w_arity(chaperone_procedure, "chaperone-procedure", @@ -676,6 +687,9 @@ scheme_init_fun (Scheme_Env *env) barrier_prompt_key = scheme_make_symbol("bar"); /* uninterned */ prompt_cc_guard_key = scheme_make_symbol("cc"); /* uninterned */ + REGISTER_SO(mark_symbol); + mark_symbol = scheme_intern_symbol("mark"); + REGISTER_SO(scheme_default_prompt_tag); { Scheme_Object *a[1]; @@ -3367,7 +3381,8 @@ static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]) Scheme_Native_Closure *c1 = (Scheme_Native_Closure *)v1; Scheme_Native_Closure *c2 = (Scheme_Native_Closure *)v2; - if (SAME_OBJ(c1->code, c2->code)) { + if (SAME_OBJ(c1->code, c2->code) + || (c1->code->eq_key && SAME_OBJ(c1->code->eq_key, c2->code->eq_key))) { int i; i = c1->code->closure_size; if (i < 0) { @@ -3421,6 +3436,33 @@ static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]) return scheme_false; } +static Scheme_Object *procedure_specialize(int argc, Scheme_Object *argv[]) +{ + if (!SCHEME_PROCP(argv[0])) + scheme_wrong_contract("procedure-specialize", "procedure?", 0, argc, argv); + +#ifdef MZ_USE_JIT + if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_native_closure_type)) { + Scheme_Native_Closure *nc = (Scheme_Native_Closure *)argv[0]; + if ((nc->code->start_code == scheme_on_demand_jit_code) + && !(SCHEME_NATIVE_CLOSURE_DATA_FLAGS(nc->code) & NATIVE_SPECIALIZED)) { + Scheme_Native_Closure_Data *data; + if (!nc->code->eq_key) { + void *p; + p = scheme_malloc_atomic(sizeof(int)); + nc->code->eq_key = p; + } + data = MALLOC_ONE_TAGGED(Scheme_Native_Closure_Data); + memcpy(data, nc->code, sizeof(Scheme_Native_Closure_Data)); + SCHEME_NATIVE_CLOSURE_DATA_FLAGS(data) |= NATIVE_SPECIALIZED; + nc->code = data; + } + } +#endif + + return argv[0]; +} + static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating, int is_impersonator, int pass_self, int argc, Scheme_Object *argv[]) @@ -3591,35 +3633,119 @@ Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Ob return _apply_native(obj, num_rands, rands); } +Scheme_Object *extract_impersonator_results(int c, int argc, Scheme_Object **argv2, + const char *what, Scheme_Object *o, + Scheme_Chaperone *px, + Scheme_Cont_Frame_Data *cframe, int *_need_pop) +{ + int extra = c - argc; + int i, fail_reason = 0; + Scheme_Object *post; + char nth[32]; + Scheme_Config *config = NULL; + + if (!extra) + return NULL; + + post = NULL; + for (i = 0; i < extra; ) { + if (!i && SCHEME_PROCP(argv2[0])) { + post = argv2[i]; + i++; + } else if (SAME_OBJ(argv2[i], mark_symbol)) { + if (i + 3 > extra) { + fail_reason = 2; + break; + } + if (post && !*_need_pop) { + scheme_push_continuation_frame(cframe); + *_need_pop = 1; + } + scheme_set_cont_mark(argv2[i+1], argv2[i+2]); + i += 3; + } else { + fail_reason = 1; + break; + } + } + + if (!fail_reason) { + if (config) { + if (post && !*_need_pop) { + scheme_push_continuation_frame(cframe); + *_need_pop = 1; + } + scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); + } + return post; + } + + /* Failure at argument i */ + + switch (i % 10) { + case 1: + sprintf(nth, "%dst", i); + break; + case 2: + sprintf(nth, "%dnd", i); + break; + case 3: + sprintf(nth, "%drd", i); + break; + default: + sprintf(nth, "%dth", i); + } + + if (fail_reason == 1) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "procedure %s: wrapper's %s result is not valid;\n" + " %s extra result (before original argument count) should be\n" + " 'mark%s'parameter%s\n" + " original: %V\n" + " wrapper: %V\n" + " received: %V", + what, + nth, + nth, + (i ? " or " : ", "), + (i ? "" : ", or a wrapper for the original procedure's result"), + o, + SCHEME_VEC_ELS(px->redirects)[0], + argv2[i]); + } else if (fail_reason == 2) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "procedure %s: wrapper's %s result needs addition extra results;\n" + " %s extra result (before original argument count) needs an\n" + " additional %s after %V\n" + " original: %V\n" + " wrapper: %V", + what, + nth, + nth, + ((i + 1 < extra) ? "result" : "two results"), + argv2[i], + o, + SCHEME_VEC_ELS(px->redirects)[0]); + } + + return NULL; +} + /* must be at least 3: */ #define MAX_QUICK_CHAP_ARGV 5 +#define CHAPERONE_KIND_STR(px) (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR) ? "chaperone" : "impersonator") + Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks) /* auto_val => no need to actually call the function (but handle further chaperoning); checks & 0x2 => no tail; checks == 0x3 => no tail or multiple */ { - const char *what; Scheme_Chaperone *px; Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark, *self_proc; int c, i, need_restore = 0; int need_pop_mark; Scheme_Cont_Frame_Data cframe; - if (argv == MZ_RUNSTACK) { - /* Pushing onto the runstack ensures that `(vector-ref px->redirects 0)' won't - modify argv. */ - if (MZ_RUNSTACK > MZ_RUNSTACK_START) { - --MZ_RUNSTACK; - *MZ_RUNSTACK = NULL; - need_restore = 1; - } else { - /* Can't push! Just allocate a copy. */ - argv2 = MALLOC_N(Scheme_Object *, argc); - memcpy(argv2, argv, sizeof(Scheme_Object*) * argc); - argv = argv2; - } - } - if (SCHEME_RPAIRP(o)) { /* An applicable struct, where a layer of struct chaperones has been removed from the object to apply, but we will @@ -3641,18 +3767,41 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object self_proc = o; } - if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) - what = "chaperone"; - else - what = "impersonator"; - if (SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[0])) { /* no redirection procedure */ if (SCHEME_CHAPERONEP(px->prev)) { - /* commuincate `self_proc` to the next layer: */ + /* communicate `self_proc` to the next layer: */ scheme_current_thread->self_for_proc_chaperone = self_proc; } - return _scheme_tail_apply(px->prev, argc, argv); + if (checks) { + /* cannot return a tail call */ + MZ_CONT_MARK_POS -= 2; + if (checks & 0x1) { + v = _scheme_apply(px->prev, argc, argv); + } else if (SAME_TYPE(SCHEME_TYPE(px->prev), scheme_native_closure_type)) { + v = _apply_native(px->prev, argc, argv); + } else { + v = _scheme_apply_multi(px->prev, argc, argv); + } + MZ_CONT_MARK_POS += 2; + return v; + } else + return _scheme_tail_apply(px->prev, argc, argv); + } + + if (argv == MZ_RUNSTACK) { + /* Pushing onto the runstack ensures that `(vector-ref px->redirects 0)' won't + modify argv. */ + if (MZ_RUNSTACK > MZ_RUNSTACK_START) { + --MZ_RUNSTACK; + *MZ_RUNSTACK = NULL; + need_restore = 1; + } else { + /* Can't push! Just allocate a copy. */ + argv2 = MALLOC_N(Scheme_Object *, argc); + memcpy(argv2, argv, sizeof(Scheme_Object*) * argc); + argv = argv2; + } } /* Ensure that the original procedure accepts `argc' arguments: */ @@ -3736,13 +3885,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object MZ_CONT_MARK_POS += 2; scheme_pop_continuation_frame(&cframe); } - - if ((c == argc) || (c == (argc + 1))) { - if (c > argc) { - post = argv2[0]; - memmove(argv2, argv2 + 1, sizeof(Scheme_Object*)*argc); - } else - post = NULL; + + if (c >= argc) { + int need_pop = 0; + post = extract_impersonator_results(c, argc, argv2, + CHAPERONE_KIND_STR(px), o, px, + &cframe, &need_pop); + need_pop_mark = need_pop; + + if (c > argc) + memmove(argv2, argv2 + (c - argc), sizeof(Scheme_Object*)*argc); if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) { for (i = 0; i < argc; i++) { if (!SAME_OBJ(argv2[i], argv[i]) @@ -3764,12 +3916,12 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object " procedure's arguments\n" " original: %V\n" " wrapper: %V\n" - " expected: %d or %d\n" + " expected: %d or more\n" " received: %d", - what, + CHAPERONE_KIND_STR(px), o, SCHEME_VEC_ELS(px->redirects)[0], - argc, argc + 1, + argc, c); return NULL; } @@ -3784,7 +3936,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object } else argv = NULL; - if (c == argc) { + if (!post) { /* No filter for the result, so tail call: */ if (app_mark) scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark)); @@ -3794,7 +3946,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object } if (auto_val) { if (SCHEME_CHAPERONEP(px->prev)) - return do_apply_chaperone(px->prev, c, argv2, auto_val, 0); + return do_apply_chaperone(px->prev, argc, argv2, auto_val, 0); else return argv2[0]; } else { @@ -3807,40 +3959,29 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object /* cannot return a tail call */ MZ_CONT_MARK_POS -= 2; if (checks & 0x1) { - v = _scheme_apply(orig_obj, c, argv2); + v = _scheme_apply(orig_obj, argc, argv2); } else if (SAME_TYPE(SCHEME_TYPE(orig_obj), scheme_native_closure_type)) { - v = _apply_native(orig_obj, c, argv2); + v = _apply_native(orig_obj, argc, argv2); } else { - v = _scheme_apply_multi(orig_obj, c, argv2); + v = _scheme_apply_multi(orig_obj, argc, argv2); } MZ_CONT_MARK_POS += 2; return v; } else - return scheme_tail_apply(orig_obj, c, argv2); + return scheme_tail_apply(orig_obj, argc, argv2); } } else { - /* First element is a filter for the result(s) */ - if (!SCHEME_PROCP(post)) - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "procedure %s: wrapper's first result is not a procedure;\n" - " extra result compared to original argument count should be\n" - " a wrapper for the original procedure's result\n" - " original: %V\n" - " wrapper: %V\n" - " received: %V", - what, - o, - SCHEME_VEC_ELS(px->redirects)[0], - post); - if (app_mark) { - scheme_push_continuation_frame(&cframe); + if (!need_pop_mark) + scheme_push_continuation_frame(&cframe); scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark)); - MZ_CONT_MARK_POS -= 2; need_pop_mark = 1; }else need_pop_mark = 0; + if (need_pop_mark) + MZ_CONT_MARK_POS -= 2; + if (SCHEME_CHAPERONEP(px->prev)) { /* commuincate `self_proc` to the next layer: */ scheme_current_thread->self_for_proc_chaperone = self_proc; @@ -3891,7 +4032,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object " original: %V\n" " wrapper: %V\n" " number of values: %d", - what, + CHAPERONE_KIND_STR(px), o, post, c); @@ -3937,7 +4078,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object " wrapper: %V\n" " expected: %d\n" " received: %d", - what, + CHAPERONE_KIND_STR(px), o, post, c, argc); diff --git a/racket/src/racket/src/future.c b/racket/src/racket/src/future.c index ba46ad5222..46342ecfb1 100644 --- a/racket/src/racket/src/future.c +++ b/racket/src/racket/src/future.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2006-2015 PLT Design Inc. + Copyright (c) 2006-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public diff --git a/racket/src/racket/src/hash.c b/racket/src/racket/src/hash.c index f2e995b6db..98dee6ccbc 100644 --- a/racket/src/racket/src/hash.c +++ b/racket/src/racket/src/hash.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -164,6 +164,49 @@ static void string_hash_indices(void *_key, intptr_t *_h, intptr_t *_h2) *_h2 = to_signed_hash(h2); } +/*========================================================================*/ +/* equality with wraps */ +/*========================================================================*/ + +static Scheme_Object *apply_equal_key_wraps(Scheme_Object *key, Scheme_Object *key_wraps) +{ + if (key_wraps) { + GC_CAN_IGNORE const char *who = (const char *)SCHEME_CAR(key_wraps); + Scheme_Chaperone *px; + Scheme_Object *a[2], *red; + + key_wraps = SCHEME_CDR(key_wraps); + while (!SCHEME_NULLP(key_wraps)) { + px = (Scheme_Chaperone *)SCHEME_CAR(key_wraps); + + red = SCHEME_BOX_VAL(px->redirects); + red = SCHEME_VEC_ELS(red)[5]; + + a[0] = px->prev; + a[1] = key; + key = _scheme_apply(red, 2, a); + + if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR) + && !scheme_chaperone_of(key, a[1])) { + scheme_wrong_chaperoned(who, "key", a[1], key); + return 0; + } + + key_wraps = SCHEME_CDR(key_wraps); + } + } + + return key; +} + +static int equal_w_key_wraps(Scheme_Object *ekey, Scheme_Object *tkey, Scheme_Object *key_wraps) +{ + if (key_wraps) + tkey = apply_equal_key_wraps(tkey, key_wraps); + + return scheme_equal(ekey, tkey); +} + /*========================================================================*/ /* normal hash table */ /*========================================================================*/ @@ -201,9 +244,10 @@ void scheme_clear_hash_table(Scheme_Hash_Table *ht) ht->mcount = 0; } -static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int set, Scheme_Object *val) +static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int set, Scheme_Object *val, + Scheme_Object *key_wraps) { - Scheme_Object *tkey, **keys; + Scheme_Object *tkey, *ekey, **keys; intptr_t hx, h2x; hash_v_t h, h2, useme = 0; uintptr_t mask; @@ -214,8 +258,12 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int if (table->make_hash_indices) { if (table->compare == scheme_compare_equal) { + if (key_wraps) + ekey = apply_equal_key_wraps(key, key_wraps); + else + ekey = key; h2 = 0; - hx = scheme_equal_hash_key(key); + hx = scheme_equal_hash_key(ekey); h = to_unsigned_hash(hx) & mask; } else { GC_CAN_IGNORE intptr_t *_h2x; @@ -228,19 +276,21 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int h = to_unsigned_hash(hx) & mask; if (_h2x) h2 = (to_unsigned_hash(h2x) & mask) | 1; + ekey = NULL; } } else { uintptr_t lkey; lkey = PTR_TO_LONG((Scheme_Object *)key); h = lkey & mask; h2 = ((lkey >> 1) & mask) | 1; + ekey = NULL; } keys = table->keys; if (table->compare) { if (table->compare == scheme_compare_equal) { - /* Direct calls can be significant faster than indirect */ + /* Direct calls can be significantly faster than indirect */ scheme_hash_request_count++; while ((tkey = keys[HASH_TO_ARRAY_INDEX(h, mask)])) { if (SAME_PTR(tkey, GONE)) { @@ -248,7 +298,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int useme = h; set = 1; } - } else if (scheme_equal(tkey, key)) { + } else if (equal_w_key_wraps(ekey, tkey, key_wraps)) { if (set) { table->vals[HASH_TO_ARRAY_INDEX(h, mask)] = val; if (!val) { @@ -261,7 +311,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int } scheme_hash_iteration_count++; if (!h2) { - h2x = scheme_equal_hash_key2(key); + h2x = scheme_equal_hash_key2(ekey); h2 = (to_unsigned_hash(h2x) & (table->size - 1)) | 1; } h = (h + h2) & mask; @@ -346,7 +396,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int table->mcount = 0; for (i = 0; i < oldsize; i++) { if (oldkeys[i] && !SAME_PTR(oldkeys[i], GONE)) - do_hash(table, oldkeys[i], 2, oldvals[i]); + do_hash(table, oldkeys[i], 2, oldvals[i], key_wraps); } goto rehash_key; @@ -405,7 +455,7 @@ static Scheme_Object *do_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, h = useme; else if (table->mcount * FILL_FACTOR >= table->size) { /* Use slow path to grow table: */ - return do_hash(table, key, 2, val); + return do_hash(table, key, 2, val, NULL); } else { table->mcount++; } @@ -446,7 +496,8 @@ XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Schem return NULL; } -void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val) +void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val, + Scheme_Object *key_wraps) { if (!table->vals) { Scheme_Object **ba; @@ -460,21 +511,32 @@ void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object } if (table->make_hash_indices) - do_hash(table, key, 2, val); + do_hash(table, key, 2, val, key_wraps); else do_hash_set(table, key, val); } -Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key) +void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val) +{ + scheme_hash_set_w_key_wraps(table, key, val, NULL); +} + +Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, + Scheme_Object *key_wraps) { if (!table->vals) return NULL; else if (table->make_hash_indices) - return do_hash(table, key, 0, NULL); + return do_hash(table, key, 0, NULL, key_wraps); else return do_hash_get(table, key); } +Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key) +{ + return scheme_hash_get_w_key_wraps(table, key, NULL); +} + Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key) /* Specialized to allow XFORM_NONGCING */ { @@ -692,10 +754,12 @@ allocate_bucket (Scheme_Bucket_Table *table, const char *key, void *val) } static Scheme_Bucket * -get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket *b) +get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket *b, + Scheme_Object *key_wraps) { intptr_t hx, h2x; hash_v_t h, h2; + void *ekey; Scheme_Bucket *bucket; Compare_Proc compare = table->compare; uintptr_t mask; @@ -705,7 +769,11 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket mask = table->size - 1; if (table->make_hash_indices) { - table->make_hash_indices((void *)key, &hx, &h2x); + if (key_wraps) + ekey = apply_equal_key_wraps((Scheme_Object *)key, key_wraps); + else + ekey = (void *)key; + table->make_hash_indices(ekey, &hx, &h2x); h = to_unsigned_hash(hx) & mask; h2 = to_unsigned_hash(h2x) & mask; } else { @@ -713,6 +781,7 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket lkey = PTR_TO_LONG((Scheme_Object *)key); h = lkey & mask; h2 = (lkey >> 1) & mask; + ekey = NULL; } h2 |= 0x1; @@ -728,7 +797,10 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket reuse_bucket = h + 1; } else if (SAME_PTR(hk, key)) return bucket; - else if (compare && !compare((void *)hk, (void *)key)) + else if (key_wraps) { + if (equal_w_key_wraps((Scheme_Object *)ekey, (Scheme_Object *)hk, key_wraps)) + return bucket; + } else if (compare && !compare((void *)hk, ekey)) return bucket; } else if (add) break; @@ -747,7 +819,10 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket while ((bucket = table->buckets[HASH_TO_ARRAY_INDEX(h, mask)])) { if (SAME_PTR(bucket->key, key)) return bucket; - else if (compare && !compare((void *)bucket->key, (void *)key)) + else if (key_wraps) { + if (equal_w_key_wraps((Scheme_Object *)ekey, (Scheme_Object *)bucket->key, key_wraps)) + return bucket; + } else if (compare && !compare((void *)bucket->key, (void *)key)) return bucket; scheme_hash_iteration_count++; h = (h + h2) & mask; @@ -800,12 +875,12 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket if (table->weak) { for (i = 0; i < oldsize; i++) { if (old[i] && old[i]->key && HT_EXTRACT_WEAK(old[i]->key)) - get_bucket(table, (char *)HT_EXTRACT_WEAK(old[i]->key), 1, old[i]); + get_bucket(table, (char *)HT_EXTRACT_WEAK(old[i]->key), 1, old[i], key_wraps); } } else { for (i = 0; i < oldsize; i++) { if (old[i] && old[i]->key) - get_bucket(table, old[i]->key, 1, old[i]); + get_bucket(table, old[i]->key, 1, old[i], key_wraps); } } @@ -825,28 +900,35 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket } Scheme_Bucket * -scheme_bucket_or_null_from_table (Scheme_Bucket_Table *table, const char *key, int add) +scheme_bucket_or_null_from_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key, int add, + Scheme_Object *key_wraps) { Scheme_Bucket *b; - b = get_bucket(table, key, add, NULL); + b = get_bucket(table, key, add, NULL, key_wraps); return b; } +Scheme_Bucket * +scheme_bucket_or_null_from_table (Scheme_Bucket_Table *table, const char *key, int add) +{ + return scheme_bucket_or_null_from_table_w_key_wraps(table, key, add, NULL); +} + Scheme_Bucket * scheme_bucket_from_table (Scheme_Bucket_Table *table, const char *key) { - return scheme_bucket_or_null_from_table(table, key, 1); + return scheme_bucket_or_null_from_table_w_key_wraps(table, key, 1, NULL); } void -scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val, - int constant) +scheme_add_to_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key, void *val, + int constant, Scheme_Object *key_wraps) { Scheme_Bucket *b; - b = get_bucket(table, key, 1, NULL); + b = get_bucket(table, key, 1, NULL, key_wraps); if (val) b->val = val; @@ -854,17 +936,25 @@ scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val, ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_CONST; } +void +scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val, + int constant) +{ + scheme_add_to_table_w_key_wraps(table, key, val, constant, NULL); +} + void scheme_add_bucket_to_table(Scheme_Bucket_Table *table, Scheme_Bucket *b) { - get_bucket(table, table->weak ? (char *)HT_EXTRACT_WEAK(b->key) : b->key, 1, b); + get_bucket(table, table->weak ? (char *)HT_EXTRACT_WEAK(b->key) : b->key, 1, b, NULL); } void * -scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key) +scheme_lookup_in_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key, + Scheme_Object *key_wraps) { Scheme_Bucket *bucket; - bucket = get_bucket(table, key, 0, NULL); + bucket = get_bucket(table, key, 0, NULL, key_wraps); if (bucket) return bucket->val; @@ -872,12 +962,18 @@ scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key) return NULL; } +void * +scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key) +{ + return scheme_lookup_in_table_w_key_wraps(table, key, NULL); +} + void scheme_change_in_table (Scheme_Bucket_Table *table, const char *key, void *naya) { Scheme_Bucket *bucket; - bucket = get_bucket(table, key, 0, NULL); + bucket = get_bucket(table, key, 0, NULL, NULL); if (bucket) bucket->val = naya; @@ -1331,7 +1427,12 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi) t = SCHEME_TYPE(o); if (t == scheme_hash_tree_indirection_type) { - o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + if (SAME_OBJ(o, orig_obj)) { + o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + orig_obj = o; + } else { + o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + } t = SCHEME_TYPE(o); } @@ -2064,10 +2165,16 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi) return k; } - case scheme_hash_tree_type: + case scheme_hash_tree_indirection_type: + if (!SAME_OBJ(o, orig_obj)) { + o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + } else { + o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + orig_obj = o; + } + case scheme_hash_tree_type: /* ^^^ fallthrough ^^^ */ case scheme_eq_hash_tree_type: case scheme_eqv_hash_tree_type: - case scheme_hash_tree_indirection_type: { Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o; Scheme_Object *iv, *ik; @@ -2596,7 +2703,8 @@ int scheme_hash_tree_index(Scheme_Hash_Tree *ht, mzlonglong pos, Scheme_Object * } static Scheme_Object *hamt_linear_search(Scheme_Hash_Tree *tree, int stype, Scheme_Object *key, - GC_CAN_IGNORE int *_i, GC_CAN_IGNORE uintptr_t *_code) + GC_CAN_IGNORE int *_i, GC_CAN_IGNORE uintptr_t *_code, + Scheme_Object *key_wraps) /* in the case of hash collisions, we put the colliding elements in a tree that uses integers as keys; we have to search through the tree for keys, but the advatange of using a HAMT (instead of a list) is @@ -2613,7 +2721,7 @@ static Scheme_Object *hamt_linear_search(Scheme_Hash_Tree *tree, int stype, Sche return found_val; } } else if (stype == scheme_hash_tree_type) { - if (scheme_equal(key, found_key)) { + if (equal_w_key_wraps(key, found_key, key_wraps)) { if (_i) *_i = i; return found_val; } @@ -2768,7 +2876,8 @@ Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *ke return NULL; } -Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) +Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, + Scheme_Object *key_wraps) { uintptr_t h; int stype, pos; @@ -2778,9 +2887,11 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) if (stype == scheme_eq_hash_tree_type) return scheme_eq_hash_tree_get(tree, key); - else if (stype == scheme_hash_tree_type) + else if (stype == scheme_hash_tree_type) { + if (key_wraps) + key = apply_equal_key_wraps(key, key_wraps); h = to_unsigned_hash(scheme_equal_hash_key(key)); - else + } else h = to_unsigned_hash(scheme_eqv_hash_key(key)); tree = hamt_assoc(tree, h, &pos, 0); @@ -2790,10 +2901,10 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) if (HASHTR_COLLISIONP(tree->els[pos])) { /* hash collision; linear search in subtree */ uintptr_t code; - return hamt_linear_search((Scheme_Hash_Tree *)tree->els[pos], stype, key, NULL, &code); + return hamt_linear_search((Scheme_Hash_Tree *)tree->els[pos], stype, key, NULL, &code, key_wraps); } else { if (stype == scheme_hash_tree_type) { - if (scheme_equal(key, tree->els[pos])) + if (equal_w_key_wraps(key, tree->els[pos], key_wraps)) return mzHAMT_VAL(tree, pos); } else { if (scheme_eqv(key, tree->els[pos])) @@ -2804,20 +2915,29 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) return NULL; } -Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val) +Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) +{ + return scheme_hash_tree_get_w_key_wraps(tree, key, NULL); +} + +Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val, + Scheme_Object *key_wraps) /* val == NULL => remove */ { uintptr_t h; Scheme_Hash_Tree *in_tree; + Scheme_Object *ekey = key; int stype, pos; stype = SCHEME_TYPE(resolve_placeholder(tree)); if (stype == scheme_eq_hash_tree_type) h = PTR_TO_LONG((Scheme_Object *)key); - else if (stype == scheme_hash_tree_type) - h = to_unsigned_hash(scheme_equal_hash_key(key)); - else + else if (stype == scheme_hash_tree_type) { + if (key_wraps) + ekey = apply_equal_key_wraps(ekey, key_wraps); + h = to_unsigned_hash(scheme_equal_hash_key(ekey)); + } else h = to_unsigned_hash(scheme_eqv_hash_key(key)); in_tree = hamt_assoc(resolve_placeholder(tree), h, &pos, 0); @@ -2836,7 +2956,7 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke int i, inc; uintptr_t code; in_tree = (Scheme_Hash_Tree *)in_tree->els[pos]; - if (hamt_linear_search(in_tree, stype, key, &i, &code)) { + if (hamt_linear_search(in_tree, stype, key, &i, &code, key_wraps)) { /* key is part of the current collision */ if (!val) { if (in_tree->count == 2) { @@ -2874,7 +2994,7 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke if (stype == scheme_eq_hash_tree_type) same = SAME_OBJ(key, in_tree->els[pos]); else if (stype == scheme_hash_tree_type) - same = scheme_equal(key, in_tree->els[pos]); + same = equal_w_key_wraps(ekey, in_tree->els[pos], key_wraps); else same = scheme_eqv(key, in_tree->els[pos]); @@ -2910,13 +3030,22 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke } } +Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val) +{ + return scheme_hash_tree_set_w_key_wraps(tree, key, val, NULL); +} + static int hamt_equal_entries(int stype, void *eql_data, Scheme_Object *k1, Scheme_Object *v1, Scheme_Object *k2, Scheme_Object *v2) { if (stype == scheme_eq_hash_tree_type) { - if (SAME_OBJ(k1, k2)) - return scheme_recur_equal(v1, v2, eql_data); + if (SAME_OBJ(k1, k2)) { + if (eql_data) + return scheme_recur_equal(v1, v2, eql_data); + else + return SAME_OBJ(v1, v2); + } } else if (stype == scheme_hash_tree_type) { if (scheme_recur_equal(k1, k2, eql_data)) return scheme_recur_equal(v1, v2, eql_data); @@ -2946,6 +3075,16 @@ static int hamt_equal_entries(int stype, void *eql_data, #define HAMT_USE_FUEL(n) /* empty */ #include "hamt_subset.inc" +/* fast variant for eq-based dictionaries, where values are compared with `eq?` */ +#define HAMT_NONGCING XFORM_NONGCING +#define HAMT_SUBSET_OF hamt_eq_subset_match_of +#define HAMT_ELEMENT_OF hamt_eq_element_match_of +#define HAMT_ELEMENT_OF_COLLISION hamt_eq_element_match_of_collision +#define HAMT_EQUAL_ENTRIES(stype, eql_data, k1, v1, k2, v2) (SAME_OBJ(k1, k2) && SAME_OBJ(v1, v2)) +#define HAMT_IF_VAL(v, n) v +#define HAMT_USE_FUEL(n) /* empty */ +#include "hamt_subset.inc" + static uintptr_t hamt_combine_key_hashes(Scheme_Hash_Tree *ht) { int popcount, i; @@ -3026,6 +3165,18 @@ int scheme_eq_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2) return hamt_eq_subset_of(t1, t2, 0, scheme_eq_hash_tree_type, NULL); } +int scheme_eq_hash_tree_subset_match_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2) +/* assumes that `t1` and `t2` are sets, as opposed to maps */ +{ + t1 = resolve_placeholder(t1); + t2 = resolve_placeholder(t2); + + if (t1->count > t2->count) + return 0; + + return hamt_eq_subset_match_of(t1, t2, 0, scheme_eq_hash_tree_type, NULL); +} + intptr_t scheme_hash_tree_key_hash(Scheme_Hash_Tree *ht) { ht = resolve_placeholder(ht); diff --git a/racket/src/racket/src/jit.c b/racket/src/racket/src/jit.c index a57816e51d..8282905d7d 100644 --- a/racket/src/racket/src/jit.c +++ b/racket/src/racket/src/jit.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2006-2015 PLT Design Inc. + Copyright (c) 2006-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public @@ -453,18 +453,16 @@ Scheme_Object *scheme_extract_global(Scheme_Object *o, Scheme_Native_Closure *nc return globs->a[pos]; } -Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, int extra_push) +static Scheme_Object *extract_closure_local(int pos, mz_jit_state *jitter, int get_constant) { - int pos; - - pos = SCHEME_LOCAL_POS(obj); - pos -= extra_push; if (pos >= jitter->self_pos - jitter->self_to_closure_delta) { pos -= (jitter->self_pos - jitter->self_to_closure_delta); if (pos < jitter->nc->code->u2.orig_code->closure_size) { /* in the closure */ - return jitter->nc->vals[pos]; - } else { + if (!get_constant + || (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED)) + return jitter->nc->vals[pos]; + } else if (!get_constant) { /* maybe an example argument... which is useful when the enclosing function has been lifted, converting a closure element into an argument */ @@ -477,6 +475,43 @@ Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *ji return NULL; } +Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, + int extra_push, int get_constant) +{ + int pos; + + pos = SCHEME_LOCAL_POS(obj); + pos -= extra_push; + return extract_closure_local(pos, jitter, get_constant); +} + + +Scheme_Object *scheme_specialize_to_constant(Scheme_Object *obj, mz_jit_state *jitter, int extra_push) +{ + Scheme_Object *c; + + if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) { + if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)) { + c = scheme_extract_closure_local(obj, jitter, extra_push, 1); + if (c) { + MZ_ASSERT(SCHEME_TYPE(c) != scheme_prefix_type); + return c; + } + } + + if (SAME_TYPE(SCHEME_TYPE(obj), scheme_toplevel_type)) { + c = scheme_extract_global(obj, jitter->nc, 0); + if (c) { + c = ((Scheme_Bucket *)c)->val; + if (c) + return c; + } + } + } + + return obj; +} + int scheme_native_closure_preserves_marks(Scheme_Object *p) { Scheme_Native_Closure_Data *ndata = ((Scheme_Native_Closure *)p)->code; @@ -496,6 +531,8 @@ int scheme_native_closure_preserves_marks(Scheme_Object *p) int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack_start) { + a = scheme_specialize_to_constant(a, jitter, stack_start); + if (SCHEME_PRIMP(a)) { int opts; opts = ((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_OPT_MASK; @@ -601,27 +638,40 @@ int scheme_is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st break; case scheme_application_type: - if (scheme_inlined_nary_prim(((Scheme_App_Rec *)obj)->args[0], obj, jitter) - && !SAME_OBJ(((Scheme_App_Rec *)obj)->args[0], scheme_values_func)) - return 1; - if (just_markless) { - return scheme_is_noncm(((Scheme_App_Rec *)obj)->args[0], jitter, depth, - stack_start + ((Scheme_App_Rec *)obj)->num_args); + { + Scheme_Object *rator; + rator = scheme_specialize_to_constant(((Scheme_App_Rec *)obj)->args[0], jitter, + stack_start + ((Scheme_App_Rec *)obj)->num_args); + if (scheme_inlined_nary_prim(rator, obj, jitter) + && !SAME_OBJ(rator, scheme_values_func)) + return 1; + if (just_markless) { + return scheme_is_noncm(rator, jitter, depth, + stack_start + ((Scheme_App_Rec *)obj)->num_args); + } } break; case scheme_application2_type: - if (scheme_inlined_unary_prim(((Scheme_App2_Rec *)obj)->rator, obj, jitter)) - return 1; - else if (just_markless) { - return scheme_is_noncm(((Scheme_App2_Rec *)obj)->rator, jitter, depth, stack_start + 1); + { + Scheme_Object *rator; + rator = scheme_specialize_to_constant(((Scheme_App2_Rec *)obj)->rator, jitter, stack_start + 1); + if (scheme_inlined_unary_prim(rator, obj, jitter)) + return 1; + else if (just_markless) { + return scheme_is_noncm(rator, jitter, depth, stack_start + 1); + } } break; case scheme_application3_type: - if (scheme_inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj, jitter) - && !SAME_OBJ(((Scheme_App2_Rec *)obj)->rator, scheme_values_func)) - return 1; - else if (just_markless) { - return scheme_is_noncm(((Scheme_App3_Rec *)obj)->rator, jitter, depth, stack_start + 2); + { + Scheme_Object *rator; + rator = scheme_specialize_to_constant(((Scheme_App3_Rec *)obj)->rator, jitter, stack_start + 2); + if (scheme_inlined_binary_prim(rator, obj, jitter) + && !SAME_OBJ(rator, scheme_values_func)) + return 1; + else if (just_markless) { + return scheme_is_noncm(rator, jitter, depth, stack_start + 2); + } } break; @@ -878,6 +928,54 @@ int scheme_needs_only_target_register(Scheme_Object *obj, int and_can_reorder) return (t >= _scheme_compiled_values_types_); } +static int produces_single_value(Scheme_Object *rator, int num_args, mz_jit_state *jitter) +{ + rator = scheme_specialize_to_constant(rator, jitter, num_args); + + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_native_closure_type)) { + Scheme_Native_Closure *nc = (Scheme_Native_Closure *)rator; + if (nc->code->start_code == scheme_on_demand_jit_code) + return (SCHEME_CLOSURE_DATA_FLAGS(nc->code->u2.orig_code) & CLOS_SINGLE_RESULT); + else + return (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(nc->code) & NATIVE_IS_SINGLE_RESULT); + } + + if (SCHEME_PRIMP(rator)) { + int opt; + opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; + if (opt >= SCHEME_PRIM_OPT_NONCM) + return 1; + + /* special case: (values ) */ + if (SAME_OBJ(rator, scheme_values_func) && (num_args == 1)) + return 1; + } + + return 0; +} + +static int is_single_valued(Scheme_Object *obj, mz_jit_state *jitter) +{ + Scheme_Type t = SCHEME_TYPE(obj); + + switch(t) { + case scheme_application_type: + return produces_single_value(((Scheme_App_Rec *)obj)->args[0], ((Scheme_App_Rec *)obj)->num_args, jitter); + break; + case scheme_application2_type: + return produces_single_value(((Scheme_App2_Rec *)obj)->rator, 1, jitter); + break; + case scheme_application3_type: + return produces_single_value(((Scheme_App3_Rec *)obj)->rator, 2, jitter); + break; + default: + if (t > _scheme_values_types_) + return 1; + } + + return 0; +} + /*========================================================================*/ /* branch info */ /*========================================================================*/ @@ -1204,13 +1302,25 @@ static int generate_closure_fill(Scheme_Closure_Data *data, /* Fill in closure */ int j, size, pos; mzshort *map; + Scheme_Object *v; size = data->closure_size; map = data->closure_map; jit_addi_p(JIT_R2, JIT_R0, &((Scheme_Native_Closure *)0x0)->vals); for (j = 0; j < size; j++) { CHECK_LIMIT(); - pos = mz_remap(map[j]); - jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + + if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) + v = extract_closure_local(map[j], jitter, 1); + else + v = NULL; + + if (v) { + /* capture value directly within specialized */ + scheme_mz_load_retained(jitter, JIT_R1, v); + } else { + pos = mz_remap(map[j]); + jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + } jit_stxi_p(WORDS_TO_BYTES(j), JIT_R2, JIT_R1); } return 1; @@ -1686,6 +1796,9 @@ static int generate_branch(Scheme_Object *obj, mz_jit_state *jitter, int is_tail } CHECK_LIMIT(); + if (old_self_pos != jitter->self_pos) + scheme_signal_error("internal error: self position moved across test"); + save_ubd = jitter->unbox_depth; scheme_mz_unbox_restore(jitter, &ubs); @@ -1923,6 +2036,8 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w } #endif + obj = scheme_specialize_to_constant(obj, jitter, 0); + orig_target = target; result_ignored = (target < 0); if (target < 0) target = JIT_R0; @@ -1948,12 +2063,20 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w START_JIT_DATA(); LOG_IT(("top-level\n")); mz_rs_sync_fail_branch(); - /* Load global array: */ - pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); - mz_rs_ldxi(JIT_R2, pos); - /* Load bucket: */ - pos = SCHEME_TOPLEVEL_POS(obj); - jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); + if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) { + /* Must be a top-level that is not yet defined. */ + Scheme_Object *b; + mz_rs_sync_fail_branch(); + b = scheme_extract_global(obj, jitter->nc, 0); + scheme_mz_load_retained(jitter, JIT_R2, b); + } else { + /* Load global array: */ + pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); + mz_rs_ldxi(JIT_R2, pos); + /* Load bucket: */ + pos = SCHEME_TOPLEVEL_POS(obj); + jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); + } /* Extract bucket value */ jit_ldxi_p(target, JIT_R2, &(SCHEME_VAR_BUCKET(0x0)->val)); CHECK_LIMIT(); @@ -2054,15 +2177,23 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w case scheme_local_unbox_type: { int pos; + Scheme_Object *specialized = NULL; START_JIT_DATA(); LOG_IT(("unbox local\n")); + if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) + specialized = scheme_extract_closure_local(obj, jitter, 0, 1); + pos = mz_remap(SCHEME_LOCAL_POS(obj)); if (!result_ignored) { - mz_rs_ldxi(JIT_R0, pos); + if (specialized) + scheme_mz_load_retained(jitter, JIT_R0, specialized); + else + mz_rs_ldxi(JIT_R0, pos); jit_ldr_p(target, JIT_R0); } - if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_CLEAR_ON_READ) { + if ((SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_CLEAR_ON_READ) + && !specialized) { LOG_IT(("clear-on-read\n")); mz_rs_stxi(pos, JIT_RUNSTACK); } @@ -2248,7 +2379,6 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w case scheme_apply_values_type: { Scheme_Object *p, *v; - GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *ref5, *refloop; START_JIT_DATA(); LOG_IT(("appvals\n")); @@ -2256,146 +2386,172 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w v = SCHEME_PTR1_VAL(obj); p = SCHEME_PTR2_VAL(obj); - scheme_generate_non_tail(v, jitter, 0, 1, 0); - CHECK_LIMIT(); + v = scheme_specialize_to_constant(v, jitter, 0); + p = scheme_specialize_to_constant(p, jitter, 0); + + if (is_single_valued(p, jitter)) { + /* We might discover late that `v` produces a single value, + possibly because we're in a specialized closure. In that + case, use a plain application. */ + Scheme_Object *alt_rands[2]; + int r; + + alt_rands[0] = v; + alt_rands[1] = p; + + r = scheme_generate_app(NULL, alt_rands, 1, 0, jitter, is_tail, multi_ok, result_ignored, 0); - /* If v is not known to produce a procedure, then check result: */ - if (!is_a_procedure(v, jitter)) { - mz_rs_sync(); - (void)jit_bmsi_l(sjc.bad_app_vals_target, JIT_R0, 0x1); - jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type); - (void)jit_blti_i(sjc.bad_app_vals_target, JIT_R1, scheme_prim_type); - (void)jit_bgti_i(sjc.bad_app_vals_target, JIT_R1, scheme_proc_chaperone_type); CHECK_LIMIT(); - } - - mz_pushr_p(JIT_R0); - scheme_generate_non_tail(p, jitter, 1, 1, 0); - CHECK_LIMIT(); - - mz_popr_p(JIT_V1); - /* Function is in V1, argument(s) in R0 */ - - mz_rs_sync(); - - __START_SHORT_JUMPS__(1); - ref = jit_beqi_p(jit_forward(), JIT_R0, SCHEME_MULTIPLE_VALUES); - /* Single-value case: --------------- */ - /* We definitely have stack space for one argument, because we - just used it for the rator. */ - if (is_tail) { - mz_ld_runstack_base_alt(JIT_RUNSTACK); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK_BASE_OR_ALT(JIT_RUNSTACK), WORDS_TO_BYTES(1)); - } else { - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); - } - CHECK_RUNSTACK_OVERFLOW(); - jit_str_p(JIT_RUNSTACK, JIT_R0); - jit_movi_l(JIT_R0, 1); - ref2 = jit_jmpi(jit_forward()); - CHECK_LIMIT(); - - /* Multiple-values case: ------------ */ - mz_patch_branch(ref); - /* Get new argc: */ - (void)mz_tl_ldi_p(JIT_R1, tl_scheme_current_thread); - jit_ldxi_l(JIT_R2, JIT_R1, &((Scheme_Thread *)0x0)->ku.multiple.count); - /* Enough room on runstack? */ - mz_tl_ldi_p(JIT_R0, tl_MZ_RUNSTACK_START); - if (is_tail) { - mz_ld_runstack_base_alt(JIT_R0); - jit_subr_ul(JIT_R0, JIT_RUNSTACK_BASE_OR_ALT(JIT_R0), JIT_R0); - } else { - jit_subr_ul(JIT_R0, JIT_RUNSTACK, JIT_R0); - } - CHECK_LIMIT(); - /* R0 is space left (in bytes), R2 is argc */ - jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE); - if (is_tail) { - int fpos, fstack; - fstack = scheme_mz_flostack_save(jitter, &fpos); - __END_SHORT_JUMPS__(1); - scheme_mz_flostack_restore(jitter, 0, 0, 1, 1); - (void)jit_bltr_ul(sjc.app_values_tail_slow_code, JIT_R0, JIT_R2); - __START_SHORT_JUMPS__(1); - scheme_mz_flostack_restore(jitter, fstack, fpos, 0, 1); - ref5 = 0; - } else { - GC_CAN_IGNORE jit_insn *refok; - refok = jit_bger_ul(jit_forward(), JIT_R0, JIT_R2); - __END_SHORT_JUMPS__(1); - if (multi_ok) { - (void)jit_calli(sjc.app_values_multi_slow_code); - } else { - (void)jit_calli(sjc.app_values_slow_code); - } - __START_SHORT_JUMPS__(1); - ref5 = jit_jmpi(jit_forward()); - mz_patch_branch(refok); - } - CHECK_LIMIT(); - if (is_tail) { - mz_ld_runstack_base_alt(JIT_RUNSTACK); - jit_subr_ul(JIT_RUNSTACK, JIT_RUNSTACK_BASE_OR_ALT(JIT_RUNSTACK), JIT_R2); - } else { - jit_subr_ul(JIT_RUNSTACK, JIT_RUNSTACK, JIT_R2); - } - CHECK_RUNSTACK_OVERFLOW(); - /* Copy args: */ - jit_ldxi_l(JIT_R1, JIT_R1, &((Scheme_Thread *)0x0)->ku.multiple.array); - refloop = jit_get_ip(); - ref3 = jit_blei_l(jit_forward(), JIT_R2, 0); - jit_subi_l(JIT_R2, JIT_R2, JIT_WORD_SIZE); - jit_ldxr_p(JIT_R0, JIT_R1, JIT_R2); - jit_stxr_p(JIT_R2, JIT_RUNSTACK, JIT_R0); - (void)jit_jmpi(refloop); - CHECK_LIMIT(); - mz_patch_branch(ref3); - /* clear array pointer and re-laod argc: */ - (void)mz_tl_ldi_p(JIT_R0, tl_scheme_current_thread); - (void)jit_movi_p(JIT_R1, NULL); - jit_stxi_l(&((Scheme_Thread *)0x0)->ku.multiple.array, JIT_R0, JIT_R1); - jit_ldxi_l(JIT_R0, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.count); - CHECK_LIMIT(); - - /* Perform call --------------------- */ - /* Function is in V1, argc in R0, args on RUNSTACK */ - mz_patch_ucbranch(ref2); - __END_SHORT_JUMPS__(1); - - if (is_tail) { - if (!sjc.shared_tail_argc_code) { - sjc.shared_tail_argc_code = scheme_generate_shared_call(-1, jitter, 1, 0, 1, 0, 0, 0, 0); - } - mz_set_local_p(JIT_R0, JIT_LOCAL2); - (void)jit_jmpi(sjc.shared_tail_argc_code); - } else { - int mo = (multi_ok - ? (result_ignored ? SHARED_RESULT_IGNORED_CASE : SHARED_MULTI_OK_CASE) - : SHARED_SINGLE_VALUE_CASE); - void *code; - if (!sjc.shared_non_tail_argc_code[mo]) { - scheme_ensure_retry_available(jitter, multi_ok, result_ignored); - code = scheme_generate_shared_call(-2, jitter, multi_ok, result_ignored, 0, 0, 0, 0, 0); - sjc.shared_non_tail_argc_code[mo] = code; - } - code = sjc.shared_non_tail_argc_code[mo]; - (void)jit_calli(code); - /* non-tail code pops args off runstack for us */ - jitter->need_set_rs = 1; - mz_patch_ucbranch(ref5); if (target != JIT_R0) jit_movr_p(target, JIT_R0); + + if (for_branch) finish_branch(jitter, target, for_branch); + + return r; + } else { + GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *ref5, *refloop; + + scheme_generate_non_tail(v, jitter, 0, 1, 0); + CHECK_LIMIT(); + + /* If v is not known to produce a procedure, then check result: */ + if (!is_a_procedure(v, jitter)) { + mz_rs_sync(); + (void)jit_bmsi_l(sjc.bad_app_vals_target, JIT_R0, 0x1); + jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type); + (void)jit_blti_i(sjc.bad_app_vals_target, JIT_R1, scheme_prim_type); + (void)jit_bgti_i(sjc.bad_app_vals_target, JIT_R1, scheme_proc_chaperone_type); + CHECK_LIMIT(); + } + + mz_pushr_p(JIT_R0); + scheme_generate_non_tail(p, jitter, 1, 1, 0); + CHECK_LIMIT(); + + mz_popr_p(JIT_V1); + /* Function is in V1, argument(s) in R0 */ + + mz_rs_sync(); + + __START_SHORT_JUMPS__(1); + ref = jit_beqi_p(jit_forward(), JIT_R0, SCHEME_MULTIPLE_VALUES); + /* Single-value case: --------------- */ + /* We definitely have stack space for one argument, because we + just used it for the rator. */ + if (is_tail) { + mz_ld_runstack_base_alt(JIT_RUNSTACK); + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK_BASE_OR_ALT(JIT_RUNSTACK), WORDS_TO_BYTES(1)); + } else { + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + } + CHECK_RUNSTACK_OVERFLOW(); + jit_str_p(JIT_RUNSTACK, JIT_R0); + jit_movi_l(JIT_R0, 1); + ref2 = jit_jmpi(jit_forward()); + CHECK_LIMIT(); + + /* Multiple-values case: ------------ */ + mz_patch_branch(ref); + /* Get new argc: */ + (void)mz_tl_ldi_p(JIT_R1, tl_scheme_current_thread); + jit_ldxi_l(JIT_R2, JIT_R1, &((Scheme_Thread *)0x0)->ku.multiple.count); + /* Enough room on runstack? */ + mz_tl_ldi_p(JIT_R0, tl_MZ_RUNSTACK_START); + if (is_tail) { + mz_ld_runstack_base_alt(JIT_R0); + jit_subr_ul(JIT_R0, JIT_RUNSTACK_BASE_OR_ALT(JIT_R0), JIT_R0); + } else { + jit_subr_ul(JIT_R0, JIT_RUNSTACK, JIT_R0); + } + CHECK_LIMIT(); + /* R0 is space left (in bytes), R2 is argc */ + jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE); + if (is_tail) { + int fpos, fstack; + fstack = scheme_mz_flostack_save(jitter, &fpos); + __END_SHORT_JUMPS__(1); + scheme_mz_flostack_restore(jitter, 0, 0, 1, 1); + (void)jit_bltr_ul(sjc.app_values_tail_slow_code, JIT_R0, JIT_R2); + __START_SHORT_JUMPS__(1); + scheme_mz_flostack_restore(jitter, fstack, fpos, 0, 1); + ref5 = 0; + } else { + GC_CAN_IGNORE jit_insn *refok; + refok = jit_bger_ul(jit_forward(), JIT_R0, JIT_R2); + __END_SHORT_JUMPS__(1); + if (multi_ok) { + (void)jit_calli(sjc.app_values_multi_slow_code); + } else { + (void)jit_calli(sjc.app_values_slow_code); + } + __START_SHORT_JUMPS__(1); + ref5 = jit_jmpi(jit_forward()); + mz_patch_branch(refok); + } + CHECK_LIMIT(); + if (is_tail) { + mz_ld_runstack_base_alt(JIT_RUNSTACK); + jit_subr_ul(JIT_RUNSTACK, JIT_RUNSTACK_BASE_OR_ALT(JIT_RUNSTACK), JIT_R2); + } else { + jit_subr_ul(JIT_RUNSTACK, JIT_RUNSTACK, JIT_R2); + } + CHECK_RUNSTACK_OVERFLOW(); + /* Copy args: */ + jit_ldxi_l(JIT_R1, JIT_R1, &((Scheme_Thread *)0x0)->ku.multiple.array); + refloop = jit_get_ip(); + ref3 = jit_blei_l(jit_forward(), JIT_R2, 0); + jit_subi_l(JIT_R2, JIT_R2, JIT_WORD_SIZE); + jit_ldxr_p(JIT_R0, JIT_R1, JIT_R2); + jit_stxr_p(JIT_R2, JIT_RUNSTACK, JIT_R0); + (void)jit_jmpi(refloop); + CHECK_LIMIT(); + mz_patch_branch(ref3); + /* clear array pointer and re-laod argc: */ + (void)mz_tl_ldi_p(JIT_R0, tl_scheme_current_thread); + (void)jit_movi_p(JIT_R1, NULL); + jit_stxi_l(&((Scheme_Thread *)0x0)->ku.multiple.array, JIT_R0, JIT_R1); + jit_ldxi_l(JIT_R0, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.count); + CHECK_LIMIT(); + + /* Perform call --------------------- */ + /* Function is in V1, argc in R0, args on RUNSTACK */ + mz_patch_ucbranch(ref2); + __END_SHORT_JUMPS__(1); + + if (is_tail) { + if (!sjc.shared_tail_argc_code) { + sjc.shared_tail_argc_code = scheme_generate_shared_call(-1, jitter, 1, 0, 1, 0, 0, 0, 0); + } + mz_set_local_p(JIT_R0, JIT_LOCAL2); + (void)jit_jmpi(sjc.shared_tail_argc_code); + } else { + int mo = (multi_ok + ? (result_ignored ? SHARED_RESULT_IGNORED_CASE : SHARED_MULTI_OK_CASE) + : SHARED_SINGLE_VALUE_CASE); + void *code; + if (!sjc.shared_non_tail_argc_code[mo]) { + scheme_ensure_retry_available(jitter, multi_ok, result_ignored); + code = scheme_generate_shared_call(-2, jitter, multi_ok, result_ignored, 0, 0, 0, 0, 0); + sjc.shared_non_tail_argc_code[mo] = code; + } + code = sjc.shared_non_tail_argc_code[mo]; + (void)jit_calli(code); + /* non-tail code pops args off runstack for us */ + jitter->need_set_rs = 1; + mz_patch_ucbranch(ref5); + if (target != JIT_R0) + jit_movr_p(target, JIT_R0); + } + CHECK_LIMIT(); + + if (for_branch) finish_branch(jitter, target, for_branch); + + END_JIT_DATA(81); + + if (is_tail) + return 2; + return 1; } - CHECK_LIMIT(); - - if (for_branch) finish_branch(jitter, target, for_branch); - - END_JIT_DATA(81); - - if (is_tail) - return 2; - return 1; } break; case scheme_with_immed_mark_type: @@ -2568,7 +2724,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w return r; } - r = scheme_generate_app(app, NULL, app->num_args, jitter, is_tail, multi_ok, result_ignored, 0); + r = scheme_generate_app(app, NULL, app->num_args, app->num_args, jitter, is_tail, multi_ok, result_ignored, 0); CHECK_LIMIT(); if (target != JIT_R0) @@ -2596,7 +2752,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w args[0] = app->rator; args[1] = app->rand; - r = scheme_generate_app(NULL, args, 1, jitter, is_tail, multi_ok, result_ignored, 0); + r = scheme_generate_app(NULL, args, 1, 1, jitter, is_tail, multi_ok, result_ignored, 0); CHECK_LIMIT(); if (target != JIT_R0) @@ -2647,7 +2803,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w args[1] = app->rand1; args[2] = app->rand2; - r = scheme_generate_app(NULL, args, 2, jitter, is_tail, multi_ok, result_ignored, 0); + r = scheme_generate_app(NULL, args, 2, 2, jitter, is_tail, multi_ok, result_ignored, 0); CHECK_LIMIT(); if (target != JIT_R0) @@ -2727,13 +2883,20 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w if (lv->count == 1) { /* Expect one result: */ + Scheme_Object *specialized = NULL; + if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) + specialized = extract_closure_local(lv->position, jitter, 1); scheme_generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */ CHECK_LIMIT(); if (ab) { pos = mz_remap(lv->position); - mz_rs_ldxi(JIT_R2, pos); + if (specialized) + scheme_mz_load_retained(jitter, JIT_R2, specialized); + else + mz_rs_ldxi(JIT_R2, pos); jit_str_p(JIT_R2, JIT_R0); } else { + MZ_ASSERT(!specialized); pos = mz_remap(lv->position); mz_rs_stxi(pos, JIT_R0); } @@ -3347,6 +3510,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) void *retain_code = NULL; #endif int i, r, cnt, has_rest, is_method, num_params, to_args, argc, argv_delta; + int specialized; Scheme_Object **argv; start_code = jit_get_ip(); @@ -3549,26 +3713,32 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) to_args = 0; #endif + specialized = SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED; + /* Extract closure to runstack: */ cnt = data->closure_size; to_args += cnt; if (cnt) { - mz_rs_dec(cnt); - CHECK_RUNSTACK_OVERFLOW(); + if (specialized) { + /* References to closure data will be replaced with values */ + } else { + mz_rs_dec(cnt); + CHECK_RUNSTACK_OVERFLOW(); - for (i = cnt; i--; ) { - int pos; - pos = WORDS_TO_BYTES(i) + (intptr_t)&((Scheme_Native_Closure *)0x0)->vals; - jit_ldxi_p(JIT_R1, JIT_R0, pos); - mz_rs_stxi(i, JIT_R1); - CHECK_LIMIT(); + for (i = cnt; i--; ) { + int pos; + pos = WORDS_TO_BYTES(i) + (intptr_t)&((Scheme_Native_Closure *)0x0)->vals; + jit_ldxi_p(JIT_R1, JIT_R0, pos); + mz_rs_stxi(i, JIT_R1); + CHECK_LIMIT(); + } } } mz_rs_sync(); /* If we have a letrec context, record arities */ - if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_letrec_type)) { + if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_letrec_type) && !specialized) { Scheme_Letrec *lr = (Scheme_Letrec *)data->context; int pos, self_pos = -1; for (i = data->closure_size; i--; ) { @@ -3614,7 +3784,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) } else { #ifdef USE_FLONUM_UNBOXING /* Unpack flonum closure data */ - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { + if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) && !specialized) { for (i = data->closure_size; i--; ) { if (CLOSURE_CONTENT_IS_FLONUM(data, i) || CLOSURE_CONTENT_IS_EXTFLONUM(data, i)) { @@ -3632,7 +3802,12 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) } } else #endif - mz_runstack_pushed(jitter, cnt); + { + if (specialized) + mz_runstack_skipped(jitter, cnt); + else + mz_runstack_pushed(jitter, cnt); + } /* A define-values context? */ if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_toplevel_type)) { @@ -3738,6 +3913,9 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Schem abort(); } + if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) & NATIVE_SPECIALIZED) + SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) -= NATIVE_SPECIALIZED; + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_PRESERVES_MARKS) SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) |= NATIVE_PRESERVES_MARKS; if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT) diff --git a/racket/src/racket/src/jit.h b/racket/src/racket/src/jit.h index 694c8823aa..5d097e6011 100644 --- a/racket/src/racket/src/jit.h +++ b/racket/src/racket/src/jit.h @@ -152,8 +152,10 @@ END_XFORM_ARITH; # define SCHEME_FLOAT_TYPE scheme_double_type #endif +/* These flags are set post-JIT: */ #define NATIVE_PRESERVES_MARKS 0x1 #define NATIVE_IS_SINGLE_RESULT 0x2 +/* Pre-JIT flags are in "schpriv.h" */ #if defined(MZ_PRECISE_GC) && !defined(USE_COMPACT_3M_GC) # define CAN_INLINE_ALLOC @@ -201,12 +203,7 @@ END_XFORM_ARITH; #include "jitfpu.h" -#if 0 -static void assert_failure(int where) { printf("JIT assert failed %d\n", where); } -#define JIT_ASSERT(v) if (!(v)) assert_failure(__LINE__); -#else -#define JIT_ASSERT(v) /* */ -#endif +#define JIT_ASSERT(v) MZ_ASSERT(v) /* Tracking statistics: */ #if 0 @@ -1315,11 +1312,7 @@ static void emit_indentation(mz_jit_state *jitter) /* jitstate */ /**********************************************************************/ -#if defined(SIXTY_FOUR_BIT_INTEGERS) || defined(MZ_USE_JIT_PPC) -# define JIT_BUFFER_PAD_SIZE 200 -#else -# define JIT_BUFFER_PAD_SIZE 100 -#endif +#define JIT_BUFFER_PAD_SIZE 200 #define PAST_LIMIT() ((uintptr_t)jit_get_raw_ip() > (uintptr_t)jitter->limit) #define CHECK_LIMIT() if (PAST_LIMIT()) return past_limit(jitter, __FILE__, __LINE__); @@ -1366,6 +1359,8 @@ long_double *scheme_mz_retain_long_double(mz_jit_state *jitter, long_double d); int scheme_mz_remap_it(mz_jit_state *jitter, int i); void scheme_mz_pushr_p_it(mz_jit_state *jitter, int reg); void scheme_mz_popr_p_it(mz_jit_state *jitter, int reg, int discard); +void scheme_extra_pushed(mz_jit_state *jitter, int n); +void scheme_extra_popped(mz_jit_state *jitter, int n); void scheme_mz_need_space(mz_jit_state *jitter, int need_extra); int scheme_stack_safety(mz_jit_state *jitter, int cnt, int offset); #ifdef USE_FLONUM_UNBOXING @@ -1482,7 +1477,7 @@ typedef struct jit_direct_arg jit_direct_arg; void *scheme_generate_shared_call(int num_rands, mz_jit_state *old_jitter, int multi_ok, int result_ignored, int is_tail, int direct_prim, int direct_native, int nontail_self, int unboxed_args); void scheme_ensure_retry_available(mz_jit_state *jitter, int multi_ok, int result_ignored); -int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, +int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, int num_pushes, mz_jit_state *jitter, int is_tail, int multi_ok, int ignored_result, int no_call); int scheme_generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_native, int need_set_rs, @@ -1591,7 +1586,8 @@ int scheme_jit_check_closure_extflonum_bit(Scheme_Closure_Data *data, int pos, i #endif Scheme_Object *scheme_extract_global(Scheme_Object *o, Scheme_Native_Closure *nc, int local_only); -Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, int extra_push); +Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, int extra_push, int get_constant); +Scheme_Object *scheme_specialize_to_constant(Scheme_Object *obj, mz_jit_state *jitter, int extra_push); void scheme_jit_register_traversers(void); #ifdef MZ_USE_LWC diff --git a/racket/src/racket/src/jitalloc.c b/racket/src/racket/src/jitalloc.c index 9213bf8a7a..8ae0f9c6eb 100644 --- a/racket/src/racket/src/jitalloc.c +++ b/racket/src/racket/src/jitalloc.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2006-2015 PLT Design Inc. + Copyright (c) 2006-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public diff --git a/racket/src/racket/src/jitarith.c b/racket/src/racket/src/jitarith.c index 4a81996ca9..e363df3050 100644 --- a/racket/src/racket/src/jitarith.c +++ b/racket/src/racket/src/jitarith.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2006-2015 PLT Design Inc. + Copyright (c) 2006-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public @@ -2241,7 +2241,7 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app, } if (stack_c) - scheme_generate_app(app, alt_args, stack_c, jitter, 0, 0, 0, 2); + scheme_generate_app(app, alt_args, stack_c, stack_c, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); diff --git a/racket/src/racket/src/jitcall.c b/racket/src/racket/src/jitcall.c index 6276c1f76d..ffeabfd26c 100644 --- a/racket/src/racket/src/jitcall.c +++ b/racket/src/racket/src/jitcall.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2006-2015 PLT Design Inc. + Copyright (c) 2006-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public @@ -66,6 +66,7 @@ static Scheme_Object *clear_runstack(Scheme_Object **rs, intptr_t amt, Scheme_Ob static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, GC_CAN_IGNORE jit_insn *refagain) { GC_CAN_IGNORE jit_insn *ref2, *refz1, *refz2, *refz3, *refz4, *refz5; + GC_CAN_IGNORE jit_insn *refz6, *refz7, *refz8; ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_struct_type); jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Structure *)0x0)->stype); @@ -109,11 +110,27 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, (void)jit_jmpi(refagain); CHECK_LIMIT(); + mz_patch_branch(ref2); + /* check for a procedure impersonator that just keeps properties */ + ref2 = jit_bnei_i(jit_forward(), JIT_R1, scheme_proc_chaperone_type); + jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Chaperone *)0x0)->redirects); + refz6 = mz_bnei_t(jit_forward(), JIT_R1, scheme_vector_type, JIT_R2); + (void)jit_ldxi_l(JIT_R2, JIT_R1, &SCHEME_VEC_SIZE(0x0)); + refz7 = jit_bmci_i(jit_forward(), JIT_R2, 0x1); + (void)jit_ldxi_l(JIT_R2, JIT_R1, &(SCHEME_VEC_ELS(0x0)[0])); + refz8 = jit_bnei_p(jit_forward(), JIT_R2, scheme_false); + /* Can extract the impersonated function and use it directly */ + jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Chaperone *)0x0)->prev); + (void)jit_jmpi(refagain); + mz_patch_branch(refz1); mz_patch_branch(refz2); mz_patch_branch(refz3); mz_patch_branch(refz4); mz_patch_branch(refz5); + mz_patch_branch(refz6); + mz_patch_branch(refz7); + mz_patch_branch(refz8); return ref2; } @@ -347,10 +364,12 @@ int scheme_generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na must be >= 0 */ { int i, r2_has_runstack = 0; - GC_CAN_IGNORE jit_insn *refagain, *ref, *ref2, *ref4, *ref5; + GC_CAN_IGNORE jit_insn *top_refagain, *refagain, *ref, *ref2, *ref4, *ref5; __START_SHORT_JUMPS__(num_rands < 100); + top_refagain = jit_get_ip(); + /* First, try fast direct jump to native code: */ if (!direct_native) { ref = jit_bmsi_ul(jit_forward(), JIT_V1, 0x1); @@ -474,7 +493,7 @@ int scheme_generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na /* Handle simple applicable struct: */ mz_patch_branch(ref2); /* uses JIT_R1: */ - ref2 = generate_proc_struct_retry(jitter, num_rands, refagain); + ref2 = generate_proc_struct_retry(jitter, num_rands, top_refagain); CHECK_LIMIT(); } @@ -767,7 +786,7 @@ int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc if num_rands != -3, need to pop runstack before returning. If num_rands == -1 or -3, skip prolog. */ GC_CAN_IGNORE jit_insn *ref, *ref2, *ref4, *ref5, *ref6, *ref7, *ref8, *ref9; - GC_CAN_IGNORE jit_insn *ref10, *refagain; + GC_CAN_IGNORE jit_insn *ref10, *refagain, *top_refagain; GC_CAN_IGNORE jit_insn *refrts USED_ONLY_FOR_FUTURES; #ifndef FUEL_AUTODECEREMENTS GC_CAN_IGNORE jit_insn *ref11; @@ -785,6 +804,8 @@ int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc } } + top_refagain = jit_get_ip(); + /* Check for inlined native type */ if (!direct_native) { ref = jit_bmsi_ul(jit_forward(), JIT_V1, 0x1); @@ -1029,7 +1050,7 @@ int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc if (!is_inlined && (num_rands >= 0)) { mz_patch_branch(ref2); /* uses JIT_R1 */ - ref2 = generate_proc_struct_retry(jitter, num_rands, refagain); + ref2 = generate_proc_struct_retry(jitter, num_rands, top_refagain); CHECK_LIMIT(); } } else { @@ -1709,13 +1730,14 @@ static int generate_call_path_with_unboxes(mz_jit_state *jitter, int direct_flos /* Reset V1 to rator for slow path: */ scheme_generate(rator, jitter, 0, 0, 0, JIT_V1, NULL, NULL); + CHECK_LIMIT(); mz_rs_sync(); return 1; } #endif -int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, +int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, int num_pushes, mz_jit_state *jitter, int is_tail, int multi_ok, int result_ignored, int no_call) /* de-sync'd ok @@ -1740,6 +1762,8 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ rator = (alt_rands ? alt_rands[0] : app->args[0]); + rator = scheme_specialize_to_constant(rator, jitter, num_pushes); + if (no_call == 2) { direct_prim = 1; } else if (SCHEME_PRIMP(rator)) { @@ -1761,6 +1785,13 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } else { Scheme_Type t; t = SCHEME_TYPE(rator); + + if (t == scheme_case_closure_type) { + /* Turn it into a JITted empty case closure: */ + rator = scheme_unclose_case_lambda(rator, 1); + t = SCHEME_TYPE(rator); + } + if ((t == scheme_local_type) && scheme_ok_to_delay_local(rator)) { /* We can re-order evaluation of the rator. */ reorder_ok = 1; @@ -1768,7 +1799,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ /* Call to known native, or even known self? */ { int pos, flags; - pos = SCHEME_LOCAL_POS(rator) - num_rands; + pos = SCHEME_LOCAL_POS(rator) - num_pushes; if (scheme_mz_is_closure(jitter, pos, num_rands, &flags)) { direct_native = 1; if ((pos == jitter->self_pos) @@ -1806,6 +1837,9 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } } } + } else if (SAME_TYPE(t, scheme_native_closure_type)) { + direct_native = can_direct_native(rator, num_rands, &extract_case); + reorder_ok = 1; } else if (SAME_TYPE(t, scheme_closure_type)) { Scheme_Closure_Data *data; data = ((Scheme_Closure *)rator)->code; @@ -1895,7 +1929,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ locations that will be filled with argument values; that is, check how many arguments are already in place for the call. */ - mz_runstack_skipped(jitter, num_rands); + mz_runstack_skipped(jitter, num_pushes); for (i = 0; i < num_rands; i++) { v = (alt_rands ? alt_rands[i+1] : app->args[i+1]); if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type) @@ -1909,11 +1943,14 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } else break; } - mz_runstack_unskipped(jitter, num_rands); + mz_runstack_unskipped(jitter, num_pushes); if (args_already_in_place) { direct_native = 2; - mz_runstack_skipped(jitter, args_already_in_place); + if (num_pushes) + mz_runstack_skipped(jitter, args_already_in_place); num_rands -= args_already_in_place; + if (num_pushes) + num_pushes -= args_already_in_place; } LOG_IT((" [args in place: %d]\n", args_already_in_place)); } @@ -1926,7 +1963,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (num_rands) { if (inline_direct_args) { - mz_runstack_skipped(jitter, num_rands); + mz_runstack_skipped(jitter, num_pushes); } else if (!direct_prim || (num_rands > 1) || (no_call == 2)) { int skip_end = 0; if (direct_self && is_tail && !no_call && (num_rands > 0)) { @@ -1936,13 +1973,17 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (num_rands - skip_end > 0) { mz_rs_dec(num_rands-skip_end); CHECK_RUNSTACK_OVERFLOW(); - mz_runstack_pushed(jitter, num_rands-skip_end); + if (num_pushes) + mz_runstack_pushed(jitter, num_pushes-skip_end); + else + scheme_extra_pushed(jitter, num_rands-skip_end); } need_safety = num_rands-skip_end; - if (skip_end) + if (skip_end && num_pushes) mz_runstack_skipped(jitter, skip_end); } else { - mz_runstack_skipped(jitter, 1); + if (num_pushes) + mz_runstack_skipped(jitter, 1); } } @@ -2103,7 +2144,8 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (!no_call) { (void)jit_movi_p(JIT_V1, ((Scheme_Primitive_Proc *)rator)->prim_val); if (num_rands == 1) { - mz_runstack_unskipped(jitter, 1); + if (num_pushes) + mz_runstack_unskipped(jitter, 1); } else { mz_rs_sync(); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); diff --git a/racket/src/racket/src/jitcommon.c b/racket/src/racket/src/jitcommon.c index e58e30ec06..98d34274e1 100644 --- a/racket/src/racket/src/jitcommon.c +++ b/racket/src/racket/src/jitcommon.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2006-2015 PLT Design Inc. + Copyright (c) 2006-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public @@ -3967,6 +3967,7 @@ static int more_common1(mz_jit_state *jitter, void *_data) /* -3 here means "don't pop the arguments"; need regular argument handling via `reftop` for tail calls */ scheme_generate_non_tail_call(jitter, -3, 0, 1, multi_ok, 0, 0, 1, 0, 0, reftop); + CHECK_LIMIT(); scheme_jit_register_sub_func(jitter, code, scheme_false); } diff --git a/racket/src/racket/src/jitinline.c b/racket/src/racket/src/jitinline.c index f22d78a755..3b0fef43d3 100644 --- a/racket/src/racket/src/jitinline.c +++ b/racket/src/racket/src/jitinline.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2006-2015 PLT Design Inc. + Copyright (c) 2006-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public @@ -174,11 +174,12 @@ static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int ex return check_val_struct_prim(p, arity); } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_local_type)) { Scheme_Object *p; - p = scheme_extract_closure_local(o, jitter, extra_push); + p = scheme_extract_closure_local(o, jitter, extra_push, 0); return check_val_struct_prim(p, arity); } } - return 0; + + return check_val_struct_prim(o, 1); } int scheme_inlined_unary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_state *jitter) @@ -371,6 +372,9 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app static Scheme_Object *extract_struct_constant(mz_jit_state *jitter, Scheme_Object *rator) { + if (SCHEME_PROCP(rator)) + return rator; + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_toplevel_type) && (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST) { rator = scheme_extract_global(rator, jitter->nc, 0); @@ -401,7 +405,7 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, args[0] = rator; args[1] = rand; args[2] = rand2; - scheme_generate_app(NULL, args, 2, jitter, 0, 0, 0, 1); /* sync'd below */ + scheme_generate_app(NULL, args, 2, 2, jitter, 0, 0, 0, 1); /* sync'd below */ CHECK_LIMIT(); jit_movr_p(JIT_R0, JIT_V1); mz_rs_ldr(JIT_R1); @@ -623,7 +627,7 @@ static int generate_inlined_nary_struct_op(int kind, mz_jit_state *jitter, /* de-sync'd ok; for branch, sync'd before */ { /* generate code to evaluate the arguments */ - scheme_generate_app(app, NULL, app->num_args, jitter, 0, 0, 0, 1); + scheme_generate_app(app, NULL, app->num_args, app->num_args, jitter, 0, 0, 0, 1); CHECK_LIMIT(); mz_rs_sync(); @@ -947,6 +951,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in { Scheme_Object *rator = app->rator; + rator = scheme_specialize_to_constant(rator, jitter, 1); + { int k; k = inlineable_struct_prim(rator, jitter, 1, 1); @@ -2088,6 +2094,9 @@ int scheme_generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ Return is 1 if thr arguments are in order, -1 if reversed. */ { int simple1, simple2, direction = 1; + + rand1 = scheme_specialize_to_constant(rand1, jitter, skipped); + rand2 = scheme_specialize_to_constant(rand2, jitter, skipped); simple1 = scheme_is_relatively_constant_and_avoids_r1(rand1, rand2); simple2 = scheme_is_relatively_constant_and_avoids_r1(rand2, rand1); @@ -2166,6 +2175,7 @@ int scheme_generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ if (simple2 && !order_matters && already_in_register(rand1, jitter)) { scheme_generate(rand1, jitter, 0, 0, 0, JIT_R1, NULL, NULL); /* no sync... */ + CHECK_LIMIT(); scheme_generate(rand2, jitter, 0, 0, 0, JIT_R0, NULL, NULL); /* no sync... */ direction = -1; } else { @@ -2479,6 +2489,8 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i { Scheme_Object *rator = app->rator; + rator = scheme_specialize_to_constant(rator, jitter, 2); + if (SCHEME_PRIMP(rator) && IS_NAMED_PRIM(rator, "ptr-ref")) { Scheme_App_Rec *app2; mz_rs_sync(); @@ -3426,6 +3438,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i scheme_mz_unbox_save(jitter, &ubs); /* no unboxing of vector and index arguments */ scheme_generate_two_args(app->rand1, app->rand2, jitter, 1, 2); + CHECK_LIMIT(); scheme_mz_unbox_restore(jitter, &ubs); CHECK_LIMIT(); @@ -3468,6 +3481,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i is_u = IS_NAMED_PRIM(rator, "unsafe-u16vector-ref"); scheme_generate_two_args(app->rand1, app->rand2, jitter, 1, 2); + CHECK_LIMIT(); jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&(((Scheme_Structure *)0x0)->slots[0])); jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CPTR_VAL(0x0)); @@ -3484,6 +3498,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i } else if (IS_NAMED_PRIM(rator, "list-ref") || IS_NAMED_PRIM(rator, "list-tail")) { scheme_generate_two_args(app->rand1, app->rand2, jitter, 1, 2); + CHECK_LIMIT(); mz_rs_sync(); if (IS_NAMED_PRIM(rator, "list-ref")) @@ -3518,6 +3533,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i } scheme_generate_two_args(app->rand1, app->rand2, jitter, 1, 2); + CHECK_LIMIT(); if (IS_NAMED_PRIM(rator, "unsafe-list-ref")) (void)jit_calli(sjc.list_ref_code); @@ -3864,7 +3880,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i args[1] = app->rand1; args[2] = app->rand2; - scheme_generate_app(NULL, args, 2, jitter, 0, 0, 0, 2); + scheme_generate_app(NULL, args, 2, 2, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -3945,7 +3961,9 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int /* de-sync's; for branch, sync'd before */ { Scheme_Object *rator = app->args[0]; - + + rator = scheme_specialize_to_constant(rator, jitter, app->num_args); + if (!for_branch) { int k; k = inlineable_struct_prim(rator, jitter, app->num_args, app->num_args); @@ -4000,7 +4018,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } /* generate code to evaluate the arguments */ - scheme_generate_app(app, NULL, 3, jitter, 0, 0, 0, 2); + scheme_generate_app(app, NULL, 3, 3, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4255,6 +4273,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int scheme_generate(app->args[3], jitter, 0, 0, 0, JIT_R2, NULL, NULL); /* sync'd below */ else { scheme_generate_non_tail(app->args[3], jitter, 0, 1, 0); /* sync'd below */ + CHECK_LIMIT(); jit_movr_p(JIT_R2, JIT_R0); } } @@ -4450,7 +4469,8 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } else { got_two = 1; mz_runstack_skipped(jitter, 1); - scheme_generate_app(app, NULL, 2, jitter, 0, 0, 0, 2); + scheme_generate_app(app, NULL, 2, 2, jitter, 0, 0, 0, 2); + CHECK_LIMIT(); } if (scheme_can_unbox_inline(app->args[3], 5, JIT_FPUSEL_FPR_NUM(extfl)-1, 1, extfl)) @@ -4515,7 +4535,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int star = IS_NAMED_PRIM(rator, "list*"); if (c) - scheme_generate_app(app, NULL, c, jitter, 0, 0, 0, 2); + scheme_generate_app(app, NULL, c, c, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4576,7 +4596,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int if (!multi_ok) return 0; if (c) { - scheme_generate_app(app, NULL, c, jitter, 0, 0, 0, 2); + scheme_generate_app(app, NULL, c, c, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4613,7 +4633,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } else if (IS_NAMED_PRIM(rator, "max")) { return scheme_generate_nary_arith(jitter, app, ARITH_MAX, 0, NULL, 1, dest); } else if (IS_NAMED_PRIM(rator, "checked-procedure-check-and-extract")) { - scheme_generate_app(app, NULL, 5, jitter, 0, 0, 0, 2); /* sync'd below */ + scheme_generate_app(app, NULL, 5, 5, jitter, 0, 0, 0, 2); /* sync'd below */ CHECK_LIMIT(); mz_rs_sync(); @@ -4636,7 +4656,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int is_ref = IS_NAMED_PRIM(rator, "ptr-ref"); abs_offset = (n == (is_ref ? 4 : 5)); - scheme_generate_app(app, NULL, n, jitter, 0, 0, 0, 2); /* sync'd below */ + scheme_generate_app(app, NULL, n, n, jitter, 0, 0, 0, 2); /* sync'd below */ CHECK_LIMIT(); mz_rs_sync(); @@ -4988,7 +5008,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, } else { c = app->num_args; if (c) - scheme_generate_app(app, NULL, c, jitter, 0, 0, 0, 2); /* sync'd below */ + scheme_generate_app(app, NULL, c, c, jitter, 0, 0, 0, 2); /* sync'd below */ } CHECK_LIMIT(); diff --git a/racket/src/racket/src/jitprep.c b/racket/src/racket/src/jitprep.c index ec147332d8..3b8978f81c 100644 --- a/racket/src/racket/src/jitprep.c +++ b/racket/src/racket/src/jitprep.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/jitstack.c b/racket/src/racket/src/jitstack.c index b13b2577d3..3663ac665d 100644 --- a/racket/src/racket/src/jitstack.c +++ b/racket/src/racket/src/jitstack.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2006-2015 PLT Design Inc. + Copyright (c) 2006-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public diff --git a/racket/src/racket/src/jitstate.c b/racket/src/racket/src/jitstate.c index 42040bb6f2..e3e71591c2 100644 --- a/racket/src/racket/src/jitstate.c +++ b/racket/src/racket/src/jitstate.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2006-2015 PLT Design Inc. + Copyright (c) 2006-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public @@ -487,12 +487,11 @@ static void new_mapping(mz_jit_state *jitter) jitter->mappings[jitter->num_mappings] = 0; } -void scheme_mz_pushr_p_it(mz_jit_state *jitter, int reg) -/* de-sync's rs */ +void scheme_extra_pushed(mz_jit_state *jitter, int n) { int v; - jitter->extra_pushed++; + jitter->extra_pushed += n; if (jitter->extra_pushed > jitter->max_extra_pushed) jitter->max_extra_pushed = jitter->extra_pushed; @@ -502,8 +501,14 @@ void scheme_mz_pushr_p_it(mz_jit_state *jitter, int reg) new_mapping(jitter); } v = (jitter->mappings[jitter->num_mappings]) >> 2; - v++; + v += n; jitter->mappings[jitter->num_mappings] = ((v << 2) | 0x1); +} + +void scheme_mz_pushr_p_it(mz_jit_state *jitter, int reg) +/* de-sync's rs */ +{ + scheme_extra_pushed(jitter, 1); mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW_NOCL(); @@ -512,21 +517,30 @@ void scheme_mz_pushr_p_it(mz_jit_state *jitter, int reg) jitter->need_set_rs = 1; } -void scheme_mz_popr_p_it(mz_jit_state *jitter, int reg, int discard) +void scheme_extra_popped(mz_jit_state *jitter, int n) /* de-sync's rs */ { int v; - jitter->extra_pushed--; + if (PAST_LIMIT()) return; + + jitter->extra_pushed -= n; JIT_ASSERT(jitter->mappings[jitter->num_mappings] & 0x1); JIT_ASSERT(!(jitter->mappings[jitter->num_mappings] & 0x2)); v = jitter->mappings[jitter->num_mappings] >> 2; - v--; + v -= n; + JIT_ASSERT(v >= 0); if (!v) --jitter->num_mappings; else jitter->mappings[jitter->num_mappings] = ((v << 2) | 0x1); +} + +void scheme_mz_popr_p_it(mz_jit_state *jitter, int reg, int discard) +/* de-sync's rs */ +{ + scheme_extra_popped(jitter, 1); if (!discard) mz_rs_ldr(reg); @@ -546,6 +560,7 @@ void scheme_mz_runstack_skipped(mz_jit_state *jitter, int n) int v; if (!n) return; + if (PAST_LIMIT()) return; if (!(jitter->mappings[jitter->num_mappings] & 0x1) || (jitter->mappings[jitter->num_mappings] & 0x2) @@ -564,6 +579,7 @@ void scheme_mz_runstack_unskipped(mz_jit_state *jitter, int n) int v; if (!n) return; + if (PAST_LIMIT()) return; JIT_ASSERT(jitter->mappings[jitter->num_mappings] & 0x1); JIT_ASSERT(!(jitter->mappings[jitter->num_mappings] & 0x2)); @@ -620,6 +636,9 @@ void scheme_mz_runstack_flonum_pushed(mz_jit_state *jitter, int pos) void scheme_mz_runstack_popped(mz_jit_state *jitter, int n) { int v; + + if (PAST_LIMIT()) return; + jitter->depth -= n; jitter->self_pos -= n; diff --git a/racket/src/racket/src/letrec_check.c b/racket/src/racket/src/letrec_check.c index 328b2aa1dd..e705bed2c8 100644 --- a/racket/src/racket/src/letrec_check.c +++ b/racket/src/racket/src/letrec_check.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public diff --git a/racket/src/racket/src/lightning/arm/core.h b/racket/src/racket/src/lightning/arm/core.h index af5e793796..c6783cac6e 100644 --- a/racket/src/racket/src/lightning/arm/core.h +++ b/racket/src/racket/src/lightning/arm/core.h @@ -1329,6 +1329,7 @@ arm_branch(jit_state_t _jitp, int cc, jit_insn *i0) _CC_B(cc, d & 0x00ffffff); } else { int im = (int)i0; + jit_assert(_jitl.long_jumps); if (jit_armv6t_p()) { _CC_MOVWI(cc, JIT_TMP, _jit_US(im)); _CC_MOVTI(cc, JIT_TMP, _jit_US((unsigned)im >> 16)); diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index d253e78449..d12fa9424d 100644 --- a/racket/src/racket/src/list.c +++ b/racket/src/racket/src/list.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -2944,7 +2944,7 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, i { Scheme_Chaperone *px; Scheme_Object *val = argv[0]; - Scheme_Object *redirects, *clear; + Scheme_Object *redirects, *clear, *equal_key_wrap; Scheme_Hash_Tree *props; int start_props = 5; @@ -2967,15 +2967,23 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, i } else clear = scheme_false; + if ((argc > 6) && (SCHEME_FALSEP(argv[6]) || SCHEME_PROCP(argv[6]))) { + scheme_check_proc_arity2(name, 2, 6, argc, argv, 1); /* clear */ + equal_key_wrap = argv[6]; + start_props++; + } else + equal_key_wrap = scheme_false; + /* The allocation of this vector is used to detect when two chaperoned immutable hash tables can be `{chaperone,impersonator}-of?` when they're not eq. */ - redirects = scheme_make_vector(5, NULL); + redirects = scheme_make_vector(6, NULL); SCHEME_VEC_ELS(redirects)[0] = argv[1]; SCHEME_VEC_ELS(redirects)[1] = argv[2]; SCHEME_VEC_ELS(redirects)[2] = argv[3]; SCHEME_VEC_ELS(redirects)[3] = argv[4]; SCHEME_VEC_ELS(redirects)[4] = clear; + SCHEME_VEC_ELS(redirects)[5] = equal_key_wrap; redirects = scheme_box(redirects); /* so it doesn't look like a struct chaperone */ props = scheme_parse_chaperone_props(name, start_props, argc, argv); @@ -3019,7 +3027,7 @@ static Scheme_Object *transfer_chaperone(Scheme_Object *chaperone, Scheme_Object } static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k, - Scheme_Object *v, int mode); + Scheme_Object *v, int mode, Scheme_Object *key_wraps); static Scheme_Object *chaperone_hash_op_k(void) { @@ -3028,13 +3036,15 @@ static Scheme_Object *chaperone_hash_op_k(void) Scheme_Object *k = (Scheme_Object *)p->ku.k.p2; Scheme_Object *v = (Scheme_Object *)p->ku.k.p3; const char *who = (const char *)p->ku.k.p4; + Scheme_Object *key_wraps = (Scheme_Object *)p->ku.k.p5; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; p->ku.k.p4 = NULL; + p->ku.k.p5 = NULL; - o = chaperone_hash_op(who, o, k, v, p->ku.k.i1); + o = chaperone_hash_op(who, o, k, v, p->ku.k.i1, key_wraps); if (!o) return scheme_false; @@ -3043,7 +3053,7 @@ static Scheme_Object *chaperone_hash_op_k(void) } static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object *o, Scheme_Object *k, - Scheme_Object *v, int mode) + Scheme_Object *v, int mode, Scheme_Object *key_wraps) { Scheme_Thread *p = scheme_current_thread; @@ -3052,6 +3062,7 @@ static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object p->ku.k.p3 = (void *)v; p->ku.k.p4 = (void *)who; p->ku.k.i1 = mode; + p->ku.k.p5 = (void *)key_wraps; o = scheme_handle_stack_overflow(chaperone_hash_op_k); @@ -3062,26 +3073,30 @@ static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object } static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k, - Scheme_Object *v, int mode) + Scheme_Object *v, int mode, Scheme_Object *key_wraps) { Scheme_Object *wraps = NULL; while (1) { if (!SCHEME_NP_CHAPERONEP(o)) { + if (SCHEME_NULLP(key_wraps)) + key_wraps = NULL; + else + key_wraps = scheme_make_raw_pair((Scheme_Object *)who, key_wraps); if (mode == 0) { /* hash-ref */ if (SCHEME_HASHTP(o)) - return scheme_hash_get((Scheme_Hash_Table *)o, k); + return scheme_hash_get_w_key_wraps((Scheme_Hash_Table *)o, k, key_wraps); else if (SCHEME_HASHTRP(o)) - return scheme_hash_tree_get((Scheme_Hash_Tree *)o, k); + return scheme_hash_tree_get_w_key_wraps((Scheme_Hash_Tree *)o, k, key_wraps); else - return scheme_lookup_in_table((Scheme_Bucket_Table *)o, (const char *)k); + return scheme_lookup_in_table_w_key_wraps((Scheme_Bucket_Table *)o, (const char *)k, key_wraps); } else if ((mode == 1) || (mode == 2)) { /* hash-set! or hash-remove! */ if (SCHEME_HASHTP(o)) - scheme_hash_set((Scheme_Hash_Table *)o, k, v); + scheme_hash_set_w_key_wraps((Scheme_Hash_Table *)o, k, v, key_wraps); else if (SCHEME_HASHTRP(o)) { - o = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)o, k, v); + o = (Scheme_Object *)scheme_hash_tree_set_w_key_wraps((Scheme_Hash_Tree *)o, k, v, key_wraps); while (wraps) { o = transfer_chaperone(SCHEME_CAR(wraps), o); wraps = SCHEME_CDR(wraps); @@ -3089,13 +3104,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem return o; } else if (!v) { Scheme_Bucket *b; - b = scheme_bucket_or_null_from_table((Scheme_Bucket_Table *)o, (char *)k, 0); + b = scheme_bucket_or_null_from_table_w_key_wraps((Scheme_Bucket_Table *)o, (char *)k, 0, key_wraps); if (b) { HT_EXTRACT_WEAK(b->key) = NULL; b->val = NULL; } } else - scheme_add_to_table((Scheme_Bucket_Table *)o, (const char *)k, v, 0); + scheme_add_to_table_w_key_wraps((Scheme_Bucket_Table *)o, (const char *)k, v, 0, key_wraps); return scheme_void; } else if (mode == 3) return k; @@ -3119,14 +3134,21 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem #ifdef DO_STACK_CHECK { # include "mzstkchk.h" - return chaperone_hash_op_overflow(who, o, k, v, mode); + return chaperone_hash_op_overflow(who, o, k, v, mode, key_wraps); } #endif + if ((mode != 3) && (mode != 4)) { + red = SCHEME_BOX_VAL(px->redirects); + red = SCHEME_VEC_ELS(red)[5]; + if (!SCHEME_FALSEP(red)) + key_wraps = scheme_make_pair((Scheme_Object *)px, key_wraps); + } + if (mode == 0) orig = NULL; else if (mode == 3) { - orig = chaperone_hash_op(who, px->prev, k, v, mode); + orig = chaperone_hash_op(who, px->prev, k, v, mode, key_wraps); k = orig; } else if (mode == 2) orig = k; @@ -3196,7 +3218,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem who, red); - orig = chaperone_hash_op(who, px->prev, k, v, mode); + orig = chaperone_hash_op(who, px->prev, k, v, mode, key_wraps); if (!orig) return NULL; /* hash-ref */ @@ -3240,27 +3262,27 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem Scheme_Object *scheme_chaperone_hash_get(Scheme_Object *table, Scheme_Object *key) { - return chaperone_hash_op("hash-ref", table, key, NULL, 0); + return chaperone_hash_op("hash-ref", table, key, NULL, 0, scheme_null); } void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val) { - (void)chaperone_hash_op(val ? "hash-set!" : "hash-remove!", table, key, val, val ? 1 : 2); + (void)chaperone_hash_op(val ? "hash-set!" : "hash-remove!", table, key, val, val ? 1 : 2, scheme_null); } Scheme_Object *chaperone_hash_tree_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val) { - return chaperone_hash_op(val ? "hash-set" : "hash-remove", table, key, val, val ? 1 : 2); + return chaperone_hash_op(val ? "hash-set" : "hash-remove", table, key, val, val ? 1 : 2, scheme_null); } static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key) { - return chaperone_hash_op(name, table, key, NULL, 3); + return chaperone_hash_op(name, table, key, NULL, 3, scheme_null); } static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table) { - return chaperone_hash_op(name, table, NULL, NULL, 4); + return chaperone_hash_op(name, table, NULL, NULL, 4, scheme_null); } Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_Object *key, @@ -3268,7 +3290,7 @@ Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_ { key = chaperone_hash_key("hash-table-iterate-key", table, key); *alt_key = key; - return chaperone_hash_op("hash-ref", table, key, NULL, 0); + return chaperone_hash_op("hash-ref", table, key, NULL, 0, scheme_null); } Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj) diff --git a/racket/src/racket/src/marshal.c b/racket/src/racket/src/marshal.c index b64b84866d..f3041afe1d 100644 --- a/racket/src/racket/src/marshal.c +++ b/racket/src/racket/src/marshal.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -94,6 +94,7 @@ static Scheme_Object *read_top_level_require(Scheme_Object *obj); static Scheme_Object *write_top_level_require(Scheme_Object *obj); static Scheme_Object *ht_to_vector(Scheme_Object *ht, int delay); +static Scheme_Object *closure_marshal_name(Scheme_Object *name); void scheme_init_marshal(Scheme_Env *env) { @@ -365,7 +366,7 @@ static Scheme_Object *write_case_lambda(Scheme_Object *obj) l = cons(cl->array[i], l); } - return cons((cl->name ? cl->name : scheme_null), + return cons(closure_marshal_name(cl->name), l); } @@ -462,7 +463,7 @@ static Scheme_Object *read_begin_for_syntax(Scheme_Object *obj) static Scheme_Object *write_begin_for_syntax(Scheme_Object *obj) { - return write_define_values(obj); + return scheme_clone_vector(obj, 0, 0); } static Scheme_Object *read_set_bang(Scheme_Object *obj) @@ -759,17 +760,9 @@ static int not_relative_path(Scheme_Object *p, Scheme_Hash_Table *cache) return 0; } -static Scheme_Object *write_compiled_closure(Scheme_Object *obj) +static Scheme_Object *closure_marshal_name(Scheme_Object *name) { - Scheme_Closure_Data *data; - Scheme_Object *name, *l, *code, *ds, *tl_map; - int svec_size, pos; - Scheme_Marshal_Tables *mt; - - data = (Scheme_Closure_Data *)obj; - - if (data->name) { - name = data->name; + if (name) { if (SCHEME_VECTORP(name)) { /* We can only save marshalable src names, which includes paths, symbols, and strings: */ @@ -786,13 +779,26 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj) name = SCHEME_VEC_ELS(name)[0]; } } - } else { + } else name = scheme_null; - } + + return name; +} + +static Scheme_Object *write_compiled_closure(Scheme_Object *obj) +{ + Scheme_Closure_Data *data; + Scheme_Object *name, *l, *code, *ds, *tl_map; + int svec_size, pos; + Scheme_Marshal_Tables *mt; + + data = (Scheme_Closure_Data *)obj; + + name = closure_marshal_name(data->name); svec_size = data->closure_size; if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { - svec_size += boxmap_size(data->num_params + data->closure_size); + svec_size += scheme_boxmap_size(data->num_params + data->closure_size); { int k, mv; for (k = data->num_params + data->closure_size; --k; ) { @@ -1016,7 +1022,7 @@ static Scheme_Object *read_compiled_closure(Scheme_Object *obj) data->closure_size = SCHEME_SVEC_LEN(v); if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS)) - if (data->closure_size + boxmap_size(data->closure_size + data->num_params) != SCHEME_SVEC_LEN(v)) + if (data->closure_size + scheme_boxmap_size(data->closure_size + data->num_params) != SCHEME_SVEC_LEN(v)) return NULL; data->closure_map = SCHEME_SVEC_VEC(v); diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 1e9baef4f3..18ea5061a9 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -125,6 +125,7 @@ typedef struct Module_Begin_Expand_State { Scheme_Hash_Table *modidx_cache; Scheme_Object *redef_modname; Scheme_Object *end_statementss; /* list of lists */ + Scheme_Object *modsrc; /* source for top-level module */ } Module_Begin_Expand_State; static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, @@ -1128,8 +1129,6 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], base_phase = env->phase; - scheme_prepare_compile_env(env); - m = module_load(modname, env, errname); srcm = m; @@ -3717,7 +3716,7 @@ static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]) "second argument", 1, argv[1], "third argument", 1, argv[2], NULL); - return scheme_get_submodule_empty_self_modidx(argv[2]); + return scheme_get_submodule_empty_self_modidx(argv[2], 0); } } @@ -4025,31 +4024,49 @@ static Scheme_Object *resolved_module_path_to_modidx(Scheme_Object *rmp) return scheme_make_modidx(path, scheme_false, rmp); } -Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path) +Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path, int can_cache) { Scheme_Bucket *b; + Scheme_Object *modidx; - if (SCHEME_NULLP(submodule_path)) - return empty_self_modidx; + if (SCHEME_NULLP(submodule_path)) { + if (can_cache) + return empty_self_modidx; + return scheme_make_modidx(scheme_false, scheme_false, empty_self_modname); + } if (!submodule_empty_modidx_table) { REGISTER_SO(submodule_empty_modidx_table); submodule_empty_modidx_table = scheme_make_weak_equal_table(); } - scheme_start_atomic(); - b = scheme_bucket_from_table(submodule_empty_modidx_table, (const char *)submodule_path); - if (!b->val) { - submodule_path = make_resolved_module_path_obj(scheme_make_pair(scheme_resolved_module_path_value(empty_self_modname), - submodule_path)); - submodule_path = scheme_make_modidx(scheme_false, - scheme_false, - submodule_path); - b->val = submodule_path; + if (can_cache) { + scheme_start_atomic(); + b = scheme_bucket_from_table(submodule_empty_modidx_table, (const char *)submodule_path); + if (b->val) + modidx = scheme_ephemeron_value(b->val); + else + modidx = NULL; + } else { + b = NULL; + modidx = NULL; } - scheme_end_atomic_no_swap(); - return b->val; + if (!modidx) { + modidx = make_resolved_module_path_obj(scheme_make_pair(scheme_resolved_module_path_value(empty_self_modname), + submodule_path)); + modidx = scheme_make_modidx(scheme_false, scheme_false, modidx); + if (b) { + modidx = scheme_make_ephemeron(submodule_path, modidx); + b->val = modidx; + modidx = scheme_ephemeron_value(modidx); + } + } + + if (can_cache) + scheme_end_atomic_no_swap(); + + return modidx; } static Scheme_Object *_module_resolve_k(void); @@ -4933,9 +4950,11 @@ static void lock_registry(Scheme_Env *env) static void unlock_registry(Scheme_Env *env) { Scheme_Object *lock; - lock = scheme_hash_get(env->module_registry->loaded, scheme_false); - scheme_post_sema(SCHEME_CAR(lock)); - scheme_hash_set(env->module_registry->loaded, scheme_false, NULL); + if (env) { + lock = scheme_hash_get(env->module_registry->loaded, scheme_false); + scheme_post_sema(SCHEME_CAR(lock)); + scheme_hash_set(env->module_registry->loaded, scheme_false, NULL); + } } XFORM_NONGCING static intptr_t make_key(int base_phase, int eval_exp, int eval_run) @@ -5743,7 +5762,7 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) { Scheme_Object *v, *prev; - Scheme_Env *menv; + Scheme_Env *menv, *uenv; int need_lock; need_lock = wait_registry(env); @@ -5764,14 +5783,17 @@ static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) } v = prev; - if (need_lock) + if (need_lock) { lock_registry(env); + uenv = env; + } else + uenv = NULL; while (SCHEME_NAMESPACEP(v)) { menv = (Scheme_Env *)v; v = menv->available_next[pos]; menv->available_next[pos] = NULL; - BEGIN_ESCAPEABLE(unlock_registry, env); + BEGIN_ESCAPEABLE(unlock_registry, uenv); start_module(menv->module, menv->instance_env, 0, NULL, 1, 0, base_phase, scheme_null, 1); @@ -7096,7 +7118,10 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, rmp = SCHEME_STX_VAL(nm); rmp = scheme_intern_resolved_module_path(rmp); m->modname = rmp; - m->modsrc = rmp; + if (super_bxs) + m->modsrc = super_bxs->modsrc; + else + m->modsrc = rmp; if (!SCHEME_NULLP(submodule_ancestry)) submodule_path = scheme_append(submodule_path, scheme_make_pair(SCHEME_STX_VAL(nm), scheme_null)); @@ -7318,7 +7343,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp)); - this_empty_self_modidx = scheme_get_submodule_empty_self_modidx(submodule_path); + this_empty_self_modidx = scheme_get_submodule_empty_self_modidx(submodule_path, 1); /* phase shift to replace self_modidx of previous expansion: */ fm = scheme_stx_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, @@ -7408,8 +7433,14 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, cons(fm, scheme_null)))); fm = scheme_datum_to_syntax(fm, form, ctx_form, 0, 2); + + /* for future expansion, shift away from self_modidx: */ + ps = scheme_make_shift(NULL, self_modidx, this_empty_self_modidx, NULL, NULL, NULL); + fm = scheme_stx_add_shift(fm, ps); if (hints) { + Scheme_Object *stx, *l; + fm = scheme_stx_property(fm, scheme_intern_symbol("module-direct-requires"), m->requires); @@ -7419,6 +7450,24 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, fm = scheme_stx_property(fm, scheme_intern_symbol("module-direct-for-template-requires"), m->tt_requires); + + l = scheme_null; + if (!SCHEME_NULLP(m->dt_requires)) + l = scheme_make_pair(scheme_make_pair(scheme_false, m->dt_requires), + l); + if (m->other_requires) { + int i; + for (i = 0; i < m->other_requires->size; i++) { + if (m->other_requires->vals[i]) { + l = scheme_make_pair(scheme_make_pair(m->other_requires->keys[i], + m->other_requires->vals[i]), + l); + } + } + } + fm = scheme_stx_property(fm, + scheme_intern_symbol("module-direct-for-meta-requires"), + l); fm = scheme_stx_property(fm, scheme_intern_symbol("module-variable-provides"), @@ -7438,11 +7487,25 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, fm = scheme_stx_property(fm, scheme_intern_symbol("module-self-path-index"), this_empty_self_modidx); - } - /* for future expansion, shift away from self_modidx: */ - ps = scheme_make_shift(NULL, self_modidx, this_empty_self_modidx, NULL, NULL, NULL); - fm = scheme_stx_add_shift(fm, ps); + fm = scheme_stx_property(fm, + scheme_intern_symbol("module-body-context-simple?"), + (SAME_OBJ(scheme_true, m->rn_stx) + ? scheme_true + : scheme_false)); + + stx = scheme_datum_to_syntax(scheme_intern_symbol("inside"), scheme_false, scheme_false, 0, 0); + stx = scheme_stx_add_module_context(stx, rn_set); + fm = scheme_stx_property(fm, + scheme_intern_symbol("module-body-context"), + scheme_stx_add_shift(stx, ps)); + + stx = scheme_datum_to_syntax(scheme_intern_symbol("outside"), scheme_false, scheme_false, 0, 0); + stx = scheme_stx_introduce_to_module_context(stx, rn_set); + fm = scheme_stx_property(fm, + scheme_intern_symbol("module-body-inside-context"), + scheme_stx_add_shift(stx, ps)); + } /* make self_modidx like the empty modidx */ if (SAME_OBJ(this_empty_self_modidx, empty_self_modidx)) @@ -7670,7 +7733,10 @@ static void check_require_name(Scheme_Object *id, Scheme_Object *self_modidx, && prep_required_id(vec) && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, phase)) { /* can override; first, remove old binding mapping: */ - scheme_hash_set(required, binding, NULL); + if (SCHEME_SYMBOLP(binding)) + scheme_hash_set(required, binding, scheme_false); + else + scheme_hash_set(required, binding, NULL); /* construct overriding `binding`: */ binding = scheme_make_vector(4, NULL); vec = scheme_module_resolve(modidx, 0); @@ -7971,17 +8037,17 @@ static Scheme_Object *shift_require_phase(Scheme_Object *e, Scheme_Object *phase Scheme_Object *l, *a; l = e; - if (SCHEME_STXP(l)) l = SCHEME_STX_VAL(l); + if (SCHEME_STXP(l)) l = scheme_stx_content(l); if (SCHEME_PAIRP(l)) { a = SCHEME_CAR(l); - if (SCHEME_STXP(a)) a = SCHEME_STX_VAL(a); + if (SCHEME_STXP(a)) a = scheme_stx_content(a); if (can_just_meta && SAME_OBJ(a, just_meta_symbol)) { /* Shift any `for-meta` within `just-meta`: */ l = SCHEME_CDR(l); if (scheme_proper_list_length(l) >= 1) { a = SCHEME_CAR(l); - if (SCHEME_STXP(a)) a = SCHEME_STX_VAL(a); + if (SCHEME_STXP(a)) a = scheme_stx_content(a); if (SCHEME_FALSEP(a) || SCHEME_INTP(a) || SCHEME_BIGNUMP(a)) { e = scheme_null; for (l = SCHEME_CDR(l); SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { @@ -7999,7 +8065,7 @@ static Scheme_Object *shift_require_phase(Scheme_Object *e, Scheme_Object *phase l = SCHEME_CDR(l); if (SCHEME_PAIRP(l)) { a = SCHEME_CAR(l); - if (SCHEME_STXP(a)) a = SCHEME_STX_VAL(a); + if (SCHEME_STXP(a)) a = scheme_stx_content(a); if (SCHEME_FALSEP(a)) { return e; } else if (SCHEME_INTP(a) || SCHEME_BIGNUMP(a)) { @@ -8220,6 +8286,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env bxs->modidx_cache = modidx_cache; bxs->redef_modname = redef_modname; bxs->end_statementss = scheme_null; + bxs->modsrc = env->genv->module->modsrc; if (env->genv->module->super_bxs_info) { /* initialize imports that are available for export from the enclosing module's @@ -8354,7 +8421,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env result = scheme_null; - /* kernel re-export info (always #f): */ + /* kernel re-export info (now always #f): */ result = scheme_make_pair(scheme_false, result); /* Indirect provides */ @@ -8438,6 +8505,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env add_binding_names_from_environment(env->genv->module, bnenv); } } + } else { + /* For a property on the expanded module: */ + if (*all_simple_bindings && env->genv->module->rn_stx) { + /* We will be able to reconstruct binding for `module->namespace`: */ + env->genv->module->rn_stx = scheme_true; + } } if (rec[drec].comp || has_submodules) { @@ -8744,7 +8817,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ return fm; } #endif - + if (*bxs->_num_phases < phase + 1) *bxs->_num_phases = phase + 1; @@ -9334,6 +9407,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ /************ module[*] *************/ /* check outer syntax & name, then expand pre-module or remember for post-module pass */ int k; + e = handle_submodule_form(who, e, env, phase, rn_set, observer, @@ -10366,39 +10440,28 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv, { int i, count, j, start, end; Scheme_Bucket **bs, *b; - Scheme_Object **exsns = pt->provide_src_names, **exis; + Scheme_Object **exsns = pt->provide_src_names, **exss = pt->provide_srcs, **exis; int exicount; Scheme_Bucket_Table *t; if (vars) { start = 0; end = pt->num_provides; /* check both vars & syntax, in case of rename transformer */ + t = genv->toplevel; } else { start = pt->num_var_provides; end = pt->num_provides; - } - - if (vars) - t = genv->toplevel; - else t = genv->syntax; - - - if (!t) - count = 0; - else { - bs = t->buckets; - for (count = 0, i = t->size; i--; ) { - b = bs[i]; - if (b && b->val) - count++; - } } + count = (t ? t->count : 0); + if (!count) { *_count = 0; return NULL; } + + bs = t->buckets; exis = MALLOC_N(Scheme_Object *, count); @@ -10411,7 +10474,8 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv, /* If the name is directly provided, no need for indirect... */ for (j = start; j < end; j++) { - if (SAME_OBJ(name, exsns[j])) + if (SAME_OBJ(name, exsns[j]) + && SCHEME_FALSEP(exss[j])) break; } diff --git a/racket/src/racket/src/mzclpf_post.inc b/racket/src/racket/src/mzclpf_post.inc index 2bfd7f7182..9b47dc1f48 100644 --- a/racket/src/racket/src/mzclpf_post.inc +++ b/racket/src/racket/src/mzclpf_post.inc @@ -27,7 +27,8 @@ /* We're the first to look at this prefix... */ /* Add it to the chain of prefixes to finish after all other marking: */ - if (gc_mode == GC_CURRENT_MODE_INCREMENTAL) { + if ((gc_mode == GC_CURRENT_MODE_INCREMENTAL) + || (gc_mode == GC_CURRENT_MODE_INCREMENTAL_FINAL)) { pf->next_final = scheme_inc_prefix_finalize; scheme_inc_prefix_finalize = pf; } else { @@ -41,56 +42,56 @@ mark_stxes = 0; /* Add this closure to the chain to be repaired when the - prefix is marked (and potentially moved): */ - if ((gc_mode == GC_CURRENT_MODE_INCREMENTAL) || (SCHEME_PREFIX_FLAGS(pf) & 0x1)) { - /* Can't steal closure slot for this purpose, since the - slot is still in use until a full collection finishes */ - Scheme_Object **pr; - pr = (Scheme_Object **)GC_malloc_for_incremental(2 * sizeof(Scheme_Object *)); - pr[0] = (Scheme_Object *)c; - pr[1] = (Scheme_Object *)pf->fixup_chain; - pf->fixup_chain = (Scheme_Object *)pr; - SCHEME_PREFIX_FLAGS(pf) |= 0x1; - } else { + prefix is marked and potentially moved; if we're here + in incremental mode, though, the prefix won't be moved: */ + if (gc_mode != GC_CURRENT_MODE_INCREMENTAL) { c->vals[closure_size - 1] = pf->fixup_chain; pf->fixup_chain = (Scheme_Object *)c; + } else { + /* Mark the prefix as reached in incremental mode, which + triggers special handling for backpointers */ + SCHEME_PREFIX_FLAGS(pf) |= 0x1; } /* Mark just the elements of the prefix that are (newly) used: */ if ((uintptr_t)data->tl_map & 0x1) { - map = ((uintptr_t)data->tl_map) >> 1; - for (i = 0; i < 31; i++) { - if (map & (1 << i)) { - if (!(use_bits[0] & (1 << i))) { - if ((i < pf->num_toplevels) || !pf->num_stxes) - gcMARK2(pf->a[i], gc); /* top level */ - else if (i == pf->num_toplevels) - mark_stxes = 1; /* any syntax object */ - else - gcMARK2(pf->a[i + pf->num_stxes], gc); /* lifted */ + map = (((uintptr_t)data->tl_map) >> 1) & 0x7FFFFFFF; + if ((use_bits[0] & map) != map) { + for (i = 0; i < 31; i++) { + if (map & (1 << i)) { + if (!(use_bits[0] & (1 << i))) { + if ((i < pf->num_toplevels) || !pf->num_stxes) + gcMARK2(pf->a[i], gc); /* top level */ + else if (i == pf->num_toplevels) + mark_stxes = 1; /* any syntax object */ + else + gcMARK2(pf->a[i + pf->num_stxes], gc); /* lifted */ + } } } + use_bits[0] |= map; } - use_bits[0] |= (map & 0x7FFFFFFF); } else { int *u = (int *)GC_resolve2(data->tl_map, gc), j, pos; for (i = u[0]; i--; ) { map = u[i+1]; - for (j = 0; j < 32; j++) { - if (map & (1 << j)) { - if (!(use_bits[i] & (1 << j))) { - pos = (i * 32) + j; - if ((pos < pf->num_toplevels) || !pf->num_stxes) - gcMARK2(pf->a[pos], gc); /* top level */ - else if (pos == pf->num_toplevels) - mark_stxes = 1; /* any syntax object */ - else - gcMARK2(pf->a[pos + pf->num_stxes], gc); /* lifted */ + if ((use_bits[i] & map) != map) { + for (j = 0; j < 32; j++) { + if (map & (1 << j)) { + if (!(use_bits[i] & (1 << j))) { + pos = (i * 32) + j; + if ((pos < pf->num_toplevels) || !pf->num_stxes) + gcMARK2(pf->a[pos], gc); /* top level */ + else if (pos == pf->num_toplevels) + mark_stxes = 1; /* any syntax object */ + else + gcMARK2(pf->a[pos + pf->num_stxes], gc); /* lifted */ + } } } + use_bits[i] |= map; } - use_bits[i] |= map; } } if (mark_stxes) { diff --git a/racket/src/racket/src/mzmark_jit.inc b/racket/src/racket/src/mzmark_jit.inc index a6cbabd86d..aeb5be06da 100644 --- a/racket/src/racket/src/mzmark_jit.inc +++ b/racket/src/racket/src/mzmark_jit.inc @@ -158,6 +158,7 @@ static int native_unclosed_proc_MARK(void *p, struct NewGC *gc) { gcMARK2(d->u.arities, gc); } gcMARK2(d->tl_map, gc); + gcMARK2(d->eq_key, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; @@ -183,6 +184,7 @@ static int native_unclosed_proc_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(d->u.arities, gc); } gcFIXUP2(d->tl_map, gc); + gcFIXUP2(d->eq_key, gc); # ifdef GC_NO_SIZE_NEEDED_FROM_PROCS return 0; diff --git a/racket/src/racket/src/mzmark_read.inc b/racket/src/racket/src/mzmark_read.inc index 541c04d991..8539f2ccf0 100644 --- a/racket/src/racket/src/mzmark_read.inc +++ b/racket/src/racket/src/mzmark_read.inc @@ -50,6 +50,7 @@ static int mark_cport_MARK(void *p, struct NewGC *gc) { gcMARK2(cp->ht, gc); gcMARK2(cp->ut, gc); gcMARK2(cp->symtab, gc); + gcMARK2(cp->symtab_entries, gc); gcMARK2(cp->relto, gc); gcMARK2(cp->magic_sym, gc); gcMARK2(cp->magic_val, gc); @@ -73,6 +74,7 @@ static int mark_cport_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(cp->ht, gc); gcFIXUP2(cp->ut, gc); gcFIXUP2(cp->symtab, gc); + gcFIXUP2(cp->symtab_entries, gc); gcFIXUP2(cp->relto, gc); gcFIXUP2(cp->magic_sym, gc); gcFIXUP2(cp->magic_val, gc); @@ -195,6 +197,7 @@ static int mark_delay_load_MARK(void *p, struct NewGC *gc) { Scheme_Load_Delay *ld = (Scheme_Load_Delay *)p; gcMARK2(ld->path, gc); gcMARK2(ld->symtab, gc); + gcMARK2(ld->symtab_entries, gc); gcMARK2(ld->shared_offsets, gc); gcMARK2(ld->relto, gc); gcMARK2(ld->ut, gc); @@ -215,6 +218,7 @@ static int mark_delay_load_FIXUP(void *p, struct NewGC *gc) { Scheme_Load_Delay *ld = (Scheme_Load_Delay *)p; gcFIXUP2(ld->path, gc); gcFIXUP2(ld->symtab, gc); + gcFIXUP2(ld->symtab_entries, gc); gcFIXUP2(ld->shared_offsets, gc); gcFIXUP2(ld->relto, gc); gcFIXUP2(ld->ut, gc); diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index 96d438a8df..efe40de46c 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/racket/src/racket/src/mzmarksrc.c @@ -2274,6 +2274,7 @@ mark_cport { gcMARK2(cp->ht, gc); gcMARK2(cp->ut, gc); gcMARK2(cp->symtab, gc); + gcMARK2(cp->symtab_entries, gc); gcMARK2(cp->relto, gc); gcMARK2(cp->magic_sym, gc); gcMARK2(cp->magic_val, gc); @@ -2312,6 +2313,7 @@ mark_delay_load { Scheme_Load_Delay *ld = (Scheme_Load_Delay *)p; gcMARK2(ld->path, gc); gcMARK2(ld->symtab, gc); + gcMARK2(ld->symtab_entries, gc); gcMARK2(ld->shared_offsets, gc); gcMARK2(ld->relto, gc); gcMARK2(ld->ut, gc); @@ -2511,6 +2513,7 @@ native_unclosed_proc { gcMARK2(d->u.arities, gc); } gcMARK2(d->tl_map, gc); + gcMARK2(d->eq_key, gc); size: gcBYTES_TO_WORDS(sizeof(Scheme_Native_Closure_Data)); diff --git a/racket/src/racket/src/mzrt.c b/racket/src/racket/src/mzrt.c index bdaa9dc143..21c8441902 100644 --- a/racket/src/racket/src/mzrt.c +++ b/racket/src/racket/src/mzrt.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2009-2015 PLT Design Inc. + Copyright (c) 2009-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public diff --git a/racket/src/racket/src/mzsj86.c b/racket/src/racket/src/mzsj86.c index 3ceb734c72..d76e61e4df 100644 --- a/racket/src/racket/src/mzsj86.c +++ b/racket/src/racket/src/mzsj86.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/network.c b/racket/src/racket/src/network.c index 10af061f5b..3e5d938121 100644 --- a/racket/src/racket/src/network.c +++ b/racket/src/racket/src/network.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -398,6 +398,12 @@ SHARED_OK static struct protoent *proto; /* mz_addrinfo is defined in scheme.h */ +#if defined(__MINGW32__) && !defined(HAVE_GETADDRINFO) +/* Although `configure` didn't discover it, we do have getaddrinfo() + from Winsock */ +# define HAVE_GETADDRINFO +#endif + #ifdef HAVE_GETADDRINFO # define mzAI_PASSIVE AI_PASSIVE # define mz_getaddrinfo getaddrinfo @@ -411,24 +417,6 @@ static int mz_getaddrinfo(const char *nodename, const char *servname, { struct hostent *h; -#ifdef __MINGW32__ - { - HMODULE hm; - hm = LoadLibrary("ws2_32.dll"); - if (hm) { - gai_t gai; - gai = (gai_t)GetProcAddress(hm, "getaddrinfo"); - if (gai) { - int v; - v = gai(nodename, servname, hints, res); - if (!v && !(*res)->ai_addr) - (*res)->ai_addrlen = 0; - return v; - } - } - } -#endif - if (nodename) h = gethostbyname(nodename); else @@ -471,32 +459,13 @@ static int mz_getaddrinfo(const char *nodename, const char *servname, void mz_freeaddrinfo(struct mz_addrinfo *ai) XFORM_SKIP_PROC { -#ifdef __MINGW32__ - { - HMODULE hm; - hm = LoadLibrary("ws2_32.dll"); - if (hm) { - fai_t fai; - fai = (fai_t)GetProcAddress(hm, "freeaddrinfo"); - if (fai) { - fai(ai); - return; - } - } - } -#endif - free(ai->ai_addr); free(ai); } const char *mz_gai_strerror(int ecode) XFORM_SKIP_PROC { -#ifdef __MINGW32__ - return NULL; /* => use FormatMessageW(), instead */ -#else return hstrerror(ecode); -#endif } #endif diff --git a/racket/src/racket/src/numarith.c b/racket/src/racket/src/numarith.c index 315d6a4034..36030db974 100644 --- a/racket/src/racket/src/numarith.c +++ b/racket/src/racket/src/numarith.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/number.c b/racket/src/racket/src/number.c index 16b4eeee5d..62e6321ef9 100644 --- a/racket/src/racket/src/number.c +++ b/racket/src/racket/src/number.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -3617,18 +3617,42 @@ scheme_expt(int argc, Scheme_Object *argv[]) } } } - } else if ((d < 0.0) && (d > -1.0)) { + } else if (SCHEME_BIGNUMP(e) && SCHEME_BIGPOS(e)) { /* If `e` is a positive bignum, then the result should be zero, but we won't get that result if conversion produces infinity */ - if (SCHEME_BIGNUMP(e) && SCHEME_BIGPOS(e)) { + double e_dbl; #ifdef MZ_USE_SINGLE_FLOATS - int sgl = !SCHEME_DBLP(n); + int sgl = !SCHEME_DBLP(n); #endif + if ((d < 0.0) && (d > -1.0)) { if (SCHEME_FALSEP(scheme_odd_p(1, &e))) return SELECT_EXPT_PRECISION(scheme_zerof, scheme_zerod); else return SELECT_EXPT_PRECISION(scheme_nzerof, scheme_nzerod); } + /* If d is negative, and `e` is a large enough bignum which would + be converted to infinity, this would return a complex NaN. + Instead, we want to return (positive of negative) infinity. + See discussion in Github issue 1148. */ +#ifdef MZ_USE_SINGLE_FLOATS + if (sgl) { + /* Need to go through singles to get right overflow behavior. */ + e_dbl = (double)(scheme_bignum_to_float(e)); + } else { + e_dbl = scheme_bignum_to_double(e); + } +#else + e_dbl = scheme_bignum_to_double(e); +#endif + if ((d < 0.0) && MZ_IS_POS_INFINITY(e_dbl)) { + if (SCHEME_TRUEP(scheme_odd_p(1, &e))) { + return SELECT_EXPT_PRECISION(scheme_single_minus_inf_object, + scheme_minus_inf_object); + } else { + return SELECT_EXPT_PRECISION(scheme_single_inf_object, + scheme_inf_object); + } + } } if ((d < 0.0) && SCHEME_RATIONALP(e)) { @@ -3804,6 +3828,21 @@ static Scheme_Object *magnitude(int argc, Scheme_Object *argv[]) a[0] = i; return scheme_exact_to_inexact(1, a); } +#ifdef MZ_USE_SINGLE_FLOATS + if (SCHEME_FLTP(i)) { + float f; + f = SCHEME_FLT_VAL(i); + if (MZ_IS_POS_INFINITY((double) f)) { + if (SCHEME_FLTP(r)) { /* `r` is either a single-precision float or exact 0 */ + f = SCHEME_FLT_VAL(r); + if (MZ_IS_NAN((double) f)) { + return scheme_single_nan_object; + } + return scheme_single_inf_object; + } + } + } +#endif if (SCHEME_FLOATP(i)) { double d; d = SCHEME_FLOAT_VAL(i); diff --git a/racket/src/racket/src/numcomp.c b/racket/src/racket/src/numcomp.c index a3923119c4..1ba5d8594a 100644 --- a/racket/src/racket/src/numcomp.c +++ b/racket/src/racket/src/numcomp.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/nummacs.h b/racket/src/racket/src/nummacs.h index 7109d75d0d..0a5bfa20f7 100644 --- a/racket/src/racket/src/nummacs.h +++ b/racket/src/racket/src/nummacs.h @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/numstr.c b/racket/src/racket/src/numstr.c index 0f4fb210ac..eca6de2817 100644 --- a/racket/src/racket/src/numstr.c +++ b/racket/src/racket/src/numstr.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -386,7 +386,7 @@ END_XFORM_ARITH; static double STRTOD(const char *orig_c, char **f, int extfl) { int neg = 0; - int found_dot = 0, is_infinity = 0, is_zero = 0; + int found_dot = 0, is_infinity = 0, is_zero = 0, is_nonzero = 0; const char *c = orig_c; *f = (char *)c; @@ -410,7 +410,8 @@ static double STRTOD(const char *orig_c, char **f, int extfl) int ch = *c; if (isdigit(ch)) { - /* ok */ + if (ch != '0') + is_nonzero = 1; } else if ((ch == 'e') || (ch == 'E')) { int e = 0, neg_exp = 0; @@ -431,7 +432,7 @@ static double STRTOD(const char *orig_c, char **f, int extfl) else { e = (e * 10) + (ch - '0'); if (e > CHECK_INF_EXP_THRESHOLD(extfl)) { - if (neg_exp) + if (neg_exp || !is_nonzero) is_zero = 1; else is_infinity = 1; @@ -494,13 +495,27 @@ START_XFORM_ARITH; # define STRTOD(x, y, extfl) strtod(x, y) #endif -static Scheme_Object *CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl) +#ifdef MZ_LONG_DOUBLE +# define CHECK_SINGLE(v, s, il, l, str, len, radix) do_CHECK_SINGLE(v, s, il, l, NULL, 0, 0) +#else +# define CHECK_SINGLE(v, s, il, l, str, len, radix) do_CHECK_SINGLE(v, s, il, NULL, str, len, radix) +#endif + +static Scheme_Object *do_CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl, + Scheme_Object *lv, const mzchar *str, intptr_t len, int radix) { if (SCHEME_DBLP(v)) { #ifdef MZ_USE_SINGLE_FLOATS if (s) return scheme_make_float((float)SCHEME_DBL_VAL(v)); #endif + if (long_dbl) { +#ifdef MZ_LONG_DOUBLE + return lv; +#else + return wrap_as_long_double(scheme_utf8_encode_to_buffer(str, len, NULL, 0), radix); +#endif + } } return v; @@ -1392,7 +1407,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else { /* Mantissa is not a fraction. */ mzchar *digits; - int extra_power = 0, dcp = 0, num_ok; + int extra_power = 0, dcp = 0, non_zero = 0, num_ok; digits = (mzchar *)scheme_malloc_atomic((has_expt - delta + 1) * sizeof(mzchar)); @@ -1401,7 +1416,11 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, digits[dcp++] = str[i++]; for (; isAdigit(str[i]) || ((radix > 10) && isbaseNdigit(radix, str[i])); i++) { + if ((radix < 10) && ((str[i] - '0') >= radix)) + break; digits[dcp++] = str[i]; + if (str[i] != '0') + non_zero = 1; } if (str[i] == '#') { @@ -1411,13 +1430,17 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, num_ok = 0; } else num_ok = 1; - + if (str[i] == '.') { i++; if (num_ok) for (; isAdigit(str[i]) || ((radix > 10) && isbaseNdigit(radix, str[i])); i++) { + if ((radix < 10) && ((str[i] - '0') >= radix)) + break; digits[dcp++] = str[i]; extra_power++; + if (str[i] != '0') + non_zero = 1; } for (; str[i] == '#'; i++) { @@ -1444,22 +1467,36 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, return scheme_false; } - /* Reduce unnecessary mantissa-reading work for inexact results. - This is also necessary to make the range check on `exponent' - correct. */ - if (result_is_float && (dcp > MAX_FLOATREAD_PRECISION_DIGITS(is_long_double))) { - extra_power -= (dcp - MAX_FLOATREAD_PRECISION_DIGITS(is_long_double)); - dcp = MAX_FLOATREAD_PRECISION_DIGITS(is_long_double); + /* Zero mantissa => zero inexact result */ + if (!non_zero && result_is_float) { + if (dcp && (digits[0] == '-')) + return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double, scheme_nzerol, str, len, radix); + else + return CHECK_SINGLE(scheme_zerod, sgl, is_long_double, scheme_zerol, str, len, radix); + } + + /* Reduce unnecessary mantissa-reading work for inexact results. */ + if (result_is_float) { + Scheme_Object *max_useful; + + max_useful = scheme_bin_plus(scheme_make_integer(MAX_FLOATREAD_PRECISION_DIGITS(is_long_double)), + exponent); + if (scheme_bin_lt(max_useful, scheme_make_integer(2))) { + /* will definitely underflow */ + if (dcp > 2) + dcp = 2; /* leave room for a sign and a digit */ + } else if (SCHEME_INTP(max_useful)) { + if (result_is_float && (dcp > SCHEME_INT_VAL(max_useful))) { + extra_power -= (dcp - SCHEME_INT_VAL(max_useful)); + dcp = SCHEME_INT_VAL(max_useful); + } + } } digits[dcp] = 0; mantissa = scheme_read_bignum(digits, 0, radix); if (SCHEME_FALSEP(mantissa)) { - /* can get here with bad radix */ - if (report) - scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, - "read: bad number: %u", - str, len); + scheme_signal_error("internal error parsing mantissa: %s", digits); return scheme_false; } @@ -1470,14 +1507,14 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, if (result_is_float) { if (scheme_bin_gt(exponent, scheme_make_integer(CHECK_INF_EXP_THRESHOLD(is_long_double)))) { if (scheme_is_negative(mantissa)) - return CHECK_SINGLE(scheme_minus_inf_object, sgl, is_long_double); + return CHECK_SINGLE(scheme_minus_inf_object, sgl, is_long_double, scheme_long_minus_inf_object, str, len, radix); else - return CHECK_SINGLE(scheme_inf_object, sgl, is_long_double); + return CHECK_SINGLE(scheme_inf_object, sgl, is_long_double, scheme_long_inf_object, str, len, radix); } else if (scheme_bin_lt(exponent, scheme_make_integer(-CHECK_INF_EXP_THRESHOLD(is_long_double)))) { if (scheme_is_negative(mantissa)) - return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double); + return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double, scheme_nzerol, str, len, radix); else - return CHECK_SINGLE(scheme_zerod, sgl, is_long_double); + return CHECK_SINGLE(scheme_zerod, sgl, is_long_double, scheme_zerol, str, len, radix); } } } @@ -1506,7 +1543,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, n = wrap_as_long_double(scheme_utf8_encode_to_buffer(str, len, NULL, 0), radix); #endif } else { - n = CHECK_SINGLE(TO_DOUBLE(n), sgl, 0); + n = CHECK_SINGLE(TO_DOUBLE(n), sgl, 0, NULL, NULL, 0, 0); } } else { if (is_long_double) { @@ -1516,7 +1553,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, str, len); return scheme_false; } - n = CHECK_SINGLE(n, sgl, 0); + n = CHECK_SINGLE(n, sgl, 0, NULL, NULL, 0, 0); } if (SCHEME_FLOATP(n) && str[delta] == '-') { @@ -1545,7 +1582,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, first[has_slash - delta] = 0; n1 = scheme_read_number(first, has_slash - delta, - is_float, is_not_float, 1, + /* recur without is_float to keep all precision */ + 0, is_not_float, 1, radix, 1, next_complain, div_by_zero, test_only, @@ -1569,7 +1607,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, #endif n2 = scheme_read_number(substr, len - has_slash - 1, - is_float, is_not_float, 1, + /* recur without is_float to keep all precision */ + 0, is_not_float, 1, radix, 1, next_complain, div_by_zero, test_only, @@ -1611,7 +1650,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, } else if (is_float) n1 = TO_DOUBLE(n1); - return CHECK_SINGLE(n1, sgl, 0); + return CHECK_SINGLE(n1, sgl, 0, NULL, NULL, 0, 0); } o = scheme_read_bignum(str, delta, radix); @@ -1629,7 +1668,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len, return scheme_nzerod; } - return CHECK_SINGLE(TO_DOUBLE(o), sgl, 0); + return CHECK_SINGLE(TO_DOUBLE(o), sgl, 0, NULL, NULL, 0, 0); } return o; diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index f1c0cd0cae..11cf2f1ac5 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -71,7 +71,7 @@ struct Optimize_Info for constraining the movement of allocation operations */ int sclock; /* virtual clock that ticks when space consumption is potentially observed */ int psize; - short inline_fuel, shift_fuel; + short inline_fuel, shift_fuel, flatten_fuel; char letrec_not_twice, enforce_const, use_psize, has_nonleaf; Scheme_Hash_Table *top_level_consts; @@ -100,6 +100,7 @@ struct Optimize_Info typedef struct Optimize_Info_Sequence { int init_shift_fuel, min_shift_fuel; + int init_flatten_fuel, min_flatten_fuel; } Optimize_Info_Sequence; #define OPT_IS_MUTATED 0x1 @@ -288,6 +289,19 @@ static void note_match(int actual, int expected, Optimize_Info *warn_info) } } +static Scheme_Object *extract_specialized_proc(Scheme_Object *le, Scheme_Object *default_val) +{ + if (SAME_TYPE(SCHEME_TYPE(le), scheme_application2_type)) { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)le; + if (SAME_OBJ(app->rator, scheme_procedure_specialize_proc)) { + if (SCHEME_PROCP(app->rand) || IS_COMPILED_PROC(app->rand)) + return app->rand; + } + } + + return default_val; +} + int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, Optimize_Info *opt_info, Optimize_Info *warn_info, int min_id_depth, int id_offset, int no_id) @@ -468,6 +482,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, && (SCHEME_INT_VAL(app->rand) >= 0)) && IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(app->rand))) { return 1; + } else if (SAME_OBJ(app->rator, scheme_procedure_specialize_proc)) { + if ((vals == 1 || vals == -1) && extract_specialized_proc(o, NULL)) + return 1; } else if (SCHEME_PRIMP(app->rator)) { if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT) || SAME_OBJ(scheme_values_func, app->rator)) { @@ -1774,6 +1791,8 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a if (already_opt) extract_tail_inside(&le, &prev, &id_offset); + le = extract_specialized_proc(le, le); + if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { /* Found a `((lambda' */ single_use = 1; @@ -1940,7 +1959,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a id_offset, orig_le, prev); if (id_offset) { optimize_info_done(sub_info, NULL); - merge_types(sub_info, info, id_offset); + merge_types(sub_info, info, -id_offset); } return le; } else { @@ -2479,6 +2498,8 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc) return scheme_box_p_proc; else if (SAME_OBJ(rator, scheme_void_proc)) return scheme_void_p_proc; + else if (SAME_OBJ(rator, scheme_procedure_specialize_proc)) + return scheme_procedure_p_proc; { Scheme_Object *p; @@ -3697,7 +3718,13 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz if (!SAME_OBJ(pred1, pred2)) { info->preserves_marks = 1; info->single_result = 1; - return scheme_false; + return do_make_discarding_sequence(app->rand1, + do_make_discarding_sequence(app->rand2, + scheme_false, + info, 0, + 1, 0), + info, 0, + 1, 0); } } } @@ -3949,6 +3976,62 @@ Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e, } } +static Scheme_Object *flatten_sequence(Scheme_Object *o, Optimize_Info *info) +{ + Scheme_Sequence *s = (Scheme_Sequence *)o, *s2, *s3; + Scheme_Object *o3; + int i, j, k, count, extra = 0, split = 0, b0; + + if (SAME_TYPE(SCHEME_TYPE(o), scheme_splice_sequence_type)) + return o; + + if (!info->flatten_fuel) + return o; + + b0 = SAME_TYPE(SCHEME_TYPE(o), scheme_begin0_sequence_type); + count = s->count; + + /* exceptions: (begin ... (begin0 ...)) and (begin0 (begin ...) ...) */ + for (i = 0; i < count; i++) { + o3 = s->array[i]; + if ((SAME_TYPE(SCHEME_TYPE(o3), scheme_sequence_type) && !(!i && b0)) + || (SAME_TYPE(SCHEME_TYPE(o3), scheme_begin0_sequence_type) && !(i == count - 1 && !b0))) { + s3 = (Scheme_Sequence *)o3; + extra += s3->count; + split++; + } + } + + if (!split) + return o; + + info->flatten_fuel--; + info->size -= split; + + s2 = scheme_malloc_sequence(s->count + extra - split); + s2->so.type = s->so.type; + s2->count = s->count + extra - split; + k = 0; + + /* exceptions: (begin ... (begin0 ...)) and (begin0 (begin ...) ...) */ + for (i = 0; i < count; i++) { + o3 = s->array[i]; + if ((SAME_TYPE(SCHEME_TYPE(o3), scheme_sequence_type) && !(!i && b0)) + || (SAME_TYPE(SCHEME_TYPE(o3), scheme_begin0_sequence_type) && !(i == count - 1 && !b0))) { + s3 = (Scheme_Sequence *)o3; + for (j = 0; j < s3->count; j++) { + s2->array[k++] = s3->array[j]; + } + } else { + s2->array[k++] = o3; + } + } + + if (k != s2->count) scheme_signal_error("internal error: flatten failed"); + + return (Scheme_Object *)s2; +} + static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, int context) { Scheme_Sequence *s = (Scheme_Sequence *)o; @@ -3989,7 +4072,7 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i single_result = info->single_result; preserves_marks = info->preserves_marks; - /* Move to last position in case the begin form is droped */ + /* Move to last position in case the begin form is dropped */ s->array[count - 1] = le; for (j = i; j < count - 1; j++) { drop++; @@ -4005,9 +4088,10 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i info->preserves_marks = preserves_marks; info->single_result = single_result; - if (drop + 1 == s->count) { + if (drop + 1 == s->count) return s->array[drop]; - } else if (drop) { + + if (drop) { Scheme_Sequence *s2; int j = 0; @@ -4017,14 +4101,14 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i for (i = 0; i < s->count; i++) { if (s->array[i]) { - s2->array[j++] = s->array[i]; + s2->array[j++] = s->array[i]; } } s = s2; } - return (Scheme_Object *)s; + return flatten_sequence((Scheme_Object *)s, info); } XFORM_NONGCING static int small_inline_number(Scheme_Object *o) @@ -5001,8 +5085,7 @@ case_lambda_shift(Scheme_Object *data, int delta, int after_depth) return data; } -static Scheme_Object * -begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) +static Scheme_Object *begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) { int i, count, drop = 0, prev_size, single_result = 0, preserves_marks = 0, kclock = 0, sclock = 0; Scheme_Sequence *s = (Scheme_Sequence *)obj; @@ -5066,7 +5149,7 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) info->preserves_marks = 1; if (i != 0) { - /* We will ignore the first expresion too */ + /* We will ignore the first expression too */ le = optimize_ignored(s->array[0], info, 0, -1, 1, 5); if (!le) { drop++; @@ -5091,7 +5174,7 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) s2->array[j++] = s->array[i]; } } - return (Scheme_Object *)s2; + return flatten_sequence((Scheme_Object *)s2, info); } info->preserves_marks = 1; @@ -5133,8 +5216,7 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) s2->array[j++] = s->array[i]; } } - if (!info->escapes) - s2->array[j++] = expr; + s2->array[j++] = expr; expr = (Scheme_Object *)s2; } @@ -5162,7 +5244,7 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) } info->size += 1; - + expr = flatten_sequence(expr, info); return replace_tail_inside(expr, inside, orig_first); } @@ -5840,7 +5922,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i info->single_result = sub_info->single_result; info->preserves_marks = sub_info->preserves_marks; optimize_info_done(sub_info, NULL); - merge_types(sub_info, info, 1); + merge_types(sub_info, info, -1); } return form; @@ -5866,7 +5948,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i info->single_result = sub_info->single_result; info->preserves_marks = sub_info->preserves_marks; optimize_info_done(sub_info, NULL); - merge_types(sub_info, info, 1); + merge_types(sub_info, info, -1); return body; } } @@ -6331,6 +6413,9 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i } } + if (value) + value = extract_specialized_proc(value, value); + if (value && (scheme_compiled_propagate_ok(value, body_info))) { int cnt; @@ -8402,6 +8487,7 @@ Optimize_Info *scheme_optimize_info_create(Comp_Prefix *cp, int get_logger) #endif info->inline_fuel = 32; info->shift_fuel = 16; + info->flatten_fuel = 16; info->cp = cp; if (get_logger) { @@ -8418,6 +8504,8 @@ static void optimize_info_seq_init(Optimize_Info *info, Optimize_Info_Sequence * { info_seq->init_shift_fuel = info->shift_fuel; info_seq->min_shift_fuel = info->shift_fuel; + info_seq->init_flatten_fuel = info->flatten_fuel; + info_seq->min_flatten_fuel = info->flatten_fuel; } static void optimize_info_seq_step(Optimize_Info *info, Optimize_Info_Sequence *info_seq) @@ -8425,12 +8513,17 @@ static void optimize_info_seq_step(Optimize_Info *info, Optimize_Info_Sequence * if (info->shift_fuel < info_seq->min_shift_fuel) info_seq->min_shift_fuel = info->shift_fuel; info->shift_fuel = info_seq->init_shift_fuel; + if (info->flatten_fuel < info_seq->min_flatten_fuel) + info_seq->min_flatten_fuel = info->flatten_fuel; + info->flatten_fuel = info_seq->init_flatten_fuel; } static void optimize_info_seq_done(Optimize_Info *info, Optimize_Info_Sequence *info_seq) { if (info->shift_fuel > info_seq->min_shift_fuel) info->shift_fuel = info_seq->min_shift_fuel; + if (info->flatten_fuel > info_seq->min_flatten_fuel) + info->flatten_fuel = info_seq->min_flatten_fuel; } void scheme_optimize_info_enforce_const(Optimize_Info *oi, int enforce_const) @@ -9043,6 +9136,7 @@ static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int naya->new_frame = current; naya->inline_fuel = info->inline_fuel; naya->shift_fuel = info->shift_fuel; + naya->flatten_fuel = info->flatten_fuel; naya->letrec_not_twice = info->letrec_not_twice; naya->enforce_const = info->enforce_const; naya->top_level_consts = info->top_level_consts; @@ -9091,6 +9185,7 @@ static void optimize_info_done(Optimize_Info *info, Optimize_Info *parent) parent->escapes = info->escapes; parent->psize += info->psize; parent->shift_fuel = info->shift_fuel; + parent->flatten_fuel = info->flatten_fuel; if (info->has_nonleaf) parent->has_nonleaf = 1; } diff --git a/racket/src/racket/src/place.c b/racket/src/racket/src/place.c index 44faed0e92..25e3add246 100644 --- a/racket/src/racket/src/place.c +++ b/racket/src/racket/src/place.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2009-2015 PLT Design Inc. + Copyright (c) 2009-2016 PLT Design Inc. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public diff --git a/racket/src/racket/src/port.c b/racket/src/racket/src/port.c index 44d3c0e930..58770af789 100644 --- a/racket/src/racket/src/port.c +++ b/racket/src/racket/src/port.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -9417,6 +9417,17 @@ static Scheme_Object *do_subprocess_kill(Scheme_Object *_sp, Scheme_Object *kill return NULL; } +#ifdef WINDOWS_PROCESSES +void scheme_release_process_job_object(void) +{ + if (process_job_object) { + TerminateJobObject((HANDLE)process_job_object, 1); + CloseHandle((HANDLE)process_job_object); + process_job_object = NULL; + } +} +#endif + static void kill_subproc(Scheme_Object *o, void *data) { (void)do_subprocess_kill(o, scheme_true, 0); @@ -9569,10 +9580,10 @@ static char *cmdline_protect(char *s) static intptr_t mz_spawnv(char *command, const char * const *argv, int exact_cmdline, intptr_t sin, intptr_t sout, intptr_t serr, int *pid, - int new_process_group, + int new_process_group, Scheme_Object *cust_mode, void *env, char *wd) { - int i, l, len = 0; + int i, l, len = 0, use_jo; intptr_t cr_flag; char *cmdline; STARTUPINFOW startup; @@ -9617,10 +9628,30 @@ static intptr_t mz_spawnv(char *command, const char * const *argv, cr_flag |= CREATE_NEW_PROCESS_GROUP; cr_flag |= CREATE_UNICODE_ENVIRONMENT; + use_jo = SCHEME_SYMBOLP(cust_mode) && !strcmp(SCHEME_SYM_VAL(cust_mode), "kill"); + if (use_jo) { + /* Use a job object to ensure that the new process will be terminated + if this process ends for any reason (including a crash) */ + if (!process_job_object) { + GC_CAN_IGNORE JOBOBJECT_EXTENDED_LIMIT_INFORMATION jeli; + + process_job_object = (void*)CreateJobObject(NULL, NULL); + + memset(&jeli, 0, sizeof(jeli)); + jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE; + SetInformationJobObject((HANDLE)process_job_object, + JobObjectExtendedLimitInformation, + &jeli, + sizeof(jeli)); + } + } + if (CreateProcessW(WIDE_PATH_COPY(command), WIDE_PATH_COPY(cmdline), NULL, NULL, 1 /*inherit*/, cr_flag, env, WIDE_PATH_COPY(wd), &startup, &info)) { + if (use_jo) + AssignProcessToJobObject((HANDLE)process_job_object, info.hProcess); CloseHandle(info.hThread); *pid = info.dwProcessId; return (intptr_t)info.hProcess; @@ -9952,7 +9983,7 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[]) from_subprocess[1], err_subprocess[1], &pid, - new_process_group, + new_process_group, cust_mode, env, SCHEME_BYTE_STR_VAL(tcd)); if (spawn_status != -1) @@ -11279,6 +11310,48 @@ void scheme_end_sleeper_thread() #endif +/*========================================================================*/ +/* thread helper */ +/*========================================================================*/ + +/* The scheme_call_sequence() functionc an be used, with some care, + via the FFI to run a computation in a foreign thread and thread + results through. Keeping the number of procedures below + `NUM_COPIED_SEQUENCE_PROCS` can potentially simplify things, too */ + +#define NUM_COPIED_SEQUENCE_PROCS 5 + +typedef void *(*Scheme_Sequenced_Proc)(void *); + +struct Scheme_Proc_Sequence { + Scheme_Object *num_procs; /* pointer simplifies allocation issues */ + void *init_data; + Scheme_Sequenced_Proc p[mzFLEX_ARRAY_DECL]; +}; + +void *scheme_call_sequence_of_procedures(struct Scheme_Proc_Sequence *s) + XFORM_SKIP_PROC +{ + int i, num_procs = SCHEME_INT_VAL(s->num_procs); + void *data = s->init_data; + Scheme_Sequenced_Proc copied[NUM_COPIED_SEQUENCE_PROCS]; + + if (num_procs <= NUM_COPIED_SEQUENCE_PROCS) { + for (i = 0; i < num_procs; i++) { + copied[i] = s->p[i]; + } + } + + for (i = 0; i < num_procs; i++) { + if (num_procs <= NUM_COPIED_SEQUENCE_PROCS) + data = copied[i](data); + else + data = s->p[i](data); + } + + return data; +} + /*========================================================================*/ /* memory debugging help */ /*========================================================================*/ diff --git a/racket/src/racket/src/portfun.c b/racket/src/racket/src/portfun.c index ca962a45bc..b8cf3bf747 100644 --- a/racket/src/racket/src/portfun.c +++ b/racket/src/racket/src/portfun.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -4844,6 +4844,9 @@ static Scheme_Object *default_load(int argc, Scheme_Object *argv[]) config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_true); config = scheme_extend_config(config, MZCONFIG_READ_DECIMAL_INEXACT, scheme_true); config = scheme_extend_config(config, MZCONFIG_READTABLE, scheme_false); + config = scheme_extend_config(config, MZCONFIG_READ_CDOT, scheme_false); + config = scheme_extend_config(config, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, scheme_false); + config = scheme_extend_config(config, MZCONFIG_CURLY_BRACES_ARE_TAGGED, scheme_false); } else { config = scheme_extend_config(config, MZCONFIG_CAN_READ_COMPILED, scheme_true); config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true); diff --git a/racket/src/racket/src/print.c b/racket/src/racket/src/print.c index e0cb524dea..35710c4532 100644 --- a/racket/src/racket/src/print.c +++ b/racket/src/racket/src/print.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/ratfloat.inc b/racket/src/racket/src/ratfloat.inc index 560b3eaaa4..9735c6c687 100644 --- a/racket/src/racket/src/ratfloat.inc +++ b/racket/src/racket/src/ratfloat.inc @@ -104,7 +104,7 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o) if (shift > FLOAT_M_BITS) { shift = FLOAT_M_BITS; } - + a[0] = n; a[1] = scheme_make_integer(shift); n = scheme_bitwise_shift(2, a); @@ -120,9 +120,9 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o) } else { /* Round to even: */ a[0] = d; - if (!scheme_odd_p(1, a)) { + if (SCHEME_FALSEP(scheme_odd_p(1, a))) { a[0] = n; - if (!scheme_even_p(1, a)) { + if (SCHEME_FALSEP(scheme_even_p(1, a))) { n = scheme_bin_plus(n, scheme_make_integer(1)); } } diff --git a/racket/src/racket/src/rational.c b/racket/src/racket/src/rational.c index 4dda7a6f94..c36aaae1b7 100644 --- a/racket/src/racket/src/rational.c +++ b/racket/src/racket/src/rational.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/read.c b/racket/src/racket/src/read.c index f9126e2fca..93bcdbd24e 100644 --- a/racket/src/racket/src/read.c +++ b/racket/src/racket/src/read.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -82,6 +82,9 @@ ROSYM static Scheme_Object *syntax_symbol; ROSYM static Scheme_Object *unsyntax_symbol; ROSYM static Scheme_Object *unsyntax_splicing_symbol; ROSYM static Scheme_Object *quasisyntax_symbol; +ROSYM static Scheme_Object *brackets_symbol; +ROSYM static Scheme_Object *braces_symbol; +ROSYM static Scheme_Object *dot_symbol; ROSYM static Scheme_Object *terminating_macro_symbol; ROSYM static Scheme_Object *non_terminating_macro_symbol; ROSYM static Scheme_Object *dispatch_macro_symbol; @@ -93,6 +96,9 @@ ROSYM static Scheme_Object *tainted_uninterned_symbol; static Scheme_Object *read_case_sensitive(int, Scheme_Object *[]); static Scheme_Object *read_bracket_as_paren(int, Scheme_Object *[]); static Scheme_Object *read_brace_as_paren(int, Scheme_Object *[]); +static Scheme_Object *read_bracket_with_tag(int, Scheme_Object *[]); +static Scheme_Object *read_brace_with_tag(int, Scheme_Object *[]); +static Scheme_Object *read_cdot(int, Scheme_Object *[]); static Scheme_Object *read_accept_graph(int, Scheme_Object *[]); static Scheme_Object *read_accept_compiled(int, Scheme_Object *[]); static Scheme_Object *read_accept_box(int, Scheme_Object *[]); @@ -171,6 +177,9 @@ typedef struct ReadParams { char case_sensitive; char square_brackets_are_parens; char curly_braces_are_parens; + char square_brackets_are_tagged; + char curly_braces_are_tagged; + char read_cdot; char read_decimal_inexact; char can_read_dot; char can_read_infix_dot; @@ -311,7 +320,8 @@ static int next_is_delim(Scheme_Object *port, static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, Scheme_Object *indentation, - ReadParams *params, Readtable *table); + ReadParams *params, Readtable *table, + Scheme_Object **prefetched); static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params, Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, @@ -414,6 +424,10 @@ void scheme_init_read(Scheme_Env *env) REGISTER_SO(unsyntax_splicing_symbol); REGISTER_SO(quasisyntax_symbol); + REGISTER_SO(brackets_symbol); + REGISTER_SO(braces_symbol); + REGISTER_SO(dot_symbol); + REGISTER_SO(unresolved_uninterned_symbol); REGISTER_SO(tainted_uninterned_symbol); REGISTER_SO(terminating_macro_symbol); @@ -430,6 +444,10 @@ void scheme_init_read(Scheme_Env *env) unsyntax_splicing_symbol = scheme_intern_symbol("unsyntax-splicing"); quasisyntax_symbol = scheme_intern_symbol("quasisyntax"); + brackets_symbol = scheme_intern_symbol("#%brackets"); + braces_symbol = scheme_intern_symbol("#%braces"); + dot_symbol = scheme_intern_symbol("#%dot"); + unresolved_uninterned_symbol = scheme_make_symbol("unresolved"); tainted_uninterned_symbol = scheme_make_symbol("tainted"); @@ -448,6 +466,7 @@ void scheme_init_read(Scheme_Env *env) } builtin_fast[';'] = READTABLE_TERMINATING; builtin_fast['\''] = READTABLE_TERMINATING; + builtin_fast['`'] = READTABLE_TERMINATING; builtin_fast[','] = READTABLE_TERMINATING; builtin_fast['"'] = READTABLE_TERMINATING; builtin_fast['|'] = READTABLE_MULTIPLE_ESCAPE; @@ -514,6 +533,9 @@ void scheme_init_read(Scheme_Env *env) GLOBAL_PARAMETER("read-case-sensitive", read_case_sensitive, MZCONFIG_CASE_SENS, env); GLOBAL_PARAMETER("read-square-bracket-as-paren", read_bracket_as_paren, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, env); GLOBAL_PARAMETER("read-curly-brace-as-paren", read_brace_as_paren, MZCONFIG_CURLY_BRACES_ARE_PARENS, env); + GLOBAL_PARAMETER("read-square-bracket-with-tag", read_bracket_with_tag, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, env); + GLOBAL_PARAMETER("read-curly-brace-with-tag", read_brace_with_tag, MZCONFIG_CURLY_BRACES_ARE_TAGGED, env); + GLOBAL_PARAMETER("read-cdot", read_cdot, MZCONFIG_READ_CDOT, env); GLOBAL_PARAMETER("read-accept-graph", read_accept_graph, MZCONFIG_CAN_READ_GRAPH, env); GLOBAL_PARAMETER("read-accept-compiled", read_accept_compiled, MZCONFIG_CAN_READ_COMPILED, env); GLOBAL_PARAMETER("read-accept-box", read_accept_box, MZCONFIG_CAN_READ_BOX, env); @@ -605,6 +627,24 @@ read_brace_as_paren(int argc, Scheme_Object *argv[]) DO_CHAR_PARAM("read-curly-brace-as-paren", MZCONFIG_CURLY_BRACES_ARE_PARENS); } +static Scheme_Object * +read_bracket_with_tag(int argc, Scheme_Object *argv[]) +{ + DO_CHAR_PARAM("read-square-bracket-with-tag", MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED); +} + +static Scheme_Object * +read_brace_with_tag(int argc, Scheme_Object *argv[]) +{ + DO_CHAR_PARAM("read-curly-brace-with-tag", MZCONFIG_CURLY_BRACES_ARE_TAGGED); +} + +static Scheme_Object * +read_cdot(int argc, Scheme_Object *argv[]) +{ + DO_CHAR_PARAM("read-cdot", MZCONFIG_READ_CDOT); +} + static Scheme_Object * read_accept_graph(int argc, Scheme_Object *argv[]) { @@ -790,6 +830,15 @@ read_delay_load(int argc, Scheme_Object *argv[]) #ifdef DO_STACK_CHECK +static Scheme_Object *read_inner_inner_inner(Scheme_Object *port, + Scheme_Object *stxsrc, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, + ReadParams *params, + int comment_mode, + int pre_char, + Readtable *init_readtable, + int get_info); static Scheme_Object *read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, @@ -817,7 +866,7 @@ static void set_need_copy(Scheme_Hash_Table **ht) scheme_hash_set(*ht, tainted_uninterned_symbol, scheme_true); } -static Scheme_Object *read_inner_inner_k(void) +static Scheme_Object *read_inner_inner_inner_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; @@ -833,7 +882,7 @@ static Scheme_Object *read_inner_inner_k(void) p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - return read_inner_inner(o, stxsrc, ht, indentation, params, p->ku.k.i1, p->ku.k.i2, + return read_inner_inner_inner(o, stxsrc, ht, indentation, params, p->ku.k.i1, p->ku.k.i2, table, p->ku.k.i3); } #endif @@ -874,14 +923,17 @@ static int read_vector_length(Scheme_Object *port, Readtable *table, int *ch, mz } if (!(*overflow)) { - intptr_t old_len; + uintptr_t old_len; + uintptr_t new_len; if (*vector_length < 0) *vector_length = 0; old_len = *vector_length; - *vector_length = ((*vector_length) * 10) + ((*ch) - 48); - if ((*vector_length < 0)|| ((*vector_length / 10) != old_len)) { + new_len = *vector_length; + new_len = ((new_len) * 10) + ((*ch) - 48); + *vector_length = new_len; + if ((*vector_length < 0) || ((new_len / 10) != old_len)) { *overflow = 1; } } @@ -894,6 +946,11 @@ static int read_vector_length(Scheme_Object *port, Readtable *table, int *ch, mz vecbuf[j] = 0; tagbuf[i] = 0; + if (!j) { + vecbuf[j] = '0'; + vecbuf[0] = 0; + } + return readtable_effective_char(table, (*ch)); } @@ -922,7 +979,7 @@ read_plus_minus_period_leading_number(Scheme_Object *port, Scheme_Object *stxsrc static Scheme_Object * -read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, +read_inner_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, Scheme_Object *indentation, ReadParams *params, int comment_mode, int pre_char, Readtable *table, int get_info) @@ -958,7 +1015,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * p->ku.k.i1 = comment_mode; p->ku.k.i2 = pre_char; p->ku.k.i3 = get_info; - return scheme_handle_stack_overflow(read_inner_inner_k); + return scheme_handle_stack_overflow(read_inner_inner_inner_k); } } #endif @@ -1060,13 +1117,13 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * case '(': return read_list(port, stxsrc, line, col, pos, ch, ')', mz_shape_cons, 0, ht, indentation, params, table); case '[': - if (!params->square_brackets_are_parens) { + if (!params->square_brackets_are_parens && !params->square_brackets_are_tagged) { scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open square bracket"); return NULL; } else return read_list(port, stxsrc, line, col, pos, ch, ']', mz_shape_cons, 0, ht, indentation, params, table); case '{': - if (!params->curly_braces_are_parens) { + if (!params->curly_braces_are_parens && !params->curly_braces_are_tagged) { scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open curly brace"); return NULL; } else @@ -1847,7 +1904,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * if (!ph) { scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: no #%ld= preceding #%ld#", + "read: no #%d= preceding #%d#", vector_length, vector_length); return scheme_void; } @@ -1874,7 +1931,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * if (*ht) { if (scheme_hash_get(*ht, scheme_make_integer(vector_length))) { scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: multiple #%ld= tags", + "read: multiple #%d= tags", vector_length); return NULL; } @@ -1960,6 +2017,54 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * } } +static Scheme_Object * +read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, + Scheme_Object *indentation, ReadParams *params, + int comment_mode, int pre_char, Readtable *table, + int get_info) +{ + intptr_t rline = 0, rcol = 0, rpos = 0; + intptr_t dline = 0, dcol = 0, dpos = 0; + Scheme_Object *ret; + int read_cdot, next, found_dot; + + read_cdot = params->read_cdot; + + scheme_tell_all(port, &rline, &rcol, &rpos); + ret = read_inner_inner_inner(port, stxsrc, ht, indentation, params, comment_mode, pre_char, table, get_info); + + if (!read_cdot) { return ret; } + + found_dot = 0; + while ( 1 ) { + next = scheme_peekc_special_ok(port); + if ( next == EOF ) { break; } + if ( (table && readtable_kind(table, next, params) & READTABLE_WHITESPACE) + || (!table && scheme_isspace(next)) ) { + scheme_getc_special_ok(port); continue; } + if ( (table && readtable_effective_char(table, next) == '.') + || (!table && next == '.') ) { + scheme_getc_special_ok(port); found_dot = 1; break; } + break; + } + + if ( found_dot ) { + Scheme_Object *dot, *next; + scheme_tell_all(port, &dline, &dcol, &dpos); + dot = dot_symbol; + if (stxsrc) { + dot = scheme_make_stx_w_offset(dot, dline, dcol, dpos, SPAN(port,dpos), stxsrc, STX_SRCTAG); + } + next = read_inner_inner(port, stxsrc, ht, indentation, params, comment_mode, pre_char, table, get_info); + ret = scheme_make_pair( dot, scheme_make_pair( ret, scheme_make_pair( next, scheme_null ) ) ); + if (stxsrc) { + ret = scheme_make_stx_w_offset(ret, rline, rcol, rpos, SPAN(port,rpos), stxsrc, STX_SRCTAG); + } + } + + return ret; +} + static Scheme_Object * read_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, Scheme_Object *indentation, ReadParams *params, @@ -1974,6 +2079,7 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, Scheme_Object *top, Scheme_Hash_Table *dht, Scheme_Hash_Table *tht, + Scheme_Hash_Table *self_contained_ht, int clone, int tail_depth); @@ -1984,7 +2090,8 @@ static Scheme_Object *resolve_k(void) Scheme_Object *port = (Scheme_Object *)p->ku.k.p2; Scheme_Object *top = (Scheme_Object *)p->ku.k.p5; Scheme_Hash_Table *dht = (Scheme_Hash_Table *)p->ku.k.p3; - Scheme_Hash_Table *tht = (Scheme_Hash_Table *)p->ku.k.p4; + Scheme_Hash_Table *tht = (Scheme_Hash_Table *)SCHEME_CAR((Scheme_Object *)p->ku.k.p4); + Scheme_Hash_Table *self_contained_ht = (Scheme_Hash_Table *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4); p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; @@ -1992,7 +2099,7 @@ static Scheme_Object *resolve_k(void) p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - return resolve_references(o, port, top, dht, tht, p->ku.k.i1, p->ku.k.i2); + return resolve_references(o, port, top, dht, tht, self_contained_ht, p->ku.k.i1, p->ku.k.i2); } #endif @@ -2001,6 +2108,7 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, Scheme_Object *top, Scheme_Hash_Table *dht, Scheme_Hash_Table *tht, + Scheme_Hash_Table *self_contained_ht, int clone, int tail_depth) { @@ -2015,7 +2123,9 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, p->ku.k.p2 = (void *)port; p->ku.k.p5 = (void *)top; p->ku.k.p3 = (void *)dht; - p->ku.k.p4 = (void *)tht; + result = scheme_make_pair((Scheme_Object *)tht, + (Scheme_Object *)self_contained_ht); + p->ku.k.p4 = (void *)result; p->ku.k.i1 = clone; p->ku.k.i2 = tail_depth; return scheme_handle_stack_overflow(resolve_k); @@ -2044,6 +2154,10 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, } } + if (self_contained_ht + && scheme_hash_get(self_contained_ht, obj)) + return obj; + result = scheme_hash_get(dht, obj); if (result) { if (SCHEME_PAIRP(result)) { @@ -2063,12 +2177,14 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, result = scheme_make_pair(scheme_false, scheme_false); scheme_hash_set(dht, obj, result); - rr = resolve_references(SCHEME_CAR(obj), port, top, dht, tht, clone, tail_depth + 1); + rr = resolve_references(SCHEME_CAR(obj), port, top, dht, tht, self_contained_ht, + clone, tail_depth + 1); SCHEME_CAR(result) = rr; scheme_hash_set(tht, result, scheme_make_integer(tail_depth)); - rr = resolve_references(SCHEME_CDR(obj), port, top, dht, tht, clone, tail_depth); + rr = resolve_references(SCHEME_CDR(obj), port, top, dht, tht, self_contained_ht, + clone, tail_depth); SCHEME_CDR(result) = rr; scheme_hash_set(tht, result, NULL); @@ -2090,7 +2206,8 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, } scheme_hash_set(dht, obj, result); - rr = resolve_references(SCHEME_BOX_VAL(obj), port, top, dht, tht, clone, tail_depth + 1); + rr = resolve_references(SCHEME_BOX_VAL(obj), port, top, dht, tht, self_contained_ht, + clone, tail_depth + 1); SCHEME_BOX_VAL(result) = rr; if (clone @@ -2122,7 +2239,8 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, rr = prev_rr; } else { prev_v = SCHEME_VEC_ELS(obj)[i]; - rr = resolve_references(prev_v, port, top, dht, tht, clone, tail_depth + 1); + rr = resolve_references(prev_v, port, top, dht, tht, self_contained_ht, + clone, tail_depth + 1); if (!SAME_OBJ(prev_v, rr)) diff = 1; prev_rr = rr; @@ -2175,7 +2293,8 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, result = (Scheme_Object *)t; scheme_hash_set(dht, obj, result); - lst = resolve_references(lst, port, top, dht, tht, clone, tail_depth + 1); + lst = resolve_references(lst, port, top, dht, tht, self_contained_ht, + clone, tail_depth + 1); for (; SCHEME_PAIRP(lst); lst = SCHEME_CDR(lst)) { a = SCHEME_CAR(lst); @@ -2207,7 +2326,8 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, } orig_l = l; - l = resolve_references(l, port, top, dht, tht, clone, tail_depth + 1); + l = resolve_references(l, port, top, dht, tht, self_contained_ht, + clone, tail_depth + 1); if (SAME_OBJ(l, orig_l)) { result = obj; @@ -2242,7 +2362,8 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, diff = 0; for (i = 0; i < c; i++) { prev_v = ((Scheme_Structure *)result)->slots[i]; - v = resolve_references(prev_v, port, top, dht, tht, clone, tail_depth + 1); + v = resolve_references(prev_v, port, top, dht, tht, self_contained_ht, + clone, tail_depth + 1); if (!SAME_OBJ(prev_v, v)) diff = 1; ((Scheme_Structure *)result)->slots[i] = v; @@ -2315,6 +2436,12 @@ _internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cant_fai params.square_brackets_are_parens = SCHEME_TRUEP(v); v = scheme_get_param(config, MZCONFIG_CURLY_BRACES_ARE_PARENS); params.curly_braces_are_parens = SCHEME_TRUEP(v); + v = scheme_get_param(config, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED); + params.square_brackets_are_tagged = SCHEME_TRUEP(v); + v = scheme_get_param(config, MZCONFIG_CURLY_BRACES_ARE_TAGGED); + params.curly_braces_are_tagged = SCHEME_TRUEP(v); + v = scheme_get_param(config, MZCONFIG_READ_CDOT); + params.read_cdot = SCHEME_TRUEP(v); v = scheme_get_param(config, MZCONFIG_READ_DECIMAL_INEXACT); params.read_decimal_inexact = SCHEME_TRUEP(v); v = scheme_get_param(config, MZCONFIG_CAN_READ_QUASI); @@ -2380,12 +2507,12 @@ _internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cant_fai tht = scheme_make_hash_table(SCHEME_hash_ptr); if (v) - v = resolve_references(v, port, NULL, dht, tht, clone, 0); + v = resolve_references(v, port, NULL, dht, tht, NULL, clone, 0); /* In case some placeholders were introduced by #;: */ v2 = scheme_hash_get(*ht, unresolved_uninterned_symbol); if (v2) - resolve_references(v2, port, NULL, dht, tht, clone, 0); + resolve_references(v2, port, NULL, dht, tht, NULL, clone, 0); if (!v) *ht = NULL; @@ -2474,6 +2601,7 @@ Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj) return resolve_references(obj, NULL, obj, scheme_make_hash_table(SCHEME_hash_ptr), scheme_make_hash_table(SCHEME_hash_ptr), + NULL, 1, 0); } @@ -2486,6 +2614,12 @@ static Scheme_Object *attach_shape_property(Scheme_Object *list, ReadParams *params, int closer); +static Scheme_Object *attach_shape_tag(Scheme_Object *list, + intptr_t line, intptr_t col, intptr_t pos, intptr_t span, + Scheme_Object *stxsrc, + ReadParams *params, + int closer); + static int next_is_delim(Scheme_Object *port, ReadParams *params, int brackets, @@ -2632,8 +2766,8 @@ read_list(Scheme_Object *port, { Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL, *prefetched = NULL; int ch = 0, got_ch_already = 0, effective_ch; - int brackets = params->square_brackets_are_parens; - int braces = params->curly_braces_are_parens; + int brackets = params->square_brackets_are_parens || params->square_brackets_are_tagged; + int braces = params->curly_braces_are_parens || params->curly_braces_are_tagged; intptr_t start, startcol, startline, dotpos, dotcol, dotline, dot2pos, dot2line, dot2col, init_span; scheme_tell_all(port, &startline, &startcol, &start); @@ -2662,7 +2796,7 @@ read_list(Scheme_Object *port, else if (got_ch_already) got_ch_already = 0; else - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); + ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL); if ((ch == EOF) && (closer != EOF)) { char *suggestion = ""; @@ -2699,6 +2833,7 @@ read_list(Scheme_Object *port, } if (!list) list = scheme_null; pop_indentation(indentation); + list = attach_shape_tag(list, line, col, pos, SPAN(port, pos), stxsrc, params, closer); list = (stxsrc ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) : list); @@ -2754,9 +2889,11 @@ read_list(Scheme_Object *port, switch (shape) { case mz_shape_fl_vec: car = read_flonum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); + MZ_ASSERT(SCHEME_DBLP(car)); break; case mz_shape_fx_vec: car = read_fixnum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); + MZ_ASSERT(SCHEME_INTP(car)); break; default: car = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); @@ -2770,7 +2907,7 @@ read_list(Scheme_Object *port, retry_before_dot: - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); + ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL); effective_ch = readtable_effective_char(table, ch); if (effective_ch == closer) { if (shape == mz_shape_hash_elem) { @@ -2793,6 +2930,7 @@ read_list(Scheme_Object *port, } pop_indentation(indentation); + list = attach_shape_tag(list, line, col, pos, SPAN(port, pos), stxsrc, params, closer); list = (stxsrc ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) : list); @@ -2819,7 +2957,7 @@ read_list(Scheme_Object *port, /* can't be eof, due to check above: */ cdr = read_inner(port, stxsrc, ht, indentation, params, 0); - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); + ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched); effective_ch = readtable_effective_char(table, ch); if ((effective_ch != closer) || (shape == mz_shape_vec_plus_infix)) { if (params->can_read_infix_dot @@ -2848,14 +2986,15 @@ read_list(Scheme_Object *port, last = pair; /* Make sure there's not a closing paren immediately after the dot: */ - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); + ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched); effective_ch = readtable_effective_char(table, ch); if ((effective_ch == closer) || (ch == EOF)) { scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, "read: illegal use of `%c'", ch); return NULL; } - got_ch_already = 1; + if (!prefetched) + got_ch_already = 1; } else { scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, "read: illegal use of `%c'", @@ -2873,6 +3012,7 @@ read_list(Scheme_Object *port, /* Assert: infixed is NULL (otherwise we raised an exception above) */ pop_indentation(indentation); + list = attach_shape_tag(list, line, col, pos, SPAN(port, pos), stxsrc, params, closer); list = (stxsrc ? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG) : list); @@ -2880,14 +3020,25 @@ read_list(Scheme_Object *port, return list; } } else { - if ((ch == SCHEME_SPECIAL) - || (table && (ch != EOF) && (shape != mz_shape_hash_list))) { + if ((ch == SCHEME_SPECIAL) + || (table + && (ch != EOF) + && (shape != mz_shape_hash_list) + && (shape != mz_shape_fl_vec) + && (shape != mz_shape_fx_vec))) { /* We have to try the read, because it might be a comment. */ scheme_ungetc(ch, port); prefetched = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); if (!prefetched) goto retry_before_dot; + if ((shape == mz_shape_fl_vec) && !SCHEME_DBLP(prefetched)) { + scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, + "read: stream produced a non-flonum for flvector"); + } else if ((shape == mz_shape_fx_vec) && !SCHEME_INTP(prefetched)) { + scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, + "read: stream produced a non-fixnum for fxvector"); + } } else { got_ch_already = 1; } @@ -2924,6 +3075,31 @@ static Scheme_Object *attach_shape_property(Scheme_Object *list, return list; } +static Scheme_Object *attach_shape_tag(Scheme_Object *list, + intptr_t line, intptr_t col, intptr_t pos, intptr_t span, + Scheme_Object *stxsrc, + ReadParams *params, + int closer) +{ + Scheme_Object *tag; + tag = NULL; + + if (params->square_brackets_are_tagged && closer == ']') { + tag = brackets_symbol; + } else if (params->curly_braces_are_tagged && closer == '}') { + tag = braces_symbol; + } + + if (tag) { + if (stxsrc) { + tag = scheme_make_stx_w_offset(tag, line, col, pos, span, stxsrc, STX_SRCTAG); + } + list = scheme_make_pair(tag, list); + } + + return list; +} + static Scheme_Object *read_flonum(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, @@ -3119,10 +3295,11 @@ read_string(int is_byte, Scheme_Object *port, case 'U': if (!is_byte) { int maxc = ((ch == 'u') ? 4 : 8); - char initial[8]; + char initial[9]; ch = scheme_getc_special_ok(port); if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) { int count = 1; + initial[0] = ch; n = ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10); while (count < maxc) { ch = scheme_peekc_special_ok(port); @@ -3134,6 +3311,7 @@ read_string(int is_byte, Scheme_Object *port, } else break; } + initial[count] = 0; if ((maxc == 4) && ((n >= 0xD800) && (n <= 0xDBFF))) { /* Allow a surrogate-pair-like encoding, as long as the next part is "\uD..." */ @@ -3178,7 +3356,6 @@ read_string(int is_byte, Scheme_Object *port, else if (NOT_EOF_OR_SPECIAL(ch)) snd[sndp++] = ch; snd[sndp] = 0; - initial[4] = 0; if (err_ok) scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, "read: bad or incomplete surrogate-style encoding at `\\u%s%5'", @@ -3491,6 +3668,7 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port, intptr_t rq_pos = 0, rq_col = 0, rq_line = 0; int case_sens = params->case_sensitive; int decimal_inexact = params->read_decimal_inexact; + int read_cdot = params->read_cdot; Scheme_Object *o; int delim_ok; int ungetc_ok; @@ -3539,8 +3717,10 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port, || (!table && !scheme_isspace(ch) && (((ch < 128) && (delim[ch] & delim_ok)) - || ((ch >= 128) && far_char_ok))) - || table)) { + || ((ch >= 128) && far_char_ok)) + && !(!is_float && !is_not_float && !radix_set && read_cdot && ch == '.')) + || (table + && !(!is_float && !is_not_float && !radix_set && read_cdot && readtable_effective_char(table, ch) == '.')))) { if (table) { int v; v = readtable_kind(table, ch, params); @@ -4111,9 +4291,12 @@ Scheme_Object *scheme_read_intern(Scheme_Object *o) static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, Scheme_Object *indentation, - ReadParams *params, Readtable *table) + ReadParams *params, Readtable *table, + Scheme_Object **_prefetched) +/* If `_prefetched` is non_NULL, then a SCHEME_SPECIAL result means that + the special value has already been read, and it wasn't a comment. */ { - int ch; + int ch, effective_ch; int blockc_1, blockc_2; blockc_1 = '#'; @@ -4126,21 +4309,23 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE)) break; } - return ch; } else { while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {} } - if (ch == ';') { + effective_ch = readtable_effective_char(table, ch); + if (effective_ch == ';') { do { ch = scheme_getc_special_ok(port); - if (ch == SCHEME_SPECIAL) + effective_ch = readtable_effective_char(table, ch); + if (effective_ch == SCHEME_SPECIAL) scheme_get_ready_read_special(port, stxsrc, ht); - } while (!is_line_comment_end(ch) && ch != EOF); + } while (!is_line_comment_end(effective_ch) && (effective_ch != EOF)); goto start_over; } - if (ch == blockc_1 && (scheme_peekc_special_ok(port) == blockc_2)) { + if ((effective_ch == blockc_1) + && (readtable_effective_char(table, scheme_peekc_special_ok(port)) == blockc_2)) { int depth = 0; int ch2 = 0; intptr_t col, pos, line; @@ -4150,27 +4335,29 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, (void)scheme_getc(port); /* re-read '|' */ do { ch = scheme_getc_special_ok(port); - - if (ch == EOF) + effective_ch = readtable_effective_char(table, ch); + + if (effective_ch == EOF) scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, "read: end of file in #| comment"); - else if (ch == SCHEME_SPECIAL) + else if (effective_ch == SCHEME_SPECIAL) scheme_get_ready_read_special(port, stxsrc, ht); - if ((ch2 == blockc_2) && (ch == blockc_1)) { + if ((ch2 == blockc_2) && (effective_ch == blockc_1)) { if (!(depth--)) goto start_over; - ch = 0; /* So we don't count '#' toward an opening "#|" */ + effective_ch = 0; /* So we don't count '#' toward an opening "#|" */ } else if ((ch2 == blockc_1) && (ch == blockc_2)) { depth++; - ch = 0; /* So we don't count '|' toward a closing "|#" */ + effective_ch = 0; /* So we don't count '|' toward a closing "|#" */ } - ch2 = ch; + ch2 = effective_ch; } while (1); goto start_over; } - if (ch == '#' && (scheme_peekc_special_ok(port) == ';')) { + if ((effective_ch == '#') + && (readtable_effective_char(table, scheme_peekc_special_ok(port)) == ';')) { Scheme_Object *skipped; intptr_t col, pos, line; @@ -4198,6 +4385,20 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, goto start_over; } + if ((ch == SCHEME_SPECIAL) && _prefetched) { + Scheme_Object *v; + intptr_t col, pos, line; + + scheme_tell_all(port, &line, &col, &pos); + v = scheme_get_special(port, stxsrc, line, col, pos, 0, ht); + if (!scheme_special_comment_value(v)) { + *_prefetched = v; + return SCHEME_SPECIAL; + } + + goto start_over; + } + return ch; } @@ -4307,6 +4508,7 @@ typedef struct Scheme_Load_Delay { uintptr_t symtab_size; Scheme_Object **symtab; intptr_t *shared_offsets; + Scheme_Hash_Table *symtab_entries; /* `symtab` content to be skipped by resolve_references */ Scheme_Object *relto; Scheme_Unmarshal_Tables *ut; struct CPort *current_rp; @@ -4336,6 +4538,7 @@ typedef struct CPort { Scheme_Object *symtab_refs; Scheme_Unmarshal_Tables *ut; Scheme_Object **symtab; + Scheme_Hash_Table *symtab_entries; Scheme_Object *magic_sym, *magic_val; Scheme_Object *relto; intptr_t *shared_offsets; @@ -4546,6 +4749,9 @@ static Scheme_Object *read_escape_from_string(char *s, intptr_t len, params.case_sensitive = scheme_case_sensitive; params.square_brackets_are_parens = 1; params.curly_braces_are_parens = 1; + params.square_brackets_are_tagged = 0; + params.curly_braces_are_tagged = 0; + params.read_cdot = 0; params.read_decimal_inexact = 1; params.can_read_dot = 1; params.can_read_infix_dot = 1; @@ -4584,6 +4790,20 @@ static Scheme_Object *read_compact_escape(CPort *port) return read_escape_from_string(s, len, port->relto, port->ht); } +static void record_symtab_self_contained(Scheme_Hash_Table *symtab_entries, Scheme_Object *v) +{ + if (SCHEME_PAIRP(v) + || SCHEME_BOXP(v) + || SCHEME_VECTORP(v) + || SCHEME_HASHTRP(v) + || SCHEME_STRUCTP(v)) { + /* Register `v` as a value that is shared through the symbol table, + so that later calls to resolve_references() can avoid re-traversing + the value. (Otherwise, bytecode reading can become quadratic-time.) */ + scheme_hash_set(symtab_entries, v, scheme_true); + } +} + static Scheme_Object *resolve_symtab_refs(Scheme_Object *v, CPort *port) { Scheme_Object *l; @@ -4596,7 +4816,8 @@ static Scheme_Object *resolve_symtab_refs(Scheme_Object *v, CPort *port) v = resolve_references(v, port->orig_port, NULL, scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), + scheme_make_hash_table(SCHEME_hash_ptr), + port->symtab_entries, 0, 0); l = SCHEME_CDR(v); @@ -4604,9 +4825,10 @@ static Scheme_Object *resolve_symtab_refs(Scheme_Object *v, CPort *port) l = port->symtab_refs; for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - if (v) + if (v) { port->symtab[SCHEME_INT_VAL(SCHEME_CAR(SCHEME_CAR(l)))] = SCHEME_CDR(SCHEME_CAR(l)); - else { + record_symtab_self_contained(port->symtab_entries, SCHEME_CDR(SCHEME_CAR(l))); + } else { /* interrupted; discard partial constructions */ port->symtab[SCHEME_INT_VAL(SCHEME_CAR(SCHEME_CAR(l)))] = NULL; } @@ -4854,7 +5076,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) *port->ht = NULL; v = resolve_references(v, port->orig_port, NULL, scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), + scheme_make_hash_table(SCHEME_hash_ptr), + port->symtab_entries, 0, 0); } @@ -4981,7 +5204,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) if (SCHEME_FALSEP(path)) return scheme_make_modidx(scheme_false, scheme_false, scheme_false); else - return scheme_get_submodule_empty_self_modidx(path); + return scheme_get_submodule_empty_self_modidx(path, 0); } else return scheme_make_modidx(path, base, scheme_false); } @@ -5340,8 +5563,9 @@ static Scheme_Object *read_compact_quote(CPort *port, int embedded) if (*q_ht) v = resolve_references(v, port->orig_port, NULL, - scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), + scheme_make_hash_table(SCHEME_hash_ptr), + scheme_make_hash_table(SCHEME_hash_ptr), + port->symtab_entries, 0, 0); return v; @@ -5677,6 +5901,14 @@ static Scheme_Object *read_compiled(Scheme_Object *port, rp->symtab = symtab; rp->unsafe_ok = params->can_read_unsafe; + { + Scheme_Hash_Table *se_ht; + se_ht = scheme_make_hash_table(SCHEME_hash_ptr); + rp->symtab_entries = se_ht; + if (delay_info) + delay_info->symtab_entries = se_ht; + } + config = scheme_current_config(); dir = scheme_get_param(config, MZCONFIG_LOAD_DIRECTORY); @@ -5964,6 +6196,7 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in rp->ut = delay_info->ut; rp->unsafe_ok = delay_info->unsafe_ok; rp->bytecode_hash = delay_info->bytecode_hash; + rp->symtab_entries = delay_info->symtab_entries; if (delay_info->ut) delay_info->ut->rp = rp; @@ -6019,11 +6252,13 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in if (*ht) { v = resolve_references(v, port, NULL, scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), + scheme_make_hash_table(SCHEME_hash_ptr), + delay_info->symtab_entries, 0, 0); } delay_info->symtab[which] = v; + record_symtab_self_contained(delay_info->symtab_entries, v); return v; } else { @@ -6204,7 +6439,8 @@ static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, Re /* resolve references from recursive `read': */ v = resolve_references(v, port, NULL, scheme_make_hash_table(SCHEME_hash_ptr), - scheme_make_hash_table(SCHEME_hash_ptr), + scheme_make_hash_table(SCHEME_hash_ptr), + NULL, 1, 0); } @@ -6303,7 +6539,7 @@ static void check_proc_either_arity(const char *who, int a1, int a2, int which, { if (!scheme_check_proc_arity(NULL, a1, which, argc, argv) && !scheme_check_proc_arity(NULL, a2, which, argc, argv)) { - char buffer[60]; + char buffer[256]; sprintf(buffer, "(or (procedure-arity-includes/c %d) (procedure-arity-includes/c %d))", a1, a2); scheme_wrong_contract(who, buffer, which, argc, argv); } diff --git a/racket/src/racket/src/regexp.c b/racket/src/racket/src/regexp.c index b2e7fa76cb..d3858ded49 100644 --- a/racket/src/racket/src/regexp.c +++ b/racket/src/racket/src/regexp.c @@ -1,7 +1,7 @@ /* * @(#)regexp.c 1.3 of 18 April 87 * Revised for PLT Racket, 1995-2001 - * Copyright (c) 2004-2015 PLT Design Inc. + * Copyright (c) 2004-2016 PLT Design Inc. * * Copyright (c) 1986 by University of Toronto. * Written by Henry Spencer. Not derived from licensed software. diff --git a/racket/src/racket/src/resolve.c b/racket/src/racket/src/resolve.c index f1bd0fea3b..90b728ac11 100644 --- a/racket/src/racket/src/resolve.c +++ b/racket/src/racket/src/resolve.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -1683,7 +1683,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) /* closures */ /*========================================================================*/ -XFORM_NONGCING int boxmap_size(int n) +XFORM_NONGCING int scheme_boxmap_size(int n) { return ((CLOS_TYPE_BITS_PER_ARG * n) + (BITS_PER_MZSHORT - 1)) / BITS_PER_MZSHORT; } @@ -1693,7 +1693,7 @@ static mzshort *allocate_boxmap(int n) mzshort *boxmap; int size; - size = boxmap_size(n); + size = scheme_boxmap_size(n); boxmap = MALLOC_N_ATOMIC(mzshort, size); memset(boxmap, 0, size * sizeof(mzshort)); @@ -1807,7 +1807,7 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, } } if (at_least_one) { - closure_size += boxmap_size(data->num_params + closure_size); + closure_size += scheme_boxmap_size(data->num_params + closure_size); expanded_already = 1; } else cl->local_type_map = NULL; @@ -1857,7 +1857,7 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, /* Currently, we only need local_type information as a closure type */ if (flags & SCHEME_INFO_TYPED_VAL_MASK) { if (!expanded_already) { - closure_size += boxmap_size(data->num_params + closure_size); + closure_size += scheme_boxmap_size(data->num_params + closure_size); new_closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size); memset(new_closure_map, 0, sizeof(mzshort) * closure_size); memcpy(new_closure_map, closure_map, sizeof(mzshort) * data->closure_size); @@ -1935,7 +1935,7 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, new_size = (captured->count + (has_tl ? 1 : 0)); if (cl->local_type_map || expanded_already || convert_boxes || captured_typed) { need_flags = new_size; - new_size += boxmap_size(data->num_params + new_size); + new_size += scheme_boxmap_size(data->num_params + new_size); expanded_already = 1; } else need_flags = 0; @@ -1978,13 +1978,13 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, if (has_tl || convert_boxes || cl->local_type_map) { int new_boxes_size; int sz; - new_boxes_size = boxmap_size(convert_size + data->num_params + (has_tl ? 1 : 0)); + new_boxes_size = scheme_boxmap_size(convert_size + data->num_params + (has_tl ? 1 : 0)); sz = ((has_tl ? sizeof(mzshort) : 0) + new_boxes_size * sizeof(mzshort)); closure_map = (mzshort *)scheme_malloc_atomic(sz); memset(closure_map, 0, sz); if (convert_boxes) { int bsz; - bsz = boxmap_size(convert_size); + bsz = scheme_boxmap_size(convert_size); memcpy(closure_map XFORM_OK_PLUS (has_tl ? 1 : 0), convert_boxes, bsz * sizeof(mzshort)); @@ -2014,7 +2014,7 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, && expanded_already && !no_map_shift_needed) { /* shift boxmap down, since we're dropping closure elements */ int bsz; - bsz = boxmap_size(data->num_params + offset); + bsz = scheme_boxmap_size(data->num_params + offset); memmove(closure_map + offset, closure_map + data->closure_size, sizeof(mzshort) * bsz); } diff --git a/racket/src/racket/src/salloc.c b/racket/src/racket/src/salloc.c index 2c449cba8a..df8d9fe91c 100644 --- a/racket/src/racket/src/salloc.c +++ b/racket/src/racket/src/salloc.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -1658,6 +1658,13 @@ void scheme_enable_garbage_collection(int on) #endif } +void scheme_incremental_garbage_collection(int on) +{ +#ifdef MZ_PRECISE_GC + GC_set_incremental_mode(on); +#endif +} + MZ_DO_NOT_INLINE(uintptr_t scheme_get_deeper_address(void)); uintptr_t scheme_get_deeper_address(void) diff --git a/racket/src/racket/src/schemef.h b/racket/src/racket/src/schemef.h index ba990ea7cb..76bede83c8 100644 --- a/racket/src/racket/src/schemef.h +++ b/racket/src/racket/src/schemef.h @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt All rights reserved. @@ -464,6 +464,7 @@ MZ_EXTERN void scheme_gc_ptr_ok(void *p); MZ_EXTERN void scheme_collect_garbage(void); MZ_EXTERN void scheme_collect_garbage_minor(void); MZ_EXTERN void scheme_enable_garbage_collection(int on); +MZ_EXTERN void scheme_incremental_garbage_collection(int on); #ifdef MZ_PRECISE_GC # ifndef USE_THREAD_LOCAL diff --git a/racket/src/racket/src/schemex.h b/racket/src/racket/src/schemex.h index 4d95b96eb5..aaf03123f1 100644 --- a/racket/src/racket/src/schemex.h +++ b/racket/src/racket/src/schemex.h @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt All rights reserved. @@ -363,6 +363,7 @@ void (*scheme_gc_ptr_ok)(void *p); void (*scheme_collect_garbage)(void); void (*scheme_collect_garbage_minor)(void); void (*scheme_enable_garbage_collection)(int on); +void (*scheme_incremental_garbage_collection)(int on); #ifdef MZ_PRECISE_GC # ifndef USE_THREAD_LOCAL void **GC_variable_stack; diff --git a/racket/src/racket/src/schemex.inc b/racket/src/racket/src/schemex.inc index 741ff989cc..498a16334c 100644 --- a/racket/src/racket/src/schemex.inc +++ b/racket/src/racket/src/schemex.inc @@ -263,6 +263,7 @@ scheme_extension_table->scheme_collect_garbage = scheme_collect_garbage; scheme_extension_table->scheme_collect_garbage_minor = scheme_collect_garbage_minor; scheme_extension_table->scheme_enable_garbage_collection = scheme_enable_garbage_collection; + scheme_extension_table->scheme_incremental_garbage_collection = scheme_incremental_garbage_collection; #ifdef MZ_PRECISE_GC # ifndef USE_THREAD_LOCAL scheme_extension_table->GC_variable_stack = GC_variable_stack; diff --git a/racket/src/racket/src/schemexm.h b/racket/src/racket/src/schemexm.h index 318cad8505..cfd3512112 100644 --- a/racket/src/racket/src/schemexm.h +++ b/racket/src/racket/src/schemexm.h @@ -263,6 +263,7 @@ #define scheme_collect_garbage (scheme_extension_table->scheme_collect_garbage) #define scheme_collect_garbage_minor (scheme_extension_table->scheme_collect_garbage_minor) #define scheme_enable_garbage_collection (scheme_extension_table->scheme_enable_garbage_collection) +#define scheme_incremental_garbage_collection (scheme_extension_table->scheme_incremental_garbage_collection) #ifdef MZ_PRECISE_GC # ifndef USE_THREAD_LOCAL #define GC_variable_stack (scheme_extension_table->GC_variable_stack) diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index 3f0adea467..2c50dd4b5c 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -14,7 +14,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1135 +#define EXPECTED_PRIM_COUNT 1141 #define EXPECTED_UNSAFE_COUNT 106 #define EXPECTED_FLFXNUM_COUNT 69 #define EXPECTED_EXTFL_COUNT 45 diff --git a/racket/src/racket/src/schnapp.inc b/racket/src/racket/src/schnapp.inc index 31a4fc6d82..c0d1e7f26e 100644 --- a/racket/src/racket/src/schnapp.inc +++ b/racket/src/racket/src/schnapp.inc @@ -60,11 +60,19 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator, t = _SCHEME_TYPE(rator); + if ((t == scheme_proc_chaperone_type) + && SCHEME_VECTORP(((Scheme_Chaperone *)rator)->redirects) + && (SCHEME_VEC_SIZE(((Scheme_Chaperone *)rator)->redirects) & 0x1)) { + if (SCHEME_FALSEP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0])) { + /* No redirection proc (i.e, chaperone is just for properties) */ + rator = ((Scheme_Chaperone *)rator)->prev; + t = _SCHEME_TYPE(rator); + } else + return scheme_apply_chaperone(rator, argc, argv, NULL, PRIM_CHECK_MULTI | (PRIM_CHECK_VALUE << 1)); + } + if (t == scheme_prim_type) { return PRIM_APPLY_NAME_FAST(rator, argc, argv); - } if ((t == scheme_proc_chaperone_type) - && SCHEME_MPAIRP(((Scheme_Chaperone *)rator)->redirects)) { - return scheme_apply_chaperone(rator, argc, argv, NULL, PRIM_CHECK_MULTI | (PRIM_CHECK_VALUE << 1)); } } diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 8da3285bec..22aa6fa1e9 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt All rights reserved. @@ -417,6 +417,7 @@ void scheme_init_exn_config(void); #endif #ifdef WINDOWS_PROCESSES void scheme_init_thread_memory(void); +void scheme_release_process_job_object(void); #endif void scheme_init_module_resolver(void); @@ -455,6 +456,7 @@ extern Scheme_Object *scheme_apply_proc; extern Scheme_Object *scheme_values_func; extern Scheme_Object *scheme_procedure_p_proc; extern Scheme_Object *scheme_procedure_arity_includes_proc; +extern Scheme_Object *scheme_procedure_specialize_proc; extern Scheme_Object *scheme_void_proc; extern Scheme_Object *scheme_void_p_proc; extern Scheme_Object *scheme_syntax_p_proc; @@ -595,6 +597,22 @@ Scheme_Object *scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, + Scheme_Object *key_wraps); +void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val, + Scheme_Object *key_wraps); +Scheme_Bucket *scheme_bucket_or_null_from_table_w_key_wraps(Scheme_Bucket_Table *table, + const char *key, int add, + Scheme_Object *key_wraps); +void scheme_add_to_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key, void *val, + int constant, Scheme_Object *key_wraps); +void *scheme_lookup_in_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key, + Scheme_Object *key_wraps); +Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, + Scheme_Object *key_wraps); +Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val, + Scheme_Object *key_wraps); + /*========================================================================*/ /* thread state and maintenance */ /*========================================================================*/ @@ -755,6 +773,7 @@ struct Scheme_Custodian { int gc_owner_set; Scheme_Object *cust_boxes; int num_cust_boxes, checked_cust_boxes; + int really_doing_accounting; #endif }; @@ -831,6 +850,9 @@ extern Scheme_Object *scheme_parameterization_key; extern Scheme_Object *scheme_exn_handler_key; extern Scheme_Object *scheme_break_enabled_key; +Scheme_Object *scheme_extend_parameterization(int argc, Scheme_Object *args[]); +XFORM_NONGCING int scheme_is_parameter(Scheme_Object *o); + extern void scheme_flatten_config(Scheme_Config *c); extern Scheme_Object *scheme_apply_thread_thunk(Scheme_Object *rator); @@ -2737,7 +2759,7 @@ typedef struct Scheme_Closure_Data XFORM_NONGCING void scheme_boxmap_set(mzshort *boxmap, int j, int bit, int delta); XFORM_NONGCING int scheme_boxmap_get(mzshort *boxmap, int j, int delta); -XFORM_NONGCING int boxmap_size(int n); +XFORM_NONGCING int scheme_boxmap_size(int n); int scheme_has_method_property(Scheme_Object *code); @@ -2780,10 +2802,15 @@ typedef struct Scheme_Native_Closure_Data { /* Thumb code is off by one, need real start for GC */ void *retain_code; #endif + void *eq_key; /* for `procedure-closure-contents-eq?` */ } Scheme_Native_Closure_Data; #define SCHEME_NATIVE_CLOSURE_DATA_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso) +/* This flag is set pre-JIT: */ +#define NATIVE_SPECIALIZED 0x1 +/* Other flags are in "jit.h" */ + typedef struct { Scheme_Object so; Scheme_Native_Closure_Data *code; @@ -2979,6 +3006,8 @@ Scheme_Native_Closure_Data *scheme_generate_case_lambda(Scheme_Case_Lambda *cl); void scheme_delay_load_closure(Scheme_Closure_Data *data); +Scheme_Object *scheme_intdef_bind_identifiers(Scheme_Object *intdef); + #define scheme_add_good_binding(i,v,f) (f->values[i] = v) Scheme_Object *scheme_compiled_void(void); @@ -3713,7 +3742,7 @@ Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, Scheme_Object *shift_to_modidx); Scheme_Object *scheme_modidx_submodule(Scheme_Object *modidx); -Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path); +Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path, int can_cache); #define SCHEME_RMPP(o) (SAME_TYPE(SCHEME_TYPE((o)), scheme_resolved_module_path_type)) #define SCHEME_MODNAMEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type)) @@ -4236,6 +4265,7 @@ void scheme_hash_tree_tie_placeholder(Scheme_Hash_Tree *t, Scheme_Hash_Tree *bas XFORM_NONGCING Scheme_Hash_Tree *scheme_hash_tree_resolve_placeholder(Scheme_Hash_Tree *t); int scheme_hash_tree_kind(Scheme_Hash_Tree *t); XFORM_NONGCING int scheme_eq_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); +XFORM_NONGCING int scheme_eq_hash_tree_subset_match_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); intptr_t scheme_hash_tree_key_hash(Scheme_Hash_Tree *t1); void scheme_set_root_param(int p, Scheme_Object *v); diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index f5551d1d19..9e553a66fd 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.3.0.2" +#define MZSCHEME_VERSION "6.4.0.1" #define MZSCHEME_VERSION_X 6 -#define MZSCHEME_VERSION_Y 3 +#define MZSCHEME_VERSION_Y 4 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/racket/src/racket/src/sema.c b/racket/src/racket/src/sema.c index c0bffa8477..90e9628fc9 100644 --- a/racket/src/racket/src/sema.c +++ b/racket/src/racket/src/sema.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/setjmpup.c b/racket/src/racket/src/setjmpup.c index 27ee9a843f..e69c1eed10 100644 --- a/racket/src/racket/src/setjmpup.c +++ b/racket/src/racket/src/setjmpup.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/sfs.c b/racket/src/racket/src/sfs.c index 8196415d0b..3cc0d7c3cb 100644 --- a/racket/src/racket/src/sfs.c +++ b/racket/src/racket/src/sfs.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -424,13 +424,14 @@ static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, SFS_LOG(printf(" |%d %d %d\n", i + t_min_t, n, info->max_nontail)); info->max_used[i + t_min_t] = n; info->max_calls[i + t_min_t] = info->max_nontail; - } + } else + SCHEME_VEC_ELS(t_vec)[i] = scheme_false; } } } /* If the other branch has last use for something not used in this branch, and if there's a non-tail call in this branch - of later, then we'll have to start with explicit clears. + or later, then we'll have to start with explicit clears. Note that it doesn't matter whether the other branch actually clears them (i.e., the relevant non-tail call might be only in this branch). */ @@ -456,7 +457,7 @@ static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, n = SCHEME_INT_VAL(o); pos = i + t_min_t; at_ip = info->max_used[pos]; - SFS_LOG(printf(" ?%d %d %d\n", pos, n, at_ip)); + SFS_LOG(printf(" ?%d[%d] %d %d\n", pos, i, n, at_ip)); /* is last use in other branch? */ if (((!delta && (at_ip == ip)) || (delta && (at_ip == n)))) { @@ -526,6 +527,25 @@ static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, return tbranch; } +static void sfs_restore_one_branch(SFS_Info *info, int ip, + Scheme_Object *vec, int delta) +{ + int t_min_t, t_cnt, i; + Scheme_Object *t_vec; + + t_vec = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1]; + + if (SCHEME_FALSEP(t_vec)) return; + + t_min_t = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W]); + t_cnt = SCHEME_VEC_SIZE(t_vec); + + for (i = 0; i < t_cnt; i++) { + if (SCHEME_TRUEP(SCHEME_VEC_ELS(t_vec)[i])) + info->max_used[i + t_min_t] = ip; + } +} + static Scheme_Object *sfs_branch(Scheme_Object *o, SFS_Info *info) { Scheme_Branch_Rec *b; @@ -579,6 +599,14 @@ static Scheme_Object *sfs_branch(Scheme_Object *o, SFS_Info *info) info->max_nontail = ip + 1; } + if (info->pass) { + /* Restore "outside" view for both branches, so that + the numbers after `if` for the second pass match + the numbers after the first pass: */ + sfs_restore_one_branch(info, ip, vec, 0); + sfs_restore_one_branch(info, ip, vec, 1); + } + SFS_LOG(printf(" done if: %d %d\n", min_t, max_t)); info->min_touch = min_t; diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index a8da4cf8ae..5191bd96c0 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -331,11 +331,14 @@ "(parameterize((read-case-sensitive #t)" "(read-square-bracket-as-paren #t)" "(read-curly-brace-as-paren #t)" +"(read-square-bracket-with-tag #f)" +"(read-curly-brace-with-tag #f)" "(read-accept-box #t)" "(read-accept-compiled #f)" "(read-accept-bar-quote #t)" "(read-accept-graph #t)" "(read-decimal-as-inexact #t)" +"(read-cdot #f)" "(read-accept-dot #t)" "(read-accept-infix-dot #t)" "(read-accept-quasiquote #t)" @@ -527,7 +530,8 @@ "(not(car a)))))" "(define-values(get-linked-collections)" "(lambda(links-path)" -"(call-with-escape-continuation (lambda(esc)" +"(call-with-escape-continuation" +"(lambda(esc)" "(define-values(make-handler)" "(lambda(ts)" "(lambda(exn)" diff --git a/racket/src/racket/src/startup.rktl b/racket/src/racket/src/startup.rktl index d830a9998c..79320b2e43 100644 --- a/racket/src/racket/src/startup.rktl +++ b/racket/src/racket/src/startup.rktl @@ -391,11 +391,14 @@ (parameterize ([read-case-sensitive #t] [read-square-bracket-as-paren #t] [read-curly-brace-as-paren #t] + [read-square-bracket-with-tag #f] + [read-curly-brace-with-tag #f] [read-accept-box #t] [read-accept-compiled #f] [read-accept-bar-quote #t] [read-accept-graph #t] [read-decimal-as-inexact #t] + [read-cdot #f] [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t] diff --git a/racket/src/racket/src/string.c b/racket/src/racket/src/string.c index 56026cd0f5..07d341c095 100644 --- a/racket/src/racket/src/string.c +++ b/racket/src/racket/src/string.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 840f03cfcf..979d9238ee 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/symbol.c b/racket/src/racket/src/symbol.c index ececb055d9..f40dd0fca4 100644 --- a/racket/src/racket/src/symbol.c +++ b/racket/src/racket/src/symbol.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index 62c5a8b0cb..3af574b018 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 2000-2001 Matthew Flatt This library is free software; you can redistribute it and/or @@ -154,7 +154,8 @@ static void register_traversers(void); XFORM_NONGCING static int is_armed(Scheme_Object *v); static Scheme_Object *add_taint_to_stx(Scheme_Object *o, int *mutate); -static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at); +static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *shifts, + Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at); static Scheme_Object *make_unmarshal_info(Scheme_Object *phase, Scheme_Object *prefix, Scheme_Object *excepts); XFORM_NONGCING static Scheme_Object *extract_unmarshal_phase(Scheme_Object *unmarshal_info); @@ -772,6 +773,13 @@ static int scopes_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b) return (scope_set_count(a) == scope_set_count(b)) && scope_subset(a, b); } +XFORM_NONGCING static int scope_props_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b) +{ + return ((scope_set_count(a) == scope_set_count(b)) + && scheme_eq_hash_tree_subset_match_of((Scheme_Hash_Tree *)a, + (Scheme_Hash_Tree *)b)); +} + static Scheme_Object *make_fallback_pair(Scheme_Object *a, Scheme_Object *b) { a = scheme_make_vector(2, a); @@ -1791,7 +1799,7 @@ int stx_shorts, stx_meds, stx_longs, stx_couldas; # define COUNT_PROPAGATES(x) /* empty */ #endif -static void intern_scope_set(Scheme_Scope_Table *t, int prop_table) +XFORM_NONGCING static void intern_scope_set(Scheme_Scope_Table *t, int prop_table) /* We don't realy intern, but approximate interning by checking against a small set of recently allocated scope sets. That's good enough to find sharing for a deeply nested sequence of `let`s from @@ -1801,16 +1809,20 @@ static void intern_scope_set(Scheme_Scope_Table *t, int prop_table) enough. */ { int i; + Scheme_Scope_Set *s; if (!t->simple_scopes || !scope_set_count(t->simple_scopes)) return; for (i = 0; i < NUM_RECENT_SCOPE_SETS; i++) { - if (recent_scope_sets[prop_table][i]) { - if (recent_scope_sets[prop_table][i] == t->simple_scopes) + s = recent_scope_sets[prop_table][i]; + if (s) { + if (s == t->simple_scopes) + return; + if ((!prop_table && scopes_equal(s, t->simple_scopes)) + || (prop_table && scope_props_equal(s, t->simple_scopes))) { + t->simple_scopes = s; return; - if (scopes_equal(recent_scope_sets[prop_table][i], t->simple_scopes)) { - t->simple_scopes = recent_scope_sets[prop_table][i]; } } } @@ -2643,7 +2655,7 @@ static Scheme_Object *replace_matching_scopes(Scheme_Object *l, Scheme_Scope_Set p = SCHEME_CDR(p); while (c--) { - p = scheme_make_pair(SCHEME_CAR(l), p); + p = scheme_make_mutable_pair(SCHEME_CAR(l), p); l = SCHEME_CDR(l); } @@ -3480,7 +3492,7 @@ char *scheme_stx_describe_context(Scheme_Object *stx, Scheme_Object *phase, int return ""; } -static void add_scopes_mapped_names(Scheme_Scope_Set *scopes, Scheme_Hash_Table *mapped) +static void add_scopes_mapped_names(Scheme_Scope_Set *scopes, Scheme_Object *shifts, Scheme_Hash_Table *mapped) { int retry; Scheme_Hash_Tree *ht; @@ -3543,7 +3555,7 @@ static void add_scopes_mapped_names(Scheme_Scope_Set *scopes, Scheme_Hash_Table pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); if (PES_UNMARSHAL_DESCP(pes)) { if (SCHEME_TRUEP(SCHEME_VEC_ELS(pes)[0])) { - unmarshal_module_context_additions(NULL, pes, binding_scopes, l); + unmarshal_module_context_additions(NULL, shifts, pes, binding_scopes, l); retry = 1; } } else { @@ -3640,7 +3652,7 @@ static Scheme_Object *do_stx_lookup(Scheme_Stx *stx, Scheme_Scope_Set *scopes, /* Need unmarshal --- but only if the scope set is relevant */ if (scope_subset(binding_scopes, scopes)) { /* unmarshal and note that we must restart */ - unmarshal_module_context_additions(stx, pes, binding_scopes, l); + unmarshal_module_context_additions(stx, NULL, pes, binding_scopes, l); invalid = 1; /* Shouldn't encounter this on a second pass: */ STX_ASSERT(!check_subset); @@ -4278,7 +4290,9 @@ Scheme_Object *scheme_module_context_inspector(Scheme_Object *mc) void scheme_module_context_add_mapped_symbols(Scheme_Object *mc, Scheme_Hash_Table *mapped) { - add_scopes_mapped_names(scheme_module_context_scopes(mc), mapped); + add_scopes_mapped_names(scheme_module_context_scopes(mc), + SCHEME_VEC_ELS(mc)[3], /* list of shifts */ + mapped); } Scheme_Object *scheme_module_context_at_phase(Scheme_Object *mc, Scheme_Object *phase) @@ -4679,6 +4693,9 @@ static Scheme_Object *unmarshal_lookup_adjust(Scheme_Object *sym, Scheme_Object Scheme_Hash_Tree *excepts; Scheme_Object *prefix; + if (!SCHEME_SYMBOLP(sym)) + return scheme_false; + excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); @@ -4736,7 +4753,8 @@ static Scheme_Object *unmarshal_key_adjust(Scheme_Object *sym, Scheme_Object *pe return sym; } -static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at) +static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *shifts, + Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at) { Scheme_Object *req_modidx, *modidx, *unmarshal_info, *context, *src_phase, *pt_phase, *bind_phase; Scheme_Object *insp, *req_insp; @@ -4746,14 +4764,10 @@ static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *v insp = SCHEME_VEC_ELS(vec)[3]; req_insp = insp; - if (stx) { + if (stx) modidx = apply_modidx_shifts(stx->shifts, req_modidx, &insp, &export_registry); - } else { - modidx = req_modidx; - export_registry = NULL; - insp = scheme_false; - req_insp = scheme_false; - } + else + modidx = apply_modidx_shifts(shifts, req_modidx, &insp, &export_registry); src_phase = SCHEME_VEC_ELS(vec)[1]; unmarshal_info = SCHEME_VEC_ELS(vec)[2]; @@ -6707,6 +6721,8 @@ Scheme_Scope_Set *list_to_scope_set(Scheme_Object *l, Scheme_Unmarshal_Tables *u Scheme_Scope_Set *scopes = NULL; Scheme_Object *r = scheme_null, *scope; + if (scheme_proper_list_length(l) < 0) return_NULL; + while (!SCHEME_NULLP(l)) { if (!SCHEME_PAIRP(l)) return_NULL; scopes = (Scheme_Scope_Set *)scheme_hash_get_either(ut->rns, ut->current_rns, l); @@ -6798,6 +6814,8 @@ Scheme_Object *unmarshal_multi_scopes(Scheme_Object *multi_scopes, if (SCHEME_FALLBACKP(l)) l = SCHEME_FALLBACK_FIRST(l); + if (scheme_proper_list_length(l) < 0) return_NULL; + l_first = scheme_null; l_last = NULL; for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { @@ -7988,12 +8006,10 @@ Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) } else m2 = NULL; - if (!m2) { + if (!m2 && !SCHEME_FALSEP(src)) { src = scheme_stx_lookup_w_nominal(argv[1], phase, 1, NULL, NULL, &m2, NULL, NULL, NULL, NULL, NULL); - if (SCHEME_FALSEP(src)) - m2 = NULL; } if (m2) { diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 8957fe383b..e06c1c27c5 100644 --- a/racket/src/racket/src/thread.c +++ b/racket/src/racket/src/thread.c @@ -191,7 +191,6 @@ THREAD_LOCAL_DECL(MZ_MARK_POS_TYPE scheme_current_cont_mark_pos); THREAD_LOCAL_DECL(int scheme_semaphore_fd_kqueue); THREAD_LOCAL_DECL(static Scheme_Custodian *main_custodian); -THREAD_LOCAL_DECL(static Scheme_Custodian *last_custodian); THREAD_LOCAL_DECL(static Scheme_Hash_Table *limited_custodians = NULL); READ_ONLY static Scheme_Object *initial_inspector; @@ -223,7 +222,7 @@ THREAD_LOCAL_DECL(static double end_this_gc_real_time); static void get_ready_for_GC(void); static void done_with_GC(void); #ifdef MZ_PRECISE_GC -static void inform_GC(int master_gc, int major_gc, intptr_t pre_used, intptr_t post_used, +static void inform_GC(int master_gc, int major_gc, int inc_gc, intptr_t pre_used, intptr_t post_used, intptr_t pre_admin, intptr_t post_admin, intptr_t post_child_places_used); #endif @@ -391,7 +390,6 @@ static Scheme_Object *parameter_p(int argc, Scheme_Object *args[]); static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object *args[]); static Scheme_Object *make_parameter(int argc, Scheme_Object *args[]); static Scheme_Object *make_derived_parameter(int argc, Scheme_Object *args[]); -static Scheme_Object *extend_parameterization(int argc, Scheme_Object *args[]); static Scheme_Object *parameterization_p(int argc, Scheme_Object *args[]); static Scheme_Object *reparameterize(int argc, Scheme_Object **argv); @@ -708,7 +706,7 @@ void scheme_init_paramz(Scheme_Env *env) scheme_add_global_constant("parameterization-key" , scheme_parameterization_key, newenv); scheme_add_global_constant("break-enabled-key" , scheme_break_enabled_key , newenv); - GLOBAL_PRIM_W_ARITY("extend-parameterization" , extend_parameterization , 1, -1, newenv); + GLOBAL_PRIM_W_ARITY("extend-parameterization" , scheme_extend_parameterization , 1, -1, newenv); GLOBAL_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, newenv); GLOBAL_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, newenv); GLOBAL_PRIM_W_ARITY("make-custodian-from-main", make_custodian_from_main, 0, 0, newenv); @@ -1085,8 +1083,6 @@ static void adjust_custodian_family(void *mgr, void *skip_move) /* Remove from global list: */ if (CUSTODIAN_FAM(r->global_next)) CUSTODIAN_FAM(CUSTODIAN_FAM(r->global_next)->global_prev) = CUSTODIAN_FAM(r->global_prev); - else - last_custodian = CUSTODIAN_FAM(r->global_prev); CUSTODIAN_FAM(CUSTODIAN_FAM(r->global_prev)->global_next) = CUSTODIAN_FAM(r->global_next); /* Add children to parent's list: */ @@ -1160,8 +1156,6 @@ void insert_custodian(Scheme_Custodian *m, Scheme_Custodian *parent) CUSTODIAN_FAM(parent->global_next) = m; if (next) CUSTODIAN_FAM(next->global_prev) = m; - else - last_custodian = m; } else { CUSTODIAN_FAM(m->global_next) = NULL; CUSTODIAN_FAM(m->global_prev) = NULL; @@ -7633,7 +7627,7 @@ static Scheme_Object *parameterization_p(int argc, Scheme_Object **argv) && ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK) \ == SCHEME_PRIM_TYPE_PARAMETER)) -static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[]) +Scheme_Object *scheme_extend_parameterization(int argc, Scheme_Object *argv[]) { Scheme_Object *key, *a[2], *param; Scheme_Config *c; @@ -7719,13 +7713,16 @@ static Scheme_Object *reparameterize(int argc, Scheme_Object **argv) return (Scheme_Object *)naya; } -static Scheme_Object *parameter_p(int argc, Scheme_Object **argv) +int scheme_is_parameter(Scheme_Object *v) { - Scheme_Object *v = argv[0]; - if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); - return (SCHEME_PARAMETERP(v) + return SCHEME_PARAMETERP(v); +} + +static Scheme_Object *parameter_p(int argc, Scheme_Object **argv) +{ + return (scheme_is_parameter(argv[0]) ? scheme_true : scheme_false); } @@ -7977,18 +7974,20 @@ static void make_initial_config(Scheme_Thread *p) init_param(cells, paramz, MZCONFIG_CURLY_BRACES_ARE_PARENS, (scheme_curly_braces_are_parens ? scheme_true : scheme_false)); + init_param(cells, paramz, MZCONFIG_SQUARE_BRACKETS_ARE_TAGGED, scheme_false); + init_param(cells, paramz, MZCONFIG_CURLY_BRACES_ARE_TAGGED, scheme_false); + init_param(cells, paramz, MZCONFIG_READ_CDOT, scheme_false); + init_param(cells, paramz, MZCONFIG_ERROR_PRINT_WIDTH, scheme_make_integer(256)); init_param(cells, paramz, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, scheme_make_integer(16)); init_param(cells, paramz, MZCONFIG_ERROR_PRINT_SRCLOC, scheme_true); REGISTER_SO(main_custodian); - REGISTER_SO(last_custodian); REGISTER_SO(limited_custodians); main_custodian = scheme_make_custodian(NULL); #ifdef MZ_PRECISE_GC GC_register_root_custodian(main_custodian); #endif - last_custodian = main_custodian; init_param(cells, paramz, MZCONFIG_CUSTODIAN, (Scheme_Object *)main_custodian); REGISTER_SO(initial_plumber); @@ -8319,8 +8318,10 @@ static Scheme_Object *make_phantom_bytes(int argc, Scheme_Object *argv[]) pb->size = SCHEME_INT_VAL(argv[0]); # ifdef MZ_PRECISE_GC - if (!GC_allocate_phantom_bytes(pb, pb->size)) + if (!GC_allocate_phantom_bytes(pb, pb->size)) { + pb->size = 0; scheme_raise_out_of_memory("make-phantom-bytes", NULL); + } # endif return (Scheme_Object *)pb; @@ -8330,6 +8331,9 @@ static Scheme_Object *set_phantom_bytes(int argc, Scheme_Object *argv[]) { Scheme_Phantom_Bytes *pb; intptr_t amt; +# ifdef MZ_PRECISE_GC + intptr_t old_size; +# endif if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_phantom_bytes_type)) scheme_wrong_contract("set-phantom-bytes!", "phantom-bytes?", 0, argc, argv); @@ -8340,12 +8344,18 @@ static Scheme_Object *set_phantom_bytes(int argc, Scheme_Object *argv[]) amt = SCHEME_INT_VAL(argv[1]); # ifdef MZ_PRECISE_GC - if (!GC_allocate_phantom_bytes(pb, amt - pb->size)) - scheme_raise_out_of_memory("make-phantom-bytes", NULL); -# endif + old_size = pb->size; +#endif pb->size = amt; +# ifdef MZ_PRECISE_GC + if (!GC_allocate_phantom_bytes(pb, amt - old_size)) { + pb->size = old_size; + scheme_raise_out_of_memory("make-phantom-bytes", NULL); + } +# endif + return scheme_void; } @@ -9246,7 +9256,7 @@ static char *gc_num(char *nums, intptr_t v) END_XFORM_SKIP; #endif -static void inform_GC(int master_gc, int major_gc, +static void inform_GC(int master_gc, int major_gc, int inc_gc, intptr_t pre_used, intptr_t post_used, intptr_t pre_admin, intptr_t post_admin, intptr_t post_child_places_used) @@ -9276,7 +9286,9 @@ static void inform_GC(int master_gc, int major_gc, vec = scheme_false; if (!master_gc && gc_info_prefab) { vec = scheme_make_vector(11, scheme_false); - SCHEME_VEC_ELS(vec)[1] = (major_gc ? scheme_true : scheme_false); + SCHEME_VEC_ELS(vec)[1] = (major_gc + ? major_symbol + : (inc_gc ? incremental_symbol : minor_symbol)); SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(pre_used); SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(pre_admin); SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(scheme_code_page_total); @@ -9305,7 +9317,7 @@ static void inform_GC(int master_gc, int major_gc, #ifdef MZ_USE_PLACES scheme_current_place_id, #endif - (master_gc ? "MST" : (major_gc ? "MAJ" : "min")), + (master_gc ? "MST" : (major_gc ? "MAJ" : (inc_gc ? "mIn" : "min"))), gc_num(nums, pre_used), gc_num(nums, pre_admin - pre_used), gc_num(nums, scheme_code_page_total), gc_num(nums, delta), ((admin_delta < 0) ? "" : "+"), gc_num(nums, admin_delta), diff --git a/racket/src/racket/src/type.c b/racket/src/racket/src/type.c index a4ab0285a7..27ac99a182 100644 --- a/racket/src/racket/src/type.c +++ b/racket/src/racket/src/type.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/validate.c b/racket/src/racket/src/validate.c index e6b7640c89..3edcfe0d40 100644 --- a/racket/src/racket/src/validate.c +++ b/racket/src/racket/src/validate.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/racket/src/vector.c b/racket/src/racket/src/vector.c index ddaf1c8adb..4f58f759ff 100644 --- a/racket/src/racket/src/vector.c +++ b/racket/src/racket/src/vector.c @@ -1,6 +1,6 @@ /* Racket - Copyright (c) 2004-2015 PLT Design Inc. + Copyright (c) 2004-2016 PLT Design Inc. Copyright (c) 1995-2001 Matthew Flatt This library is free software; you can redistribute it and/or diff --git a/racket/src/worksp/README b/racket/src/worksp/README index eddefb2230..fe3f96f6bc 100644 --- a/racket/src/worksp/README +++ b/racket/src/worksp/README @@ -121,7 +121,7 @@ supply them in binary form. The DLLs are distributed in packages, but they are also available from - https://github.com/plt/libs + https://github.com/racket/libs and they must be installed into diff --git a/racket/src/worksp/gracket/gracket.rc b/racket/src/worksp/gracket/gracket.rc index 4285e87b35..a540f0f4fa 100644 --- a/racket/src/worksp/gracket/gracket.rc +++ b/racket/src/worksp/gracket/gracket.rc @@ -43,7 +43,7 @@ BEGIN VALUE "FileDescription", "Racket GUI application\0" VALUE "InternalName", "GRacket\0" VALUE "FileVersion", MZSCHEME_VERSION "\0" - VALUE "LegalCopyright", "Copyright 1995-2015 PLT Design Inc.\0" + VALUE "LegalCopyright", "Copyright 1995-2016 PLT Design Inc.\0" VALUE "OriginalFilename", "GRacket.exe\0" VALUE "ProductName", "Racket\0" VALUE "ProductVersion", MZSCHEME_VERSION "\0" diff --git a/racket/src/worksp/mzcom/mzcom.rc b/racket/src/worksp/mzcom/mzcom.rc index 4f5554d967..772d1cc57a 100644 --- a/racket/src/worksp/mzcom/mzcom.rc +++ b/racket/src/worksp/mzcom/mzcom.rc @@ -58,7 +58,7 @@ BEGIN VALUE "FileDescription", "MzCOM Module" VALUE "FileVersion", MZSCHEME_VERSION "\0" VALUE "InternalName", "MzCOM" - VALUE "LegalCopyright", "Copyright 2000-2015 PLT Design Inc." + VALUE "LegalCopyright", "Copyright 2000-2016 PLT Design Inc." VALUE "OriginalFilename", "MzCOM.EXE" VALUE "ProductName", "MzCOM Module" VALUE "ProductVersion", MZSCHEME_VERSION "\0" diff --git a/racket/src/worksp/racket/racket.rc b/racket/src/worksp/racket/racket.rc index 9bbc8a1fe7..284a817679 100644 --- a/racket/src/worksp/racket/racket.rc +++ b/racket/src/worksp/racket/racket.rc @@ -43,7 +43,7 @@ BEGIN VALUE "FileDescription", "Racket application\0" VALUE "InternalName", "Racket\0" VALUE "FileVersion", MZSCHEME_VERSION "\0" - VALUE "LegalCopyright", "Copyright 1995-2015 PLT Design Inc.\0" + VALUE "LegalCopyright", "Copyright 1995-2016 PLT Design Inc.\0" VALUE "OriginalFilename", "racket.exe\0" VALUE "ProductName", "Racket\0" VALUE "ProductVersion", MZSCHEME_VERSION "\0" diff --git a/racket/src/worksp/starters/start.rc b/racket/src/worksp/starters/start.rc index cfec867857..48ff60773c 100644 --- a/racket/src/worksp/starters/start.rc +++ b/racket/src/worksp/starters/start.rc @@ -51,7 +51,7 @@ BEGIN #ifdef MZSTART VALUE "InternalName", "mzstart\0" #endif - VALUE "LegalCopyright", "Copyright 1996-2015 PLT Design Inc.\0" + VALUE "LegalCopyright", "Copyright 1996-2016 PLT Design Inc.\0" #ifdef MRSTART VALUE "OriginalFilename", "MrStart.exe\0" #endif