Compare commits
No commits in common. "docs-upgrading" and "master" have entirely different histories.
docs-upgra
...
master
3
.gitignore
vendored
3
.gitignore
vendored
|
|
@ -24,9 +24,6 @@ compiled/
|
|||
.DS_Store
|
||||
*.bak
|
||||
TAGS
|
||||
*.swn
|
||||
*.swo
|
||||
*.swp
|
||||
|
||||
# generated by patch
|
||||
*.orig
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@ before_script:
|
|||
script:
|
||||
- make CPUS="2" PKGS="racket-test db-test unstable-flonum-lib net-test" CONFIGURE_ARGS_qq="$RACKET_CONFIGURE_ARGS"
|
||||
- raco test -l tests/racket/test
|
||||
- racket -l tests/pkg/test -- -q
|
||||
- racket -l tests/racket/contract/all
|
||||
- raco test -l tests/json/json
|
||||
- raco test -l tests/file/main
|
||||
|
|
@ -45,7 +46,6 @@ script:
|
|||
- raco test -l tests/zo-path
|
||||
- raco test -l tests/xml/test
|
||||
- raco test -l tests/db/all-tests
|
||||
- raco test -c tests/stxparse
|
||||
notifications:
|
||||
irc: chat.freenode.net#racket-dev
|
||||
email:
|
||||
|
|
@ -56,5 +56,3 @@ notifications:
|
|||
on_success: change
|
||||
slack:
|
||||
secure: A19kphrabQHO8TU6qZcBaLQxdSNpm1ypEtbQsh8Ucg6HYPP7y1q7O7JZEndoMRHE9CNKZ9oXQzqR8H1IFVTlnjFFIJfkZzZ1YSNk4abSomhpWCq9daKMfwlcuTtY6PeI1nDVpka4/hiJGn9qzmaKYXle9Sl4CX2VEYp8o8PgMEs=
|
||||
rooms:
|
||||
secure: FsKzp4ItmOqd/YxqgsElgfjGW2/TU03p2p3ss+PQl/pKDQNnR/2b4pWCQ7GuqYibkmtiH1jYwrnuaLN4Cc+JyN7Z+zUtO4VSORsh3zt/gTsfgphMpCP6cB4sTqUh6AWsZOgzikj+fh7ORHEXVswQwlRHErTgZVEdEkWHBh4UWzc=
|
||||
|
|
|
|||
358
INSTALL.txt
358
INSTALL.txt
|
|
@ -40,43 +40,35 @@ If you stick with this repository, then you have several options:
|
|||
|
||||
* Minimal --- as described in the "src" subdirectory of "racket"
|
||||
(i.e., ignore this directory and "pkgs"). You can build a minimal
|
||||
Racket using the usual `configure && make && make install` steps
|
||||
Racket using the usual `configure && make && make install' steps
|
||||
(or similar for Windows), and then you can install packages from
|
||||
the catalog server with `raco pkg`.
|
||||
the catalog server with `raco pkg'.
|
||||
|
||||
* Installers --- create installers for a variety of platforms by
|
||||
farming out work to machines that run those platforms. This is the
|
||||
way that Racket snapshots and releases are created, and you can
|
||||
create your own. See "Building Installers" below.
|
||||
|
||||
* In-place Racket-on-Chez build --- when you use `make cs`. Unless
|
||||
you use various options described in "More Instructions: Building
|
||||
Racket-on-Chez" below, this process downloads Chez Scheme from
|
||||
Github, builds a traditional `racket` with minimal packages, builds
|
||||
Chez Scheme, and then builds Racket-on-Chez using Racket and Chez
|
||||
Scheme. Final executables that end in "cs" or "CS" are the
|
||||
Racket-on-Chez variants.
|
||||
|
||||
|
||||
Quick Instructions: In-place Build
|
||||
==================================
|
||||
|
||||
On Unix (including Linux) and Mac OS, `make` (or `make in-place`)
|
||||
On Unix (including Linux) and Mac OS X, `make' (or `make in-place')
|
||||
creates a build in the "racket" directory.
|
||||
|
||||
On Windows with Microsoft Visual Studio (any version between 2008/9.0
|
||||
and 2015/14.0), `nmake win32-in-place` creates a build in the "racket"
|
||||
and 2015/14.0), `nmake win32-in-place' creates a build in the "racket"
|
||||
directory. For information on configuring your command-line
|
||||
environment for Visual Studio, see "racket/src/worksp/README".
|
||||
|
||||
On Windows with MinGW, `make PLAIN_RACKET=racket/racket`, since MinGW
|
||||
On Windows with MinGW, `make PLAIN_RACKET=racket/racket', since MinGW
|
||||
uses Unix-style tools but generates a Windows-layout Racket build.
|
||||
|
||||
In all cases, an in-place build includes (via links) a few packages
|
||||
that are in the "pkgs" directory. To get new versions of those
|
||||
packages, as well as the Racket core, then use `git pull`. Afterward,
|
||||
or to get new versions of any other package, use `make in-place`
|
||||
again, which includes a `raco pkg update` step.
|
||||
packages, as well as the Racket core, then use `git pull'. Afterward,
|
||||
or to get new versions of any other package, use `make in-place'
|
||||
again, which includes a `raco pkg update' step.
|
||||
|
||||
See "More Instructions: Building Racket" below for more information.
|
||||
|
||||
|
|
@ -84,21 +76,21 @@ See "More Instructions: Building Racket" below for more information.
|
|||
Quick Instructions: Unix-style Install
|
||||
======================================
|
||||
|
||||
On Unix (including Linux), `make unix-style PREFIX=<dir>` builds and
|
||||
On Unix (including Linux), `make unix-style PREFIX=<dir>' builds and
|
||||
installs into "<dir>" (which must be an absolute path) with binaries
|
||||
in "<dir>/bin", packages in "<dir>/share/racket/pkgs", documentation
|
||||
in "<dir>/share/racket/doc", etc.
|
||||
|
||||
On Mac OS, `make unix-style PREFIX=<dir>` builds and installs into
|
||||
"<dir>" (which must be an absolute path) with binaries in "<dir>/bin",
|
||||
packages in "<dir>/share/pkgs", documentation in "<dir>/doc", etc.
|
||||
On Mac OS X, `make unix-style PREFIX=<dir>' builds and installs into
|
||||
"<dir>" (whichmust be an absolute path) with binaries in "<dir>/bin",
|
||||
packges in "<dir>/share/pkgs", documentation in "<dir>/doc", etc.
|
||||
|
||||
On Windows, Unix-style install is not supported.
|
||||
|
||||
A Unix-style install leaves no reference to this source directory.
|
||||
|
||||
To split the build and install steps of a Unix-style installation,
|
||||
supply `DESTDIR=<dest-dir>` with `make unix-style PREFIX=<dir>`, which
|
||||
supply `DESTDIR=<dest-dir>' with `make unix-style PREFIX=<dir>', which
|
||||
assembles the installation in "<dest-dir>" (which must be an absolute
|
||||
path). Then, copy the content of "<dest-dir>" to the target root
|
||||
"<dir>".
|
||||
|
|
@ -110,33 +102,33 @@ More Instructions: Building Racket
|
|||
==================================
|
||||
|
||||
The "racket" directory contains minimal Racket, which is just enough
|
||||
to run `raco pkg` to install everything else. The first step of `make
|
||||
in-place` or `make unix-style` is to build minimal Racket, and you can
|
||||
to run `raco pkg' to install everything else. The first step of `make
|
||||
in-place' or `make unix-style' is to build minimal Racket, and you can
|
||||
read "racket/src/README" for more information.
|
||||
|
||||
If you would like to provide arguments to `configure` for the minimal
|
||||
If you would like to provide arguments to `configure' for the minimal
|
||||
Racket build, then you can supply them with by adding
|
||||
`CONFIGURE_ARGS_qq="..."` to `make in-place` or `make
|
||||
unix-style`. (The `_qq` suffix on the variable name is a convention
|
||||
`CONFIGURE_ARGS_qq="..."' to `make in-place' or `make
|
||||
unix-style'. (The `_qq' suffix on the variable name is a convention
|
||||
that indicates that single- and double-quote marks are allowed in the
|
||||
value.)
|
||||
|
||||
The "pkgs" directory contains packages that are tied to the Racket
|
||||
core implementation and are therefore kept in the same Git
|
||||
repository. A `make in-place` links to the package in-place, while
|
||||
`make unix-style` copies packages out of "pkgs" to install them.
|
||||
repository. A `make in-place' links to the package in-place, while
|
||||
`make unix-style' copies packages out of "pkgs" to install them.
|
||||
|
||||
To install a subset of the packages in "pkgs", supply `PKGS` value to
|
||||
`make`. For example,
|
||||
To install a subset of the packages in "pkgs", supply `PKGS' value to
|
||||
`make'. For example,
|
||||
|
||||
make PKGS="gui-lib readline-lib"
|
||||
|
||||
links only the "gui-lib" and "readline-lib" packages and their
|
||||
dependencies. The default value of `PKGS` is "main-distribution
|
||||
main-distribution-test". If you run `make` a second time, all
|
||||
dependencies. The default value of `PKGS' is "main-distribution
|
||||
main-distribution-test". If you run `make' a second time, all
|
||||
previously installed packages remain installed and are updated, while
|
||||
new packages are added. To uninstall previously selected package, use
|
||||
`raco pkg remove`.
|
||||
`raco pkg remove'.
|
||||
|
||||
To build anything other than the latest sources in the repository
|
||||
(e.g., when building from the "v6.2.1" tag), you need a catalog
|
||||
|
|
@ -144,69 +136,40 @@ that's compatible with those sources. Note that a release distribution
|
|||
is configured to use a catalog specific to that release, so you can
|
||||
extract the catalog's URL from there.
|
||||
|
||||
Using `make` (or `make in-place`) sets the installation's name to
|
||||
Using `make' (or `make in-place') sets the installation's name to
|
||||
"development", unless the installation has been previously configured
|
||||
(i.e., unless the "racket/etc/config.rktd" file exists). The
|
||||
installation name affects, for example, the directory where
|
||||
user-specific documentation is installed. Using `make` also sets the
|
||||
default package scope to `installation`, which means that
|
||||
packages are installed by default into the installation's space instead
|
||||
user-specific documentation is installed. Using `make' also sets the
|
||||
default package scope is set to `installation', which means that
|
||||
package are installed by default into the installation's space instead
|
||||
of user-specific space. The name and/or default-scope configuration
|
||||
can be changed through `raco pkg config`.
|
||||
can be changed through `raco pkg config'.
|
||||
|
||||
Note that `make -j <n>` controls parallelism for the makefile part of
|
||||
a build, but not for the `raco setup` part. To control both the
|
||||
makefile and the `raco setup` part, use
|
||||
Note that `make -j <n>' controls parallelism for the makefile part of
|
||||
a build, but not for the `raco setup' part. To control both the
|
||||
makefile and the `raco setup' part, use
|
||||
|
||||
make CPUS=<n>
|
||||
|
||||
which recurs with `make -j <n> JOB_OPTIONS="-j <n>"`. Setting `CPUS`
|
||||
also works with `make unix-style`.
|
||||
which recurs with `make -j <n> JOB_OPTIONS="-j <n>"'. Setting `CPUS'
|
||||
also works with `make unix-style'.
|
||||
|
||||
Use `make as-is` (or `nmake win32-as-is`) to perform the same build
|
||||
Use `make as-is' (or `nmake win32-as-is') to perform the same build
|
||||
actions as `make in-place`, but without consulting any package
|
||||
catalogs or package sources to install or update packages. In other
|
||||
words, use `make as-is` to rebuild after local changes that could
|
||||
words, use `make as-is' to rebuild after local changes that could
|
||||
include changes to the Racket core. (If you change only packages, then
|
||||
`raco setup` should suffice.)
|
||||
`raco setup' should suffice.)
|
||||
|
||||
If you need even more control over the build, carry on to "Even More
|
||||
Instructions: Building Racket Pieces" further below.
|
||||
|
||||
|
||||
More Instructions: Building Racket-on-Chez
|
||||
==========================================
|
||||
|
||||
The `make cs` target (or `make cs-as-is` for a rebuild, or `nmake
|
||||
win32-cs` on Windows with Visual Studio) builds an experimental
|
||||
variant of Racket that runs on Chez Scheme. The executables for the
|
||||
Racket-on-Chez variant all have a "cs" or "CS" suffix, so they coexist
|
||||
with a traditional Racket build. (One day, if the experiment goes
|
||||
well, there will be an option or default to build Racket-on-Chez as
|
||||
`racket` instead of `racketcs`.)
|
||||
|
||||
Building Racket-on-Chez requires an existing Racket and Chez Scheme.
|
||||
If you use `make cs` with no further arguments, then the build process
|
||||
will bootstrap by building a traditional variant of Racket and by
|
||||
downloading and building Chez Scheme.
|
||||
|
||||
If you have a sufficiently recent Racket installation already with at
|
||||
least the "compiler-lib" and "parser-tools-libs" packages installed,
|
||||
you can supply `RACKET=...` with `make cs` to skip that part of the
|
||||
bootstrap. And if you have a Chez Scheme source directory already[*],
|
||||
you can supply that with `SCHEME_SRC=...` instead of downloading a new
|
||||
copy.
|
||||
|
||||
make cs RACKET=racket SCHEME_SRC=path/to/ChezScheme
|
||||
|
||||
[*] For now, RacketCS requires the variant of Chez Scheme at
|
||||
https://github.com/mflatt/ChezScheme
|
||||
Instructions: Building Racket Pieces".
|
||||
|
||||
|
||||
Even More Instructions: Building Racket Pieces
|
||||
==============================================
|
||||
|
||||
Instead of just using `make in-place` or `make unix-style`, you can
|
||||
Instead of just using `make in-place' or `make unix-style', you can
|
||||
take more control over the build by understand how the pieces fit
|
||||
together.
|
||||
|
||||
|
|
@ -218,29 +181,25 @@ and follow the "README" there, which gives you more configuration
|
|||
options.
|
||||
|
||||
If you don't want any special configuration and you just want the base
|
||||
build, you can use `make base` (or `nmake win32-base`) with the
|
||||
build, you can use `make base' (or `nmake win32-base') with the
|
||||
top-level makefile.
|
||||
|
||||
Minimal Racket does not require additional native libraries to run,
|
||||
but under Windows, encoding-conversion, extflonum, and SSL
|
||||
functionality is hobbled until native libraries from the
|
||||
`racket-win32-i386` or `racket-win32-x86_64` package are installed.
|
||||
`racket-win32-i386' or `racket-win32-x86_64' package are installed.
|
||||
|
||||
On all platforms, fom the top-level makefile, `JOB_OPTIONS` as a
|
||||
makefile variable and `PLT_SETUP_OPTIONS` as an environment variable
|
||||
are passed on to the `raco setup` that is used to build minimal-Racket
|
||||
libraries. See the documentation for `raco setup` for information on
|
||||
On all platforms, fom the top-level makefile, `JOB_OPTIONS' as a
|
||||
makefile variable and `PLT_SETUP_OPTIONS' as an environment variable
|
||||
are passed on to the `raco setup' that is used to build minimal-Racket
|
||||
libraries. See the documentation for `raco setup' for information on
|
||||
the options.
|
||||
|
||||
For cross compilation, add configuration options to
|
||||
`CONFIGURE_ARGS_qq="..."` as described in the "README" of
|
||||
"racket/src", but also add a `PLAIN_RACKET=...` argument for the
|
||||
top-level makefile to specify the same executable as in an
|
||||
`--enable-racket=...` for `configure`. In general, the `PLAIN_RACKET`
|
||||
setting should have the form `PLAIN_RACKET="... -C"` to ensure that
|
||||
cross-compilation mode is used and that any foreign libraries needed
|
||||
for build time can be found, but many cross-compilation scenarios work
|
||||
without `-C`.
|
||||
`CONFIGURE_ARGS_qq="..."' as descibed in the "README" of "racket/src",
|
||||
but also add a `PLAIN_RACKET=...' argument for the top-level makefile
|
||||
to specify the same executable as in an `--enable-racket=...' for
|
||||
`configure'.
|
||||
|
||||
Installing Packages
|
||||
-------------------
|
||||
|
|
@ -250,15 +209,15 @@ packages via the package-catalog server, completely ignoring the
|
|||
content of "pkgs".
|
||||
|
||||
If you want to install packages manually out of the "pkgs" directory,
|
||||
the `local-catalog` target creates a catalog as "racket/local/catalog"
|
||||
the `local-catalog' target creates a catalog as "racket/local/catalog"
|
||||
that merges the currently configured catalog's content with pointers
|
||||
to the packages in "pkgs". A Unix-style build works that way: it
|
||||
builds and installs minimal Racket, and then it installs packages out
|
||||
of a catalog that is created by `make local-catalog`.
|
||||
builds and installs minimal Racket, and then it installs packags out
|
||||
of a catalog that is created by `make local-catalog'.
|
||||
|
||||
To add a package catalog that is used after the content of "pkgs" but
|
||||
before the default package catalogs, specify the catalog's URL as the
|
||||
`SRC_CATALOG` makefile variable:
|
||||
`SRC_CATALOG' makefile variable:
|
||||
|
||||
make .... SRC_CATALOG=<url>
|
||||
|
||||
|
|
@ -266,19 +225,19 @@ Linking Packages for In-place Development Mode
|
|||
----------------------------------------------
|
||||
|
||||
With an in-place build, you can edit packages within "pkgs" directly
|
||||
or update those packages with `git pull` plus `raco setup`, since the
|
||||
or update those packages with `git pull' plus `raco setup', since the
|
||||
packages are installed with the equivalent of `raco pkg install -i
|
||||
--static-link ...`.
|
||||
--static-link ...'.
|
||||
|
||||
Instead of actually using `raco pkg install --static-link ...`, the
|
||||
`pkgs-catalog` makefile target creates a catalog that points to the
|
||||
`pkgs-catalog' makefile target creates a catalog that points to the
|
||||
packages in "pkgs", and the catalog indicates that the packages are to
|
||||
be installed as links. The `pkgs-catalog` target further configures
|
||||
be installed as links. The `pkgs-catalog' target further configures
|
||||
the new catalog as the first one to check when installing
|
||||
packages. The configuration adjustment is made only if no
|
||||
configuration file "racket/etc/config.rktd" exists already.
|
||||
|
||||
All other packages (as specified by `PKGS`) are installed via the
|
||||
All other packages (as specified by `PKGS') are installed via the
|
||||
configured package catalog. They are installed in installation scope, but
|
||||
the content of "racket/share/pkgs" is not meant to be edited. To
|
||||
reinstall a package in a mode suitable for editing and manipulation
|
||||
|
|
@ -294,7 +253,7 @@ The Whole Enchilada: Building Installers
|
|||
========================================
|
||||
|
||||
To build installers that can be distributed to other users, do not use
|
||||
`make in-place` or `make unix-style`, but instead start from a clean
|
||||
`make in-place' or `make unix-style', but instead start from a clean
|
||||
repository.
|
||||
|
||||
Use one non-Windows machine as a server, where packages will be
|
||||
|
|
@ -303,20 +262,24 @@ installers on N client machines, each of which contacts the server
|
|||
machine to obtain pre-built packages. The server can act as a client,
|
||||
naturally, to create an installer for the server's platform.
|
||||
|
||||
GNU `make` is required on the server machine, `nmake` is required on
|
||||
Windows client machines, and any `make` should work on other client
|
||||
GNU `make' is required on the server machine, `nmake' is required on
|
||||
Windows client machines, and any `make' should work on other client
|
||||
machines.
|
||||
|
||||
Running Build Farms
|
||||
-------------------
|
||||
|
||||
The `installers` target of the makefile will do everything to generate
|
||||
The `installers' target of the makefile will do everything to generate
|
||||
installers: build a server on the current machine, run clients on
|
||||
hosts specified via CONFIG, and start/stop VirtualBox virtual machines
|
||||
that act as client machines.
|
||||
|
||||
See the documentation of the "distro-build" package for a description
|
||||
of the site-configuration module and requirements on client hosts.
|
||||
See
|
||||
|
||||
pkgs/distro-build-pkgs/distro-build-client/doc.txt
|
||||
|
||||
for a description of the site-configuration module and requirements on
|
||||
client hosts.
|
||||
|
||||
If "my-site-config.rkt" is a configuration module, then
|
||||
|
||||
|
|
@ -328,22 +291,21 @@ installer filenames in "build/installer/table.rktd". A log file
|
|||
for each client is written to "build/log".
|
||||
|
||||
The default CONFIG path is "build/site.rkt", so you could put your
|
||||
configuration file there and omit the `CONFIG` argument to `make`. A
|
||||
default configuration file is created there automatically. Supply
|
||||
`CONFIG_MODE=...` to pass a configuration mode on to your
|
||||
site-configuration module (accessible via the `current-mode`
|
||||
parameter). Supply `CLEAN_MODE=--clean` to make the default `#:clean?`
|
||||
configuration file there and omit the `CONFIG' argument to
|
||||
`make'. Supply `CONFIG_MODE=...' to pass a configuration mode on to
|
||||
your site-configuration module (accessible via the `current-mode'
|
||||
parameter). Supply `CLEAN_MODE=--clean' to make the default `#:clean?'
|
||||
configuration for a client #t instead of #f, supply
|
||||
`RELEASE_MODE=--release` to make the default `#:release?`
|
||||
`RELEASE_MODE=--release' to make the default `#:release?'
|
||||
configuration #t, supply `SOURCE_MODE=--source` to make the default
|
||||
`#:source?` configuration #t, and supply `VERSIONLESS_MODE=--version`
|
||||
to make the default `#:versionless?` configuration #t.
|
||||
`#:source?' configuration #t, and supply `VERSIONLESS_MODE=--version`
|
||||
to make the default `#:versionless?' configuration #t.
|
||||
|
||||
A configuration file can specify the packages to include, host address
|
||||
of the server, distribution name, installer directory, and
|
||||
documentation search URL, but defaults can be provided as `make`
|
||||
arguments via `PKGS`, `SERVER` plus `SERVER_PORT` plus `SERVER_HOSTS`,
|
||||
`DIST_NAME`, `DIST_BASE`, and `DIST_DIR`, `DOC_SEARCH`,
|
||||
documentation search URL, but defaults can be provided as `make'
|
||||
arguments via `PKGS', `SERVER' plus `SERVER_PORT` plus `SERVER_HOSTS`,
|
||||
`DIST_NAME', `DIST_BASE', and `DIST_DIR', `DOC_SEARCH',
|
||||
respectively. The site configuration's top-level options for packages
|
||||
and documentation search URL are used to configure the set of packages
|
||||
that are available to client machines to include in installers.
|
||||
|
|
@ -354,68 +316,68 @@ is
|
|||
<dist-base>-<version>-<platform>-<dist-suffix>.<ext>
|
||||
|
||||
where <dist-base> defaults to "racket" (but can be set via
|
||||
`DIST_BASE`), <platform> is from `(system-library-subpath #f)` but
|
||||
`DIST_BASE'), <platform> is from `(system-library-subpath #f)' but
|
||||
normalizing the Windows results to "i386-win32" and "x86_63-win32",
|
||||
-<dist-suffix> is omitted unless a `#:dist-suffix` string is specified
|
||||
-<dist-suffix> is omitted unless a `#:dist-suffix' string is specified
|
||||
for the client in the site configuration, and <ext> is
|
||||
platform-specific: ".sh" for Unix (including Linux), ".dmg" or ".pkg"
|
||||
for Mac OS, and ".exe" for Windows.
|
||||
for Mac OS X, and ".exe" for Windows.
|
||||
|
||||
Generating Installer Web Sites
|
||||
------------------------------
|
||||
|
||||
The `site` target of the makefile uses the `installers` target to
|
||||
The `site' target of the makefile uses the `installers' target to
|
||||
generate a set of installers, and then it combines the installers,
|
||||
packages, a package catalog, and log files into a directory that is
|
||||
suitable for access via a web server.
|
||||
|
||||
Supply the same `CONFIG=...` and `CONFIG_MODE=...` arguments for
|
||||
`site` as for `installers`. The configuration file should have a
|
||||
`#:dist-base-url` entry for the URL where installers and packages will
|
||||
be made available; the `installers` target uses `#:dist-base-url` to
|
||||
Supply the same `CONFIG=...' and `CONFIG_MODE=...' arguments for
|
||||
`site' as for `installers'. The configuration file should have a
|
||||
`#:dist-base-url' entry for the URL where installers and packages will
|
||||
be made available; the `installers' target uses `#:dist-base-url' to
|
||||
embed suitable configuration into the installers. Specifically,
|
||||
installers are configured to access pre-built packages and
|
||||
documentation from the site indicated by `#:dist-base-url`.
|
||||
documentation from the site indicated by `#:dist-base-url'.
|
||||
|
||||
Note that `#:dist-base-url` should almost always end with "/", since
|
||||
others URLs will be constructed as relative to `#:dist-base-url`.
|
||||
Note that `#:dist-base-url' should almost always end with "/", since
|
||||
others URLs will be constructed as relative to `#:dist-base-url'.
|
||||
|
||||
The site is generated as "build/site" by default. A `#:site-dest`
|
||||
The site is generated as "build/site" by default. A `#:site-dest'
|
||||
entry in the configuration file can select an alternate destination.
|
||||
|
||||
Use the `site-from-installers` makefile target to perform the part of
|
||||
`site` that happens after `installers` (i.e., to generate a `site`
|
||||
Use the `site-from-installers' makefile target to perform the part of
|
||||
`site' that happens after `installers' (i.e., to generate a `site'
|
||||
from an already-generated set of installers).
|
||||
|
||||
Managing Snapshot Web Sites
|
||||
---------------------------
|
||||
|
||||
The `snapshot-site` makefile target uses `site` (so supply the same
|
||||
`CONFIG=...` and `CONFIG_MODE=...` arguments), and then treats the
|
||||
The `snapshot-site' makefile target uses `site' (so supply the same
|
||||
`CONFIG=...' and `CONFIG_MODE=...' arguments), and then treats the
|
||||
resulting site as a snapshot with additional snapshot-management
|
||||
tasks.
|
||||
|
||||
For snapshot management, the destination of the files generated for
|
||||
`site` (as specified by `#:site-dest`) should be within a directory of
|
||||
snapshots. The configuration file can use `(current-stamp)` to get a
|
||||
`site' (as specified by `#:site-dest') should be within a directory of
|
||||
snapshots. The configuration file can use `(current-stamp)' to get a
|
||||
string that represents the current build, and then use the string both
|
||||
for `#:dist-base-url` and `#:site-dest`. Normally, the stamp string is
|
||||
for `#:dist-base-url' and `#:site-dest'. Normally, the stamp string is
|
||||
a combination of the date and Git commit hash.
|
||||
|
||||
Snapshot management includes creating an "index.html" file in the
|
||||
snapshots directory (essentially a copy of the snapshot's own
|
||||
"index.html") and pruning snapshot subdirectories to keep the number
|
||||
of snapshots at the amount specified by `#:max-snapshots`
|
||||
of snapshots at the amount specified by `#:max-snapshots'
|
||||
configuration-file entry (with a default value of 5).
|
||||
|
||||
Use the `snapshot-at-site` makefile target to perform the part of
|
||||
Use the `snapshot-at-site' makefile target to perform the part of
|
||||
`snapshot-site that happens after `site (i.e., to manage snapshots
|
||||
around an already-generated site).
|
||||
|
||||
Separate Server and Clients
|
||||
---------------------------
|
||||
|
||||
Instead of using the `installers` makefile target and a site
|
||||
Instead of using the `installers' makefile target and a site
|
||||
configuration file, you can run server and client processes manually.
|
||||
|
||||
Roughly, the steps are
|
||||
|
|
@ -423,50 +385,50 @@ Roughly, the steps are
|
|||
1. On the server machine:
|
||||
make server PKGS="..."
|
||||
|
||||
See 1b below for more information on variables other than `PKGS`
|
||||
that you can provide with `make`.
|
||||
See 1b below for more information on variables other than `PKGS'
|
||||
that you can provide with `make'.
|
||||
|
||||
2. On each client machine:
|
||||
make client SERVER=... PKGS="..."
|
||||
or
|
||||
nmake win32-client SERVER=... PKGS="..."
|
||||
|
||||
See 2b below for more information on variables other than `SERVER`
|
||||
and `PKGS` that you can provide with `make`.
|
||||
See 2b below for more information on variables other than `SERVER'
|
||||
and `PKGS' that you can provide with `make'.
|
||||
|
||||
In more detail:
|
||||
|
||||
1a. Build "racket" on a server.
|
||||
|
||||
The `base` target of the makefile will do that, if you haven't
|
||||
The `base' target of the makefile will do that, if you haven't
|
||||
done it already. (The server only works on non-Windows platforms,
|
||||
currently.)
|
||||
|
||||
1b. On the server, build packages and start a catalog server.
|
||||
|
||||
The `server-from-base` target of the makefile will do that.
|
||||
The `server-from-base' target of the makefile will do that.
|
||||
|
||||
Alternatively, use the `server` target, which combines `base` and
|
||||
`server-from-base` (i.e., steps 1a and 1b).
|
||||
Alternatively, use the `server' target, which combines `base' and
|
||||
`server-from-base' (i.e., steps 1a and 1b).
|
||||
|
||||
The `SERVER_PORT` variable of the makefile choose the port on
|
||||
The `SERVER_PORT' variable of the makefile choose the port on
|
||||
which the server listens to clients. The default is port 9440.
|
||||
|
||||
The `SERVER_HOSTS` variable of the makefile determines the
|
||||
The `SERVER_HOSTS' variable of the makefile determines the
|
||||
interfaces at which the server listens. The default is
|
||||
"localhost" which listens only on the loopback device (for
|
||||
security). Supply the empty string to listen on all
|
||||
interfaces. Supply multiple addresses by separating them with a
|
||||
comma.
|
||||
|
||||
The `PKGS` variable of the makefile determines which packages are
|
||||
The `PKGS' variable of the makefile determines which packages are
|
||||
built for potential inclusion in a distribution.
|
||||
|
||||
The `DOC_SEARCH` variable of the makefile determine a URL that is
|
||||
The `DOC_SEARCH' variable of the makefile determine a URL that is
|
||||
embedded in rendered documentation for cases where a remote
|
||||
search is needed (because other documentation is not installed).
|
||||
|
||||
The `SRC_CATALOG` variable determines the catalog that is used to
|
||||
The `SRC_CATALOG' variable determines the catalog that is used to
|
||||
get package sources and native-library packages. The default is
|
||||
"http://pkgs.racket-lang.org".
|
||||
|
||||
|
|
@ -476,8 +438,8 @@ In more detail:
|
|||
"README.txt" by default).
|
||||
|
||||
If you stop the server and want to restart it, use the
|
||||
`built-package-server` makefile target instead of starting over
|
||||
with the `server` target.
|
||||
`built-package-server' makefile target instead of starting over
|
||||
with the `server' target.
|
||||
|
||||
2a. On each client (one for each platform to bundle), build "racket".
|
||||
|
||||
|
|
@ -486,94 +448,94 @@ In more detail:
|
|||
|
||||
2b. On each client, create an installer.
|
||||
|
||||
The `client` (or `win32-client`) target of the makefile will do
|
||||
The `client' (or `win32-client') target of the makefile will do
|
||||
that.
|
||||
|
||||
Provide `SERVER` as the hostname of the server machine, but a
|
||||
Provide `SERVER' as the hostname of the server machine, but a
|
||||
"localhost"-based tunnel back to the server is more secure and
|
||||
avoids the need to specify `SERVER_HOSTS` when starting the
|
||||
server in step 1b. Also, provide `SERVER_PORT` if an alternate
|
||||
avoids the need to specify `SERVER_HOSTS' when starting the
|
||||
server in step 1b. Also, provide `SERVER_PORT' if an alternate
|
||||
port was specified in step 1b.
|
||||
|
||||
Provide the same `PKGS` (or a subset) as in step 1b if you want a
|
||||
Provide the same `PKGS' (or a subset) as in step 1b if you want a
|
||||
different set than the ones listed in the makefile. Similarly,
|
||||
`DOC_SEARCH` normally should be the same as in step 1b, but for a
|
||||
`DOC_SEARCH' normally should be the same as in step 1b, but for a
|
||||
client, it affects future documentation builds in the
|
||||
installation.
|
||||
|
||||
Alternatively, use the `client` target, which combines `base` and
|
||||
`client-from-base` (i.e., steps 2a and 2b).
|
||||
Alternatively, use the `client' target, which combines `base' and
|
||||
`client-from-base' (i.e., steps 2a and 2b).
|
||||
|
||||
On Windows, you need NSIS installed, either in the usual location
|
||||
or with `makensis` in your command-line path.
|
||||
or with `makensis' in your command-line path.
|
||||
|
||||
To create a release installer, provide `RELEASE_MODE` as
|
||||
"--release" to `make`. A release installer has slightly different
|
||||
To create a release installer, provide `RELEASE_MODE' as
|
||||
"--release" to `make'. A release installer has slightly different
|
||||
defaults that are suitable for infrequently updated release
|
||||
installations, as opposed to frequently updated snapshot
|
||||
installations.
|
||||
|
||||
To create a source archive, provide `SOURCE_MODE` as "--source"
|
||||
to `make`.
|
||||
To create a source archive, provide `SOURCE_MODE' as "--source"
|
||||
to `make'.
|
||||
|
||||
To create an archive that omits the version number and also omit
|
||||
and version number in installer paths, provide `VERSIONLESS_MODE` as
|
||||
"--versionless" to `make`.
|
||||
and version number in installer paths, provide `VERSIONLESS_MODE' as
|
||||
"--versionless" to `make'.
|
||||
|
||||
To change the human-readable name of the distribution as embedded
|
||||
in the installer, provide `DIST_NAME` to `make`. The default
|
||||
in the installer, provide `DIST_NAME' to `make'. The default
|
||||
distribution name is "Racket". Whatever name you pick, the Racket
|
||||
version number is automatically added for various contexts.
|
||||
|
||||
To change the base name of the installer file, provide `DIST_BASE`
|
||||
to `make`. The default is "racket".
|
||||
To change the base name of the installer file, provide `DIST_BASE'
|
||||
to `make'. The default is "racket".
|
||||
|
||||
To change the directory name for installation on Unix (including
|
||||
Linux), provide `DIST_DIR` to `make`. The default is "racket".
|
||||
Linux), provide `DIST_DIR' to `make'. The default is "racket".
|
||||
|
||||
To add an extra piece to the installer's name, such as an
|
||||
identifier for a variant of Linux, provide `DIST_SUFFIX` to
|
||||
`make`. The default is "", which omits the prefix and its
|
||||
identifier for a variant of Linux, provide `DIST_SUFFIX' to
|
||||
`make'. The default is "", which omits the prefix and its
|
||||
preceding hyphen.
|
||||
|
||||
To set the description string for the installer, provide
|
||||
`DIST_DESC` to `make`. The description string is recorded
|
||||
`DIST_DESC' to `make'. The description string is recorded
|
||||
alongside the installer.
|
||||
|
||||
To set the initial package catalogs URLs for an installation,
|
||||
provide `DIST_CATALOGS_q` to `make`. Separate multiple URLs with
|
||||
provide `DIST_CATALOGS_q' to `make'. Separate multiple URLs with
|
||||
a space, and use an empty string in place of a URL to indicate
|
||||
that the default catalogs should be used. The "_q" in the
|
||||
variable name indicates that its value can include double quotes
|
||||
(but not single quotes) --- which are needed to specify an empty
|
||||
string, for example.
|
||||
|
||||
To select a "README" file for the client, provide `README` to
|
||||
`make`. The `README` value is used as a file name to download
|
||||
To select a "README" file for the client, provide `README' to
|
||||
`make'. The `README' value is used as a file name to download
|
||||
from the server.
|
||||
|
||||
To create a ".tgz" archive instead of an installer (or any
|
||||
platform), set `TGZ_MODE` to "--tgz".
|
||||
platform), set `TGZ_MODE' to "--tgz".
|
||||
|
||||
For a Mac OS installer, set `SIGN_IDENTITY` as the name to
|
||||
which the signing certificate is associated. Set `MAC_PKG_MODE`
|
||||
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
|
||||
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 `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
|
||||
client, but those paths should be empty for a server started with
|
||||
`make server`, and they are used mainly by `make
|
||||
client-from-site` (described below).
|
||||
`make server', and they are used mainly by `make
|
||||
client-from-site' (described below).
|
||||
|
||||
The `UPLOAD` makefile variable specifies a URL to use as an
|
||||
The `UPLOAD' makefile variable specifies a URL to use as an
|
||||
upload destination for the created installed, where the
|
||||
installer's name is added to the end of the URL, or leave as
|
||||
empty for no upload.
|
||||
|
|
@ -585,26 +547,26 @@ the server, which leaves the installer in a "build/installers"
|
|||
directory and records a mapping from the installer's description to
|
||||
its filename in "build/installers/table.rktd".
|
||||
|
||||
If you provide `JOB_OPTIONS=...` for either a client or server build,
|
||||
the options are used both for `raco setup` and `raco pkg
|
||||
install`. Normally, `JOB_OPTIONS` is used to control parallelism.
|
||||
If you provide `JOB_OPTIONS=...' for either a client or server build,
|
||||
the options are used both for `raco setup' and `raco pkg
|
||||
install'. Normally, `JOB_OPTIONS' is used to control parallelism.
|
||||
|
||||
Creating a Client from an Installer Web Site
|
||||
--------------------------------------------
|
||||
|
||||
If you (or someone else) previously created an installer site with
|
||||
`make site`, then `make client-from-site` in a clean repository
|
||||
`make site', then `make client-from-site` in a clean repository
|
||||
creates an installer for the current platform drawing packages
|
||||
from the site.
|
||||
|
||||
At a minimum, provide `SERVER`, `SERVER_PORT` (usually 80), and
|
||||
`SITE_PATH` (if not empty, include a trailing "/") makefile variables
|
||||
At a minimum, provide `SERVER', `SERVER_PORT' (usually 80), and
|
||||
`SITE_PATH' (if not empty, include a trailing "/") makefile variables
|
||||
to access a site at
|
||||
|
||||
http://$(SERVER):$(SERVER_PORT)/$(SITE_PATH)
|
||||
|
||||
The `client-from-site` makefile target chains to `make client` while
|
||||
The `client-from-site' makefile target chains to `make client' while
|
||||
passing suitable values for `DIST_CATALOGS_q`, `DOC_SEARCH`,
|
||||
`SERVER_CATALOG_PATH`, and `SERVER_COLLECTS_PATH`. Supply any other
|
||||
suitable variables, such as `DIST_NAME` or `RELEASE_MODE`, the same as
|
||||
for `make client`.
|
||||
`SERVER_CATALOG_PATH', and `SERVER_COLLECTS_PATH'. Supply any other
|
||||
suitable variables, such as `DIST_NAME' or `RELEASE_MODE', the same as
|
||||
for `make client'.
|
||||
|
|
|
|||
218
Makefile
218
Makefile
|
|
@ -64,32 +64,16 @@ INSTALL_PKGS_ARGS = $(JOB_OPTIONS) --no-setup --pkgs \
|
|||
ALL_PLT_SETUP_OPTIONS = $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)
|
||||
|
||||
plain-in-place:
|
||||
$(MAKE) plain-minimal-in-place
|
||||
$(MAKE) in-place-setup
|
||||
|
||||
plain-in-place-after-base:
|
||||
$(MAKE) plain-minimal-in-place-after-base
|
||||
$(MAKE) in-place-setup
|
||||
|
||||
plain-minimal-in-place:
|
||||
$(MAKE) plain-base
|
||||
$(MAKE) plain-minimal-in-place-after-base
|
||||
|
||||
plain-minimal-in-place-after-base:
|
||||
$(MAKE) base
|
||||
$(MAKE) pkgs-catalog
|
||||
$(RUN_RACO) pkg update $(UPDATE_PKGS_ARGS)
|
||||
$(RUN_RACO) pkg install $(INSTALL_PKGS_ARGS)
|
||||
$(RUN_RACO) setup --only-foreign-libs $(ALL_PLT_SETUP_OPTIONS)
|
||||
|
||||
in-place-setup:
|
||||
$(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS)
|
||||
|
||||
win32-in-place:
|
||||
$(MAKE) win32-base
|
||||
$(MAKE) win32-in-place-after-base PKGS="$(PKGS)" SRC_CATALOG="$(SRC_CATALOG)" WIN32_PLAIN_RACKET="$(WIN32_PLAIN_RACKET)"
|
||||
|
||||
win32-in-place-after-base:
|
||||
$(MAKE) win32-pkgs-catalog SRC_CATALOG="$(SRC_CATALOG)" WIN32_PLAIN_RACKET="$(WIN32_PLAIN_RACKET)"
|
||||
$(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)
|
||||
|
|
@ -107,14 +91,14 @@ cpus-as-is:
|
|||
|
||||
plain-as-is:
|
||||
$(MAKE) base
|
||||
$(MAKE) in-place-setup
|
||||
$(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS)
|
||||
|
||||
win32-as-is:
|
||||
$(MAKE) win32-base
|
||||
$(WIN32_RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS)
|
||||
|
||||
# ------------------------------------------------------------
|
||||
# Unix-style build (Unix and Mac OS, only)
|
||||
# Unix-style build (Unix and Mac OS X, only)
|
||||
|
||||
PREFIX =
|
||||
|
||||
|
|
@ -164,29 +148,16 @@ set-src-catalog:
|
|||
|
||||
CONFIGURE_ARGS_qq =
|
||||
|
||||
SELF_UP =
|
||||
SELF_FLAGS_qq = SELF_RACKET_FLAGS="-G `cd $(SELF_UP)../../../build/config; pwd`"
|
||||
INSTALL_SETUP_ARGS = $(SELF_FLAGS_qq) PLT_SETUP_OPTIONS="$(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)"
|
||||
SELF_FLAGS_qq = SELF_RACKET_FLAGS="-G `cd ../../../build/config; pwd`"
|
||||
|
||||
base:
|
||||
if [ "$(CPUS)" = "" ] ; \
|
||||
then $(MAKE) plain-base ; \
|
||||
else $(MAKE) cpus-base CPUS="$(CPUS)" ; fi
|
||||
|
||||
cpus-base:
|
||||
$(MAKE) -j $(CPUS) plain-base JOB_OPTIONS="-j $(CPUS)"
|
||||
|
||||
plain-base:
|
||||
$(MAKE) base-config
|
||||
mkdir -p build/config
|
||||
echo '#hash((links-search-files . ()))' > build/config/config.rktd
|
||||
mkdir -p racket/src/build
|
||||
$(MAKE) racket/src/build/Makefile
|
||||
cd racket/src/build; $(MAKE) reconfigure
|
||||
cd racket/src/build; $(MAKE) $(SELF_FLAGS_qq)
|
||||
cd racket/src/build; $(MAKE) install $(INSTALL_SETUP_ARGS)
|
||||
|
||||
base-config:
|
||||
mkdir -p build/config
|
||||
echo '#hash((links-search-files . ()))' > build/config/config.rktd
|
||||
cd racket/src/build; $(MAKE) install $(SELF_FLAGS_qq) PLT_SETUP_OPTIONS="$(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)"
|
||||
|
||||
win32-base:
|
||||
$(MAKE) win32-remove-setup-dlls
|
||||
|
|
@ -216,95 +187,6 @@ native-for-cross:
|
|||
racket/src/build/cross/Makefile: racket/src/configure racket/src/Makefile.in
|
||||
cd racket/src/build/cross; ../../configure
|
||||
|
||||
# ------------------------------------------------------------
|
||||
# Racket-on-Chez build
|
||||
|
||||
# If `RACKET` is not set, then we bootstrap by first building the
|
||||
# traditional virtual machine
|
||||
RACKET =
|
||||
|
||||
# If `SCHEME_SRC` is not set, then we'll download a copy of
|
||||
# Chez Scheme from `CHEZ_SCHEME_REPO`
|
||||
SCHEME_SRC =
|
||||
DEFAULT_SCHEME_SRC = racket/src/build/ChezScheme
|
||||
|
||||
CHEZ_SCHEME_REPO = https://github.com/mflatt/ChezScheme
|
||||
|
||||
# Redirected for "as-is":
|
||||
BASE_TARGET = plain-minimal-in-place
|
||||
CS_SETUP_TARGET = plain-in-place-after-base
|
||||
|
||||
cs:
|
||||
if [ "$(SCHEME_SRC)" = "" ] ; \
|
||||
then $(MAKE) scheme-src ; fi
|
||||
if [ "$(RACKET)" = "" ] ; \
|
||||
then $(MAKE) racket-then-cs ; \
|
||||
else $(MAKE) cs-after-racket-with-racket RACKET="$(RACKET)" ; fi
|
||||
|
||||
cs-as-is:
|
||||
$(MAKE) cs BASE_TARGET=plain-base CS_SETUP_TARGET=in-place-setup
|
||||
|
||||
cs-after-racket:
|
||||
if [ "$(RACKET)" = "" ] ; \
|
||||
then $(MAKE) cs-after-racket-with-racket RACKET="$(PLAIN_RACKET)" ; \
|
||||
else $(MAKE) cs-after-racket-with-racket RACKET="$(RACKET)" ; fi
|
||||
|
||||
racket-then-cs:
|
||||
$(MAKE) $(BASE_TARGET) PKGS="compiler-lib parser-tools-lib"
|
||||
$(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS) -D -l compiler parser-tools
|
||||
$(MAKE) cs-after-racket-with-racket RACKET="$(PLAIN_RACKET)"
|
||||
|
||||
ABS_RACKET = "`$(RACKET) racket/src/cs/absify.rkt --exec $(RACKET)`"
|
||||
ABS_SCHEME_SRC = "`$(RACKET) racket/src/cs/absify.rkt $(SCHEME_SRC)`"
|
||||
|
||||
cs-after-racket-with-racket:
|
||||
if [ "$(SCHEME_SRC)" = "" ] ; \
|
||||
then $(MAKE) cs-after-racket-with-racket-and-scheme-src RACKET="$(RACKET)" SCHEME_SRC="$(DEFAULT_SCHEME_SRC)" ; \
|
||||
else $(MAKE) cs-after-racket-with-racket-and-scheme-src RACKET="$(RACKET)" SCHEME_SRC="$(SCHEME_SRC)" ; fi
|
||||
|
||||
cs-after-racket-with-racket-and-scheme-src:
|
||||
$(MAKE) cs-after-racket-with-abs-paths RACKET="$(ABS_RACKET)" SCHEME_SRC="$(ABS_SCHEME_SRC)" SELF_UP=../
|
||||
|
||||
cs-after-racket-with-abs-paths:
|
||||
$(MAKE) racket/src/build/cs/Makefile
|
||||
cd racket/src/build/cs; $(MAKE) RACKET="$(RACKET)" SCHEME_SRC="$(SCHEME_SRC)"
|
||||
$(MAKE) base-config
|
||||
cd racket/src/build/cs; $(MAKE) install RACKET="$(RACKET)" $(INSTALL_SETUP_ARGS)
|
||||
$(MAKE) $(CS_SETUP_TARGET) PLAIN_RACKET=racket/bin/racketcs
|
||||
|
||||
racket/src/build/cs/Makefile: racket/src/cs/c/configure racket/src/cs/c/Makefile.in
|
||||
mkdir -p cd racket/src/build/cs
|
||||
cd racket/src/build/cs; ../../cs/c/configure
|
||||
|
||||
scheme-src:
|
||||
$(MAKE) racket/src/build/ChezScheme
|
||||
$(MAKE) update-ChezScheme
|
||||
|
||||
racket/src/build/ChezScheme:
|
||||
mkdir -p racket/src/build
|
||||
cd racket/src/build && git clone $(CHEZ_SCHEME_REPO)
|
||||
|
||||
update-ChezScheme:
|
||||
cd racket/src/build/ChezScheme && git pull && git submodule update
|
||||
|
||||
WIN32_CS_COPY_ARGS_EXCEPT_PKGS = SRC_CATALOG="$(SRC_CATALOG)"
|
||||
WIN32_CS_COPY_ARGS = PKGS="$(PKGS)" $(WIN32_CS_COPY_ARGS_EXCEPT_PKGS)
|
||||
|
||||
win32-cs:
|
||||
IF "$(RACKET)" == "" $(MAKE) win32-racket-then-cs $(WIN32_CS_COPY_ARGS)
|
||||
IF not "$(RACKET)" == "" $(MAKE) win32-just-cs RACKET="$(RACKET)" SCHEME_SRC="$(SCHEME_SRC)" $(WIN32_CS_COPY_ARGS)
|
||||
|
||||
win32-racket-then-cs:
|
||||
$(MAKE) win32-in-place PKGS="" $(WIN32_CS_COPY_ARGS_EXCEPT_PKGS)
|
||||
$(MAKE) win32-just-cs RACKET=$(WIN32_PLAIN_RACKET) SCHEME_SRC="$(SCHEME_SRC)" $(WIN32_CS_COPY_ARGS)
|
||||
|
||||
win32-just-cs:
|
||||
cmd /c $(RACKET) racket\src\worksp\csbuild.rkt --scheme-dir "$(SCHEME_SRC)"
|
||||
IF NOT EXIST build\config cmd /c mkdir build\config
|
||||
cmd /c echo #hash((links-search-files . ())) > build\config\config.rktd
|
||||
racket\racketcs -G build\config -N raco -l- raco setup $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)
|
||||
$(MAKE) win32-in-place-after-base WIN32_PLAIN_RACKET=racket\racketcs $(WIN32_CS_COPY_ARGS)
|
||||
|
||||
# ------------------------------------------------------------
|
||||
# Configuration options for building installers
|
||||
|
||||
|
|
@ -352,7 +234,7 @@ SOURCE_MODE =
|
|||
# name or installation path:
|
||||
VERSIONLESS_MODE =
|
||||
|
||||
# Set to "--mac-pkg" to create ".pkg"-based installers for Mac OS,
|
||||
# Set to "--mac-pkg" to create ".pkg"-based installers for Mac OS X,
|
||||
# instead of a ".dmg" for drag-and-drop installation:
|
||||
MAC_PKG_MODE =
|
||||
|
||||
|
|
@ -389,7 +271,7 @@ BUILD_STAMP =
|
|||
# the default as the version number:
|
||||
INSTALL_NAME =
|
||||
|
||||
# For Mac OS, a signing identity (spaces allowed) for binaries in an
|
||||
# For Mac OS X, a signing identity (spaces allowed) for binaries in an
|
||||
# installer:
|
||||
SIGN_IDENTITY =
|
||||
|
||||
|
|
@ -441,8 +323,8 @@ SVR_CAT = http://$(SVR_PRT)/$(SERVER_CATALOG_PATH)
|
|||
|
||||
# Helper macros:
|
||||
USER_CONFIG = -G build/user/config -X racket/collects -A build/user
|
||||
USER_RACKET = $(PLAIN_RACKET) $(USER_CONFIG)
|
||||
USER_RACO = $(PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco
|
||||
RACKET = $(PLAIN_RACKET) $(USER_CONFIG)
|
||||
RACO = $(PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco
|
||||
WIN32_RACKET = $(WIN32_PLAIN_RACKET) $(USER_CONFIG)
|
||||
WIN32_RACO = $(WIN32_PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco
|
||||
X_AUTO_OPTIONS = --skip-installed --deps search-auto --pkgs $(JOB_OPTIONS)
|
||||
|
|
@ -453,20 +335,18 @@ REMOTE_USER_AUTO = --catalog $(SVR_CAT) $(USER_AUTO_OPTIONS)
|
|||
REMOTE_INST_AUTO = --catalog $(SVR_CAT) --scope installation $(X_AUTO_OPTIONS)
|
||||
CONFIG_MODE_q = "$(CONFIG)" "$(CONFIG_MODE)"
|
||||
BUNDLE_CONFIG = bundle/racket/etc/config.rktd
|
||||
BUNDLE_RACO_FLAGS = -G bundle/racket/etc -X bundle/racket/collects -C -A bundle/user -l raco
|
||||
BUNDLE_RACO_FLAGS = -G bundle/racket/config -X bundle/racket/collects -A bundle/user -l raco
|
||||
BUNDLE_RACO = $(PLAIN_RACKET) $(BUNDLE_RACO_FLAGS)
|
||||
WIN32_BUNDLE_RACO = $(WIN32_PLAIN_RACKET) $(BUNDLE_RACO_FLAGS)
|
||||
IN_BUNDLE_RACO = bundle/racket/bin/raco
|
||||
WIN32_IN_BUNDLE_RACO = bundle\racket\raco
|
||||
|
||||
# ------------------------------------------------------------
|
||||
# Linking all packages (development mode; not an installer build)
|
||||
|
||||
PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata --immediate
|
||||
PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata
|
||||
PKGS_CONFIG = -U -G build/config racket/src/pkgs-config.rkt
|
||||
|
||||
pkgs-catalog:
|
||||
$(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs racket/src/expander
|
||||
$(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs
|
||||
$(RUN_RACKET) $(PKGS_CONFIG) "$(DEFAULT_SRC_CATALOG)" "$(SRC_CATALOG)"
|
||||
$(RUN_RACKET) racket/src/pkgs-check.rkt racket/share/pkgs-catalog
|
||||
|
||||
|
|
@ -519,47 +399,47 @@ stamp-from-date:
|
|||
build-from-catalog:
|
||||
rm -rf build/user
|
||||
rm -rf build/catalog-copy
|
||||
$(USER_RACO) pkg catalog-copy "$(SRC_CATALOG)" build/catalog-copy
|
||||
$(RACO) pkg catalog-copy "$(SRC_CATALOG)" build/catalog-copy
|
||||
$(MAKE) server-cache-config
|
||||
$(USER_RACO) pkg install --all-platforms $(SOURCE_USER_AUTO_q) $(REQUIRED_PKGS) $(DISTRO_BUILD_PKGS)
|
||||
$(RACO) pkg install --all-platforms $(SOURCE_USER_AUTO_q) $(REQUIRED_PKGS) $(DISTRO_BUILD_PKGS)
|
||||
$(MAKE) set-server-config
|
||||
$(USER_RACKET) -l- distro-build/pkg-info -o build/pkgs.rktd build/catalog-copy
|
||||
$(USER_RACKET) -l distro-build/install-pkgs $(CONFIG_MODE_q) "$(PKGS) $(TEST_PKGS)" $(SOURCE_USER_AUTO_q) --all-platforms
|
||||
$(USER_RACO) setup --avoid-main $(JOB_OPTIONS)
|
||||
$(RACKET) -l- distro-build/pkg-info -o build/pkgs.rktd build/catalog-copy
|
||||
$(RACKET) -l distro-build/install-pkgs $(CONFIG_MODE_q) "$(PKGS)" $(SOURCE_USER_AUTO_q) --all-platforms
|
||||
$(RACO) setup --avoid-main $(JOB_OPTIONS)
|
||||
|
||||
server-cache-config:
|
||||
$(USER_RACO) pkg config -i --set download-cache-dir build/cache
|
||||
$(USER_RACO) pkg config -i --set download-cache-max-files 1023
|
||||
$(USER_RACO) pkg config -i --set download-cache-max-bytes 671088640
|
||||
$(RACO) pkg config -i --set download-cache-dir build/cache
|
||||
$(RACO) pkg config -i --set download-cache-max-files 1023
|
||||
$(RACO) pkg config -i --set download-cache-max-bytes 671088640
|
||||
|
||||
set-server-config:
|
||||
$(USER_RACKET) -l distro-build/set-server-config build/user/config/config.rktd $(CONFIG_MODE_q) "" "" "$(DOC_SEARCH)" ""
|
||||
$(RACKET) -l distro-build/set-server-config build/user/config/config.rktd $(CONFIG_MODE_q) "" "" "$(DOC_SEARCH)" ""
|
||||
|
||||
# Although a client will build its own "collects", pack up the
|
||||
# server's version to be used by each client, so that every client has
|
||||
# exactly the same bytecode (which matters for SHA1-based dependency
|
||||
# tracking):
|
||||
origin-collects:
|
||||
$(USER_RACKET) -l distro-build/pack-collects
|
||||
$(RACKET) -l distro-build/pack-collects
|
||||
|
||||
# Now that we've built packages from local sources, create "built"
|
||||
# versions of the packages from the installation into "build/user":
|
||||
built-catalog:
|
||||
$(USER_RACKET) -l distro-build/pack-built build/pkgs.rktd
|
||||
$(RACKET) -l distro-build/pack-built build/pkgs.rktd
|
||||
|
||||
# Run a catalog server to provide pre-built packages, as well
|
||||
# as the copy of the server's "collects" tree:
|
||||
built-catalog-server:
|
||||
if [ -d ".git" ]; then git update-server-info ; fi
|
||||
$(USER_RACKET) -l distro-build/serve-catalog $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT) $(SERVE_DURING_CMD_qq)
|
||||
$(RACKET) -l distro-build/serve-catalog $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT) $(SERVE_DURING_CMD_qq)
|
||||
|
||||
# Demonstrate how a catalog server for binary packages works,
|
||||
# which involves creating package archives in "binary" mode
|
||||
# instead of "built" mode:
|
||||
binary-catalog:
|
||||
$(USER_RACKET) -l- distro-build/pack-built --mode binary build/pkgs.rktd
|
||||
$(RACKET) -l- distro-build/pack-built --mode binary build/pkgs.rktd
|
||||
binary-catalog-server:
|
||||
$(USER_RACKET) -l- distro-build/serve-catalog --mode binary $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT)
|
||||
$(RACKET) -l- distro-build/serve-catalog --mode binary $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT)
|
||||
|
||||
# ------------------------------------------------------------
|
||||
# On each supported platform (for an installer build):
|
||||
|
|
@ -581,7 +461,7 @@ PROP_ARGS = SERVER=$(SERVER) SERVER_PORT=$(SERVER_PORT) SERVER_HOSTS="$(SERVER_H
|
|||
DIST_DIR=$(DIST_DIR) DIST_SUFFIX=$(DIST_SUFFIX) UPLOAD="$(UPLOAD)" \
|
||||
DIST_DESC="$(DIST_DESC)" README="$(README)" SIGN_IDENTITY="$(SIGN_IDENTITY)" \
|
||||
OSSLSIGNCODE_ARGS_BASE64="$(OSSLSIGNCODE_ARGS_BASE64)" JOB_OPTIONS="$(JOB_OPTIONS)" \
|
||||
TGZ_MODE=$(TGZ_MODE) TEST_PKGS="$(TEST_PKGS)"
|
||||
TGZ_MODE=$(TGZ_MODE)
|
||||
|
||||
COPY_ARGS = $(PROP_ARGS) \
|
||||
SERVER_CATALOG_PATH=$(SERVER_CATALOG_PATH) SERVER_COLLECTS_PATH=$(SERVER_COLLECTS_PATH)
|
||||
|
|
@ -595,7 +475,7 @@ client:
|
|||
$(MAKE) base $(COPY_ARGS)
|
||||
$(MAKE) distro-build-from-server $(COPY_ARGS)
|
||||
$(MAKE) bundle-from-server $(COPY_ARGS)
|
||||
$(USER_RACKET) -l distro-build/set-config $(SET_BUNDLE_CONFIG_q)
|
||||
$(RACKET) -l distro-build/set-config $(SET_BUNDLE_CONFIG_q)
|
||||
$(MAKE) installer-from-bundle $(COPY_ARGS)
|
||||
|
||||
win32-client:
|
||||
|
|
@ -609,7 +489,7 @@ win32-client:
|
|||
# Install the "distro-build" package from the server into
|
||||
# a local build:
|
||||
distro-build-from-server:
|
||||
$(USER_RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client
|
||||
$(RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client
|
||||
|
||||
# Copy our local build into a "bundle/racket" build, dropping in the
|
||||
# process things that should not be in an installer (such as the "src"
|
||||
|
|
@ -621,13 +501,13 @@ distro-build-from-server:
|
|||
bundle-from-server:
|
||||
rm -rf bundle
|
||||
mkdir -p bundle/racket
|
||||
$(USER_RACKET) -l setup/unixstyle-install bundle racket bundle/racket
|
||||
$(USER_RACKET) -l setup/winstrip bundle/racket
|
||||
$(USER_RACKET) -l setup/winvers-change bundle/racket
|
||||
$(USER_RACKET) -l distro-build/unpack-collects http://$(SVR_PRT)/$(SERVER_COLLECTS_PATH)
|
||||
$(RACKET) -l setup/unixstyle-install bundle racket bundle/racket
|
||||
$(RACKET) -l setup/winstrip bundle/racket
|
||||
$(RACKET) -l setup/winvers-change bundle/racket
|
||||
$(RACKET) -l distro-build/unpack-collects http://$(SVR_PRT)/$(SERVER_COLLECTS_PATH)
|
||||
$(BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(REQUIRED_PKGS)
|
||||
$(BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(PKGS)
|
||||
$(USER_RACKET) -l setup/unixstyle-install post-adjust "$(SOURCE_MODE)" "$(PKG_SOURCE_MODE)" racket bundle/racket
|
||||
$(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) \
|
||||
|
|
@ -638,7 +518,7 @@ DIST_ARGS_q = $(UPLOAD_q) $(RELEASE_MODE) $(SOURCE_MODE) $(VERSIONLESS_MODE) \
|
|||
# Create an installer from the build (with installed packages) that's
|
||||
# in "bundle/racket":
|
||||
installer-from-bundle:
|
||||
$(USER_RACKET) -l- distro-build/installer $(DIST_ARGS_q)
|
||||
$(RACKET) -l- distro-build/installer $(DIST_ARGS_q)
|
||||
|
||||
win32-distro-build-from-server:
|
||||
$(WIN32_RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client
|
||||
|
|
@ -659,20 +539,6 @@ win32-bundle-from-server:
|
|||
win32-installer-from-bundle:
|
||||
$(WIN32_RACKET) -l- distro-build/installer $(DIST_ARGS_q)
|
||||
|
||||
# The `test-client` and `win32-test-client` targets are optional test
|
||||
# step for an installer build, were `TEST_PKGS` names extra packages
|
||||
# to install, and `TEST_ARGS_q` is a set of arguments to `raco test`.
|
||||
# This step will not make sense for some kinds of builds, such as
|
||||
# source builds or cross-platform builds.
|
||||
|
||||
test-client:
|
||||
$(BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(TEST_PKGS)
|
||||
$(IN_BUNDLE_RACO) test $(TEST_ARGS_q)
|
||||
|
||||
win32-test-client:
|
||||
$(WIN32_BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(TEST_PKGS)
|
||||
$(WIN32_IN_BUNDLE_RACO) test $(TEST_ARGS_q)
|
||||
|
||||
# ------------------------------------------------------------
|
||||
# On a supported platform (for an installer build) after a `make site'
|
||||
# has completed; SERVER, SERVER_PORT (usually 80), and SITE_PATH
|
||||
|
|
@ -699,7 +565,7 @@ DRIVE_ARGS_q = $(RELEASE_MODE) $(VERSIONLESS_MODE) $(SOURCE_MODE) \
|
|||
$(CLEAN_MODE) "$(CONFIG)" "$(CONFIG_MODE)" \
|
||||
$(SERVER) $(SERVER_PORT) "$(SERVER_HOSTS)" \
|
||||
"$(PKGS)" "$(DOC_SEARCH)" "$(DIST_NAME)" $(DIST_BASE) $(DIST_DIR)
|
||||
DRIVE_CMD_q = $(USER_RACKET) -l- distro-build/drive-clients $(DRIVE_ARGS_q)
|
||||
DRIVE_CMD_q = $(RACKET) -l- distro-build/drive-clients $(DRIVE_ARGS_q)
|
||||
|
||||
# Full server build and clients drive, based on `CONFIG':
|
||||
installers:
|
||||
|
|
@ -725,8 +591,8 @@ DOC_CATALOGS = build/built/catalog build/native/catalog
|
|||
|
||||
site-from-installers:
|
||||
rm -rf build/docs
|
||||
$(USER_RACKET) -l- distro-build/install-for-docs build/docs $(CONFIG_MODE_q) "$(PKGS)" $(DOC_CATALOGS)
|
||||
$(USER_RACKET) -l- distro-build/assemble-site $(CONFIG_MODE_q)
|
||||
$(RACKET) -l- distro-build/install-for-docs build/docs $(CONFIG_MODE_q) "$(PKGS)" $(DOC_CATALOGS)
|
||||
$(RACKET) -l- distro-build/assemble-site $(CONFIG_MODE_q)
|
||||
|
||||
# ------------------------------------------------------------
|
||||
# Create a snapshot site:
|
||||
|
|
@ -736,4 +602,4 @@ snapshot-site:
|
|||
$(MAKE) snapshot-at-site
|
||||
|
||||
snapshot-at-site:
|
||||
$(USER_RACKET) -l- distro-build/manage-snapshots $(CONFIG_MODE_q)
|
||||
$(RACKET) -l- distro-build/manage-snapshots $(CONFIG_MODE_q)
|
||||
|
|
|
|||
28
README.md
28
README.md
|
|
@ -1,28 +0,0 @@
|
|||
This is the source code for the core of Racket. See "INSTALL.txt" for
|
||||
full information on building Racket.
|
||||
|
||||
To build the full Racket distribution from this repository, run `make`
|
||||
in the top-level directory. To build minimal Racket, run `make base`.
|
||||
|
||||
The rest of the Racket distribution source code is in other
|
||||
repositories, mostly under [the Racket GitHub
|
||||
organization](https://github.com/racket).
|
||||
|
||||
Contribute to Racket by submitting a pull request, joining the
|
||||
[development mailing list](https://lists.racket-lang.org), or visiting
|
||||
the IRC channel.
|
||||
|
||||
License
|
||||
-------
|
||||
|
||||
Racket
|
||||
Copyright (c) 2010-2018 PLT Design Inc.
|
||||
|
||||
Racket is distributed under the GNU Lesser General Public License
|
||||
(LGPL). This implies that you may link Racket into proprietary
|
||||
applications, provided you follow the rules stated in the LGPL. You can
|
||||
also modify Racket; if you distribute a modified version, you must
|
||||
distribute it under the terms of the LGPL, which in particular states
|
||||
that you must release the source code for the modified software.
|
||||
|
||||
See racket/src/COPYING_LESSER.txt for more information.
|
||||
17
README.txt
Normal file
17
README.txt
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
This is the source code for the main Racket distribution. See
|
||||
"INSTALL.txt" for information on building Racket.
|
||||
|
||||
License
|
||||
-------
|
||||
|
||||
Racket
|
||||
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
|
||||
applications, provided you follow the rules stated in the LGPL. You can
|
||||
also modify Racket; if you distribute a modified version, you must
|
||||
distribute it under the terms of the LGPL, which in particular states
|
||||
that you must release the source code for the modified software.
|
||||
|
||||
See racket/src/COPYING_LESSER.txt for more information.
|
||||
|
|
@ -6,7 +6,7 @@ cache:
|
|||
- C:\Users\appveyor\AppData\Roaming\Racket
|
||||
|
||||
build_script:
|
||||
- '"c:\Program Files (x86)\Microsoft Visual Studio 12.0\vc\vcvarsall.bat" x86'
|
||||
- '"c:\Program Files (x86)\Microsoft Visual Studio 10.0\vc\vcvarsall.bat" x86'
|
||||
- echo %cd%
|
||||
- nmake win32-in-place PKGS="racket-test unstable-flonum-lib net-test"
|
||||
|
||||
|
|
@ -27,7 +27,7 @@ test_script:
|
|||
- racket\raco.exe test -l tests/match/main
|
||||
- racket\raco.exe test -l tests/zo-path
|
||||
- racket\raco.exe test -l tests/xml/test
|
||||
- racket\raco.exe test -c tests/stxparse
|
||||
|
||||
|
||||
notifications:
|
||||
- provider: Email
|
||||
|
|
@ -38,5 +38,5 @@ notifications:
|
|||
|
||||
- provider: Slack
|
||||
auth_token:
|
||||
secure: VsZxuLzL7f/k5c/UEkiJKYxvNh9ss0Gq5ifwoZl4rlwzgtkU+2bOEo9zaP2FREF5Tb/iw4r7yQXdAYHPeo8GBQ2GQn2IksABPBEUkFrxj1k=
|
||||
secure: WCMkqS/3iB39INmhzQoZDNJ3zcOXLaRueWvaayOD9MW15DcWrGOAxz7dGrhh/EcQ
|
||||
channel: notifications
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
at-exp-lib
|
||||
Copyright (c) 2010-2018 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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang racket/base
|
||||
(module reader racket/base
|
||||
(require syntax/module-reader
|
||||
(only-in scribble/reader make-at-readtable))
|
||||
|
||||
|
|
@ -16,7 +16,15 @@
|
|||
(make-meta-reader
|
||||
'at-exp
|
||||
"language path"
|
||||
lang-reader-module-paths
|
||||
(lambda (bstr)
|
||||
(let* ([str (bytes->string/latin-1 bstr)]
|
||||
[sym (string->symbol str)])
|
||||
(and (module-path? sym)
|
||||
(vector
|
||||
;; try submod first:
|
||||
`(submod ,sym reader)
|
||||
;; fall back to /lang/reader:
|
||||
(string->symbol (string-append str "/lang/reader"))))))
|
||||
wrap-reader
|
||||
(lambda (orig-read-syntax)
|
||||
(define read-syntax (wrap-reader orig-read-syntax))
|
||||
|
|
@ -28,15 +36,15 @@
|
|||
(lambda (proc)
|
||||
(lambda (key defval)
|
||||
(define (fallback) (if proc (proc key defval) defval))
|
||||
(define (try-dynamic-require lib export)
|
||||
(with-handlers ([exn:missing-module?
|
||||
(λ (x) (fallback))])
|
||||
(dynamic-require lib export)))
|
||||
(define (try-dynamic-require mod export)
|
||||
(or (with-handlers ([exn:fail? (λ (x) #f)])
|
||||
(dynamic-require mod export))
|
||||
(fallback)))
|
||||
(case key
|
||||
[(color-lexer)
|
||||
(try-dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
|
||||
[(definitions-text-surrogate)
|
||||
'scribble/private/indentation]
|
||||
[(drracket:indentation)
|
||||
(try-dynamic-require 'scribble/private/indentation 'determine-spaces)]
|
||||
[(drracket:keystrokes)
|
||||
(try-dynamic-require 'scribble/private/indentation 'keystrokes)]
|
||||
[else (fallback)])))))
|
||||
(dynamic-require 'scribble/private/indentation 'determine-spaces)]
|
||||
[else (fallback)]))))))
|
||||
|
|
|
|||
|
|
@ -23,17 +23,13 @@
|
|||
;; Settings that apply just to the surface syntax:
|
||||
(define (scribble-base-reader-info)
|
||||
(lambda (key defval default)
|
||||
(define (try-dynamic-require lib export)
|
||||
(with-handlers ([exn:missing-module?
|
||||
(λ (x) (default key defval))])
|
||||
(dynamic-require lib export)))
|
||||
(case key
|
||||
[(color-lexer)
|
||||
(try-dynamic-require 'syntax-color/scribble-lexer 'scribble-inside-lexer)]
|
||||
(dynamic-require 'syntax-color/scribble-lexer 'scribble-inside-lexer)]
|
||||
[(definitions-text-surrogate)
|
||||
'scribble/private/indentation]
|
||||
[(drracket:indentation)
|
||||
(try-dynamic-require 'scribble/private/indentation 'determine-spaces)]
|
||||
[(drracket:keystrokes)
|
||||
(try-dynamic-require 'scribble/private/indentation 'keystrokes)]
|
||||
(dynamic-require 'scribble/private/indentation 'determine-spaces)]
|
||||
[(drracket:default-extension) "scrbl"]
|
||||
[else (default key defval)])))
|
||||
|
||||
|
|
|
|||
|
|
@ -354,7 +354,7 @@
|
|||
(maybe-merge (make-stx (read-bytes (cdadr m) inp)) r)))]
|
||||
[(*peek #rx#"^$")
|
||||
(if end-token
|
||||
(read-error* 'eof "missing closing `~a`" end-token)
|
||||
(read-error* 'eof "missing closing `~a'" end-token)
|
||||
(done-items r))]
|
||||
[else (internal-error 'get-lines*)])))
|
||||
|
||||
|
|
@ -563,7 +563,7 @@
|
|||
(lambda (char inp source-name line-num col-num position)
|
||||
(let ([m (*regexp-match #rx#"^([^|]*)\\|" inp)])
|
||||
(unless m
|
||||
(raise-read-error "unbalanced `|`" source-name
|
||||
(raise-read-error "unbalanced `|'" source-name
|
||||
line-num col-num position #f))
|
||||
(datum->syntax
|
||||
#f (string->symbol (bytes->string/utf-8 (cadr m)))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
base
|
||||
Copyright (c) 2010-2018 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
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
|
||||
(define collection 'multi)
|
||||
|
||||
(define version "7.0.0.1")
|
||||
(define version "6.4.0.15")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
|||
|
|
@ -1,11 +0,0 @@
|
|||
compiler-lib
|
||||
Copyright (c) 2010-2018 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
|
||||
applications, provided you follow the rules stated in the LGPL. You
|
||||
can also modify this package; if you distribute a modified version,
|
||||
you must distribute it under the terms of the LGPL, which in
|
||||
particular means that you must release the source code for the
|
||||
modified software. See http://www.gnu.org/copyleft/lesser.html
|
||||
for more information.
|
||||
|
|
@ -1,94 +0,0 @@
|
|||
|
||||
(module bundle-dist racket/base
|
||||
(require racket/file
|
||||
(only-in racket/base lambda)
|
||||
racket/path
|
||||
racket/system
|
||||
file/zip
|
||||
file/tar)
|
||||
|
||||
(provide bundle-put-file-extension+style+filters
|
||||
bundle-directory)
|
||||
|
||||
(define (bundle-file-suffix)
|
||||
(case (system-type)
|
||||
[(macosx) "dmg"]
|
||||
[(windows) "zip"]
|
||||
[(unix) "tgz"]))
|
||||
|
||||
(define (bundle-put-file-extension+style+filters)
|
||||
(values (bundle-file-suffix)
|
||||
null
|
||||
(case (system-type)
|
||||
[(windows) '(("Zip file" "*.zip"))]
|
||||
[(macosx) '(("Disk image" "*.dmg"))]
|
||||
[(unix) '(("Gzipped tar file" "*.tgz"))])))
|
||||
|
||||
(define (add-suffix name suffix)
|
||||
(if (filename-extension name)
|
||||
name
|
||||
(path-replace-suffix name
|
||||
(string->bytes/utf-8 (string-append "." suffix)))))
|
||||
|
||||
(define (with-prepared-directory dir for-exe? k)
|
||||
;; If `dir' contains multiple files, create a new
|
||||
;; directory that contains a copy of `dir'
|
||||
(if (and for-exe?
|
||||
(= 1 (length (directory-list dir))))
|
||||
(k dir)
|
||||
(let ([temp-dir (make-temporary-file "bundle-tmp-~a" 'directory)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let ([dest
|
||||
(let-values ([(base name dir?) (split-path dir)])
|
||||
(build-path temp-dir name))])
|
||||
(make-directory dest)
|
||||
(let loop ([src dir][dest dest])
|
||||
(for-each (lambda (f)
|
||||
(let ([src (build-path src f)]
|
||||
[dest (build-path dest f)])
|
||||
(cond
|
||||
[(directory-exists? src)
|
||||
(make-directory dest)
|
||||
(loop src dest)]
|
||||
[(file-exists? src)
|
||||
(copy-file src dest)
|
||||
(file-or-directory-modify-seconds
|
||||
dest
|
||||
(file-or-directory-modify-seconds src))])))
|
||||
(directory-list src))))
|
||||
(k temp-dir))
|
||||
(lambda () (delete-directory/files temp-dir))))))
|
||||
|
||||
(define bundle-directory
|
||||
(lambda (target dir [for-exe? #f])
|
||||
(let ([target (add-suffix target (bundle-file-suffix))])
|
||||
(case (system-type)
|
||||
[(macosx)
|
||||
(with-prepared-directory
|
||||
dir for-exe?
|
||||
(lambda (dir)
|
||||
(let* ([cout (open-output-bytes)]
|
||||
[cerr (open-output-bytes)]
|
||||
[cin (open-input-bytes #"")]
|
||||
[p (process*/ports
|
||||
cout cin cerr
|
||||
"/usr/bin/hdiutil"
|
||||
"create" "-format" "UDZO"
|
||||
"-imagekey" "zlib-level=9"
|
||||
"-mode" "555"
|
||||
"-volname" (path->string
|
||||
(path-replace-suffix (file-name-from-path target) #""))
|
||||
"-srcfolder" (path->string (cleanse-path (path->complete-path dir)))
|
||||
(path->string (cleanse-path (path->complete-path target))))])
|
||||
((list-ref p 4) 'wait)
|
||||
(unless (eq? ((list-ref p 4) 'status) 'done-ok)
|
||||
(error 'bundle-directory
|
||||
"error bundling: ~a"
|
||||
(regexp-replace #rx"[\r\n]*$" (get-output-string cerr) ""))))))]
|
||||
[(windows unix)
|
||||
(let-values ([(base name dir?) (split-path (path->complete-path dir))])
|
||||
(parameterize ([current-directory base])
|
||||
((if (eq? 'unix (system-type)) tar-gzip zip) target name)))]
|
||||
[else (error 'bundle-directory "don't know how")])))))
|
||||
|
|
@ -1,95 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
raco/command-name
|
||||
compiler/zo-parse
|
||||
compiler/decompile
|
||||
compiler/compilation-path
|
||||
racket/pretty
|
||||
racket/format)
|
||||
|
||||
(define (get-name)
|
||||
(string->symbol (short-program+command-name)))
|
||||
|
||||
(define force? #f)
|
||||
(define to-linklets? #f)
|
||||
|
||||
(define source-files
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("--force") "Ignore timestamp mimatch on associated \".zo\""
|
||||
(set! force? #t)]
|
||||
[("--columns" "-n") n "Format for <n> columns"
|
||||
(let ([num (string->number n)])
|
||||
(unless (exact-positive-integer? num)
|
||||
(raise-user-error (get-name)
|
||||
"not a valid column count: ~a" n))
|
||||
(pretty-print-columns num))]
|
||||
[("--linklet") "Decompile to linklets"
|
||||
(set! to-linklets? #t)]
|
||||
#:args source-or-bytecode-file
|
||||
source-or-bytecode-file))
|
||||
|
||||
(define (check-files orig-file alt-file)
|
||||
(cond
|
||||
[(not (file-exists? alt-file))
|
||||
(cond
|
||||
[(file-exists? orig-file)
|
||||
(unless (is-bytecode-file? orig-file)
|
||||
(raise-user-error (get-name)
|
||||
(~a "not a bytecode file, and no associated \".zo\" file;\n"
|
||||
" consider using `raco make` to compile the source file to bytecode\n"
|
||||
" path: ~a\n"
|
||||
" tried associated path: ~a")
|
||||
orig-file
|
||||
alt-file))]
|
||||
[else
|
||||
(raise-user-error (get-name)
|
||||
(~a "no such file, and no associated \".zo\" file\n"
|
||||
" path: ~a\n"
|
||||
" tried associated path: ~a")
|
||||
orig-file
|
||||
alt-file)])]
|
||||
[(not (is-bytecode-file? alt-file))
|
||||
(raise-user-error (get-name)
|
||||
(~a "associated \".zo\" file is not a bytecode file\n"
|
||||
" original path: ~a\n"
|
||||
" associated path: ~a")
|
||||
orig-file
|
||||
alt-file)]
|
||||
[(and (not force?)
|
||||
((file-or-directory-modify-seconds orig-file
|
||||
#f
|
||||
(lambda () -inf.0))
|
||||
. > .
|
||||
(file-or-directory-modify-seconds alt-file)))
|
||||
;; return a warning:
|
||||
(raise-user-error (get-name)
|
||||
(~a "associated \".zo\" file's date is older than given file's date;\n"
|
||||
" consider using `raco make` to rebuild the source file, or use `--force`\n"
|
||||
" to skip the date check\n"
|
||||
" original path: ~a\n"
|
||||
" associated path: ~a")
|
||||
orig-file
|
||||
alt-file)]))
|
||||
|
||||
(define (is-bytecode-file? orig-file)
|
||||
(call-with-input-file*
|
||||
orig-file
|
||||
(lambda (i)
|
||||
(equal? #"#~" (read-bytes 2 i)))))
|
||||
|
||||
(for ([zo-file source-files])
|
||||
(let ([zo-file (path->complete-path zo-file)])
|
||||
(let-values ([(base name dir?) (split-path zo-file)])
|
||||
(let ([alt-file (get-compilation-bytecode-file zo-file)])
|
||||
(check-files zo-file alt-file)
|
||||
(parameterize ([current-load-relative-directory base]
|
||||
[print-graph #t])
|
||||
(pretty-write
|
||||
(decompile
|
||||
#:to-linklets? to-linklets?
|
||||
(call-with-input-file*
|
||||
(if (file-exists? alt-file) alt-file zo-file)
|
||||
(lambda (in)
|
||||
(zo-parse in))))))))))
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
raco/command-name
|
||||
compiler/distribute)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
(define exe-embedded-collects-path (make-parameter #f))
|
||||
(define exe-dir-add-collects-dirs (make-parameter null))
|
||||
|
||||
(define-values (dest-dir source-files)
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("--collects-path") path "Set <path> as main collects for executables"
|
||||
(exe-embedded-collects-path path)]
|
||||
#:multi
|
||||
[("++collects-copy") dir "Add collects in <dir> to directory"
|
||||
(exe-dir-add-collects-dirs (append (exe-dir-add-collects-dirs) (list dir)))]
|
||||
#:once-each
|
||||
[("-v") "Verbose mode"
|
||||
(verbose #t)]
|
||||
#:args (dest-dir . executable)
|
||||
(values dest-dir executable)))
|
||||
|
||||
(assemble-distribution
|
||||
dest-dir
|
||||
source-files
|
||||
#:collects-path (exe-embedded-collects-path)
|
||||
#:copy-collects (exe-dir-add-collects-dirs))
|
||||
(when (verbose)
|
||||
(printf " [output to \"~a\"]\n" dest-dir))
|
||||
|
||||
(module test racket/base)
|
||||
|
|
@ -1,159 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
raco/command-name
|
||||
compiler/private/embed
|
||||
launcher/launcher
|
||||
dynext/file
|
||||
setup/dirs)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
(define very-verbose (make-parameter #f))
|
||||
|
||||
(define gui (make-parameter #f))
|
||||
(define variant (make-parameter (system-type 'gc)))
|
||||
(define launcher (make-parameter #f))
|
||||
|
||||
(define exe-output (make-parameter #f))
|
||||
(define exe-embedded-flags (make-parameter '("-U" "--")))
|
||||
(define exe-embedded-libraries (make-parameter null))
|
||||
(define exe-aux (make-parameter null))
|
||||
(define exe-embedded-config-path (make-parameter "etc"))
|
||||
(define exe-embedded-collects-path (make-parameter null))
|
||||
(define exe-embedded-collects-dest (make-parameter #f))
|
||||
|
||||
(define source-file
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("-o") file "Write executable as <file>"
|
||||
(exe-output file)]
|
||||
[("--gui") "Generate GUI executable"
|
||||
(gui #t)]
|
||||
[("-l" "--launcher") "Generate a launcher"
|
||||
(when (or (find-addon-tethered-gui-bin-dir)
|
||||
(find-addon-tethered-console-bin-dir))
|
||||
;; When an addon-executable directory is configured, treat the
|
||||
;; addon directory more like an installation directory, instead
|
||||
;; of a user-specific directory: record it, and remove the -U
|
||||
;; flag (if any)
|
||||
(exe-embedded-flags
|
||||
(append
|
||||
(list "-A" (path->string (find-system-path 'addon-dir)))
|
||||
(remove "-U" (exe-embedded-flags)))))
|
||||
(launcher #t)]
|
||||
[("--embed-dlls") "On Windows, embed DLLs in the executable"
|
||||
(exe-aux (cons (cons 'embed-dlls? #t) (exe-aux)))]
|
||||
[("--config-path") path "Set <path> as configuration directory for executable"
|
||||
(exe-embedded-config-path path)]
|
||||
[("--collects-path") path "Set <path> as main collects for executable"
|
||||
(exe-embedded-collects-path path)]
|
||||
[("--collects-dest") dir "Write collection code to <dir>"
|
||||
(exe-embedded-collects-dest dir)]
|
||||
[("--ico") .ico-file "Set Windows icon for executable"
|
||||
(exe-aux (cons (cons 'ico .ico-file) (exe-aux)))]
|
||||
[("--icns") .icns-file "Set Mac OS icon for executable"
|
||||
(exe-aux (cons (cons 'icns .icns-file) (exe-aux)))]
|
||||
[("--orig-exe") "Use original executable instead of stub"
|
||||
(exe-aux (cons (cons 'original-exe? #t) (exe-aux)))]
|
||||
[("--3m") "Generate using 3m variant"
|
||||
(variant '3m)]
|
||||
[("--cgc") "Generate using CGC variant"
|
||||
(variant 'cgc)]
|
||||
[("--cs") "Generate using CS variant"
|
||||
(variant 'cs)]
|
||||
#:multi
|
||||
[("++aux") aux-file "Extra executable info (based on <aux-file> suffix)"
|
||||
(let ([auxes (extract-aux-from-path (path->complete-path aux-file))])
|
||||
(when (null? auxes)
|
||||
(printf " warning: no recognized information from ~s\n" aux-file))
|
||||
(exe-aux (append auxes (exe-aux))))]
|
||||
[("++lib") lib "Embed <lib> in executable"
|
||||
(exe-embedded-libraries (append (exe-embedded-libraries) (list lib)))]
|
||||
[("++exf") flag "Add flag to embed in executable"
|
||||
(exe-embedded-flags (append (exe-embedded-flags) (list flag)))]
|
||||
[("--exf") flag "Remove flag to embed in executable"
|
||||
(exe-embedded-flags (remove flag (exe-embedded-flags)))]
|
||||
[("--exf-clear") "Clear flags to embed in executable"
|
||||
(exe-embedded-flags null)]
|
||||
[("--exf-show") "Show flags to embed in executable"
|
||||
(printf "Flags to embed: ~s\n" (exe-embedded-flags))]
|
||||
#:once-each
|
||||
[("-v") "Verbose mode"
|
||||
(verbose #t)]
|
||||
[("--vv") "Very verbose mode"
|
||||
(verbose #t)
|
||||
(very-verbose #t)]
|
||||
#:args (source-file)
|
||||
source-file))
|
||||
|
||||
(let ([dest (mzc:embedding-executable-add-suffix
|
||||
(or (exe-output)
|
||||
(extract-base-filename/ss source-file
|
||||
(string->symbol (short-program+command-name))))
|
||||
(gui))])
|
||||
(unless (file-exists? source-file)
|
||||
(raise-user-error (string->symbol (short-program+command-name))
|
||||
"source file does not exist\n path: ~a" source-file))
|
||||
(with-handlers ([exn:fail:filesystem? (lambda (exn) (void))])
|
||||
(call-with-input-file* dest
|
||||
(lambda (dest-in)
|
||||
(call-with-input-file* source-file
|
||||
(lambda (source-in)
|
||||
(when (equal? (port-file-identity dest-in)
|
||||
(port-file-identity source-in))
|
||||
(raise-user-error (string->symbol (short-program+command-name))
|
||||
(string-append
|
||||
"source file is the same as the destination file"
|
||||
"\n source path: ~a"
|
||||
"\n destination path: ~a")
|
||||
source-file
|
||||
dest)))))))
|
||||
(cond
|
||||
[(launcher)
|
||||
(parameterize ([current-launcher-variant (variant)])
|
||||
((if (gui)
|
||||
make-gracket-launcher
|
||||
make-racket-launcher)
|
||||
(append (list "-t" (path->string (path->complete-path source-file)))
|
||||
(exe-embedded-flags))
|
||||
dest
|
||||
(exe-aux)))]
|
||||
[else
|
||||
(define mod-sym (string->symbol
|
||||
(format "#%mzc:~a"
|
||||
(let-values ([(base name dir?)
|
||||
(split-path source-file)])
|
||||
(path->bytes (path-replace-suffix name #""))))))
|
||||
(mzc:create-embedding-executable
|
||||
dest
|
||||
#:mred? (gui)
|
||||
#:variant (variant)
|
||||
#:verbose? (very-verbose)
|
||||
#:modules (cons `(#%mzc: (file ,source-file) (main configure-runtime))
|
||||
(map (lambda (l) `(#t (lib ,l)))
|
||||
(exe-embedded-libraries)))
|
||||
#:configure-via-first-module? #t
|
||||
#:early-literal-expressions
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(define cr-sym (string->symbol (format "~a(configure-runtime)" mod-sym)))
|
||||
(list
|
||||
(compile
|
||||
`(when (module-declared? '',cr-sym)
|
||||
(dynamic-require '',cr-sym #f)))))
|
||||
#:literal-expression
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(define main-sym (string->symbol (format "~a(main)" mod-sym)))
|
||||
(compile
|
||||
`(begin
|
||||
(namespace-require '',mod-sym)
|
||||
(when (module-declared? '',main-sym)
|
||||
(dynamic-require '',main-sym #f)))))
|
||||
#:cmdline (exe-embedded-flags)
|
||||
#:collects-path (exe-embedded-collects-path)
|
||||
#:collects-dest (exe-embedded-collects-dest)
|
||||
#:aux (cons `(config-dir . ,(exe-embedded-config-path))
|
||||
(exe-aux)))])
|
||||
(when (verbose)
|
||||
(printf " [output to \"~a\"]\n" dest)))
|
||||
|
||||
(module test racket/base)
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module expand racket/base
|
||||
(require racket/cmdline
|
||||
raco/command-name
|
||||
racket/pretty)
|
||||
|
||||
(provide show-program)
|
||||
|
||||
(define (show-program expand)
|
||||
(define source-files
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("--columns" "-n") n "Format for <n> columns"
|
||||
(let ([num (string->number n)])
|
||||
(unless (exact-positive-integer? num)
|
||||
(raise-user-error (string->symbol (short-program+command-name))
|
||||
"not a valid column count: ~a" n))
|
||||
(pretty-print-columns num))]
|
||||
#:args source-file
|
||||
source-file))
|
||||
|
||||
(for ([src-file source-files])
|
||||
(let ([src-file (path->complete-path src-file)])
|
||||
(let-values ([(base name dir?) (split-path src-file)])
|
||||
(parameterize ([current-load-relative-directory base]
|
||||
[current-namespace (make-base-namespace)]
|
||||
[read-accept-reader #t])
|
||||
(call-with-input-file*
|
||||
src-file
|
||||
(lambda (in)
|
||||
(port-count-lines! in)
|
||||
(let loop ()
|
||||
(let ([e (read-syntax src-file in)])
|
||||
(unless (eof-object? e)
|
||||
(pretty-write (syntax->datum (expand e)))
|
||||
(loop))))))))))))
|
||||
|
||||
(require (submod "." expand))
|
||||
(show-program expand)
|
||||
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define raco-commands
|
||||
'(("make" compiler/commands/make "compile source to bytecode" 100)
|
||||
("exe" compiler/commands/exe "create executable" 20)
|
||||
("pack" compiler/commands/pack "pack files/collections into a .plt archive" #f)
|
||||
("unpack" compiler/commands/unpack "unpack files/collections from a .plt archive" #f)
|
||||
("decompile" compiler/commands/decompile "decompile bytecode" #f)
|
||||
("test" compiler/commands/test "run tests associated with files/directories" 15)
|
||||
("expand" compiler/commands/expand "macro-expand source" #f)
|
||||
("read" compiler/commands/read "read and pretty-print source" #f)
|
||||
("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)
|
||||
("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f)))
|
||||
|
||||
(define test-responsibles '(("test.rkt" jay)))
|
||||
|
|
@ -1,119 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
raco/command-name
|
||||
compiler/cm
|
||||
compiler/compiler
|
||||
compiler/compilation-path
|
||||
dynext/file
|
||||
setup/parallel-build
|
||||
setup/path-to-relative
|
||||
racket/match)
|
||||
|
||||
(module test racket/base)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
(define very-verbose (make-parameter #f))
|
||||
(define disable-inlining (make-parameter #f))
|
||||
|
||||
(define disable-deps (make-parameter #f))
|
||||
(define disable-const (make-parameter #f))
|
||||
(define prefixes (make-parameter null))
|
||||
(define assume-primitives (make-parameter #t))
|
||||
(define worker-count (make-parameter 1))
|
||||
|
||||
(define mzc-symbol (string->symbol (short-program+command-name)))
|
||||
|
||||
(define source-files
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("-j") n "Compile with up to <n> tasks in parallel"
|
||||
(let ([num (string->number n)])
|
||||
(unless num (raise-user-error (format "~a: bad count for -j: ~s"
|
||||
(short-program+command-name)
|
||||
n)))
|
||||
(worker-count num))]
|
||||
[("--disable-inline") "Disable procedure inlining during compilation"
|
||||
(disable-inlining #t)]
|
||||
[("--disable-constant") "Disable enforcement of module constants"
|
||||
(disable-const #t)]
|
||||
[("--no-deps") "Compile immediate files without updating dependencies"
|
||||
(disable-deps #t)]
|
||||
[("-p" "--prefix") file "Add elaboration-time prefix file for --no-deps"
|
||||
(prefixes (append (prefixes) (list file)))]
|
||||
[("--no-prim") "Do not assume `scheme' bindings at top level for --no-deps"
|
||||
(assume-primitives #f)]
|
||||
[("-v") "Verbose mode"
|
||||
(verbose #t)]
|
||||
[("--vv") "Very verbose mode"
|
||||
(verbose #t)
|
||||
(very-verbose #t)]
|
||||
#:args (file . another-file) (cons file another-file)))
|
||||
|
||||
(cond
|
||||
;; Just compile one file:
|
||||
[(disable-deps)
|
||||
(let ([prefix
|
||||
`(begin
|
||||
(require scheme)
|
||||
,(if (assume-primitives)
|
||||
'(void)
|
||||
'(namespace-require/copy 'scheme))
|
||||
,@(map (lambda (s) `(load ,s)) (prefixes))
|
||||
(void))])
|
||||
((compile-zos prefix #:verbose? (verbose))
|
||||
source-files
|
||||
'auto))]
|
||||
;; Normal make:
|
||||
[(= (worker-count) 1)
|
||||
(let ([n (make-base-empty-namespace)]
|
||||
[did-one? #f])
|
||||
(parameterize ([current-namespace n]
|
||||
[manager-trace-handler
|
||||
(if (very-verbose)
|
||||
(λ (p) (printf " ~a\n" p))
|
||||
(manager-trace-handler))]
|
||||
[manager-compile-notify-handler
|
||||
(lambda (p)
|
||||
(set! did-one? #t)
|
||||
(when (verbose)
|
||||
(printf " making ~s\n" p)))])
|
||||
(for ([file source-files])
|
||||
(unless (file-exists? file)
|
||||
(error mzc-symbol "file does not exist: ~a" file))
|
||||
(set! did-one? #f)
|
||||
(let ([name (extract-base-filename/ss file mzc-symbol)])
|
||||
(when (verbose)
|
||||
(printf "\"~a\":\n" file))
|
||||
(parameterize ([compile-context-preservation-enabled
|
||||
(disable-inlining)]
|
||||
[compile-enforce-module-constants
|
||||
(not (disable-const))])
|
||||
(managed-compile-zo file))
|
||||
(when (verbose)
|
||||
(printf " [~a \"~a\"]\n"
|
||||
(if did-one? "output to" "already up-to-date at")
|
||||
(get-compilation-bytecode-file file)))))))]
|
||||
;; Parallel make:
|
||||
[else
|
||||
(define path-cache (make-hash))
|
||||
(or (parallel-compile-files
|
||||
source-files
|
||||
#:worker-count (worker-count)
|
||||
#:handler (lambda (id type work msg out err)
|
||||
(define (->rel p)
|
||||
(path->relative-string/library p #:cache path-cache))
|
||||
(match type
|
||||
['start (when (verbose) (printf " ~a making ~a\n" id (->rel work)))]
|
||||
['done (when (verbose) (printf " ~a made ~a\n" id (->rel work)))]
|
||||
['output (printf " ~a output from: ~a\n~a~a" id work out err)]
|
||||
[else (printf " ~a error compiling ~a\n~a\n~a~a" id work msg out err)]))
|
||||
#:options (let ([cons-if-true (lambda (bool carv cdrv)
|
||||
(if bool
|
||||
(cons carv cdrv)
|
||||
cdrv))])
|
||||
(cons-if-true
|
||||
(very-verbose)
|
||||
'very-verbose
|
||||
(cons-if-true (disable-inlining) 'disable-inlining null))))
|
||||
(exit 1))])
|
||||
|
|
@ -1,99 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
raco/command-name
|
||||
setup/pack
|
||||
setup/getinfo
|
||||
compiler/distribute)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
|
||||
(define collection? (make-parameter #f))
|
||||
|
||||
(define default-plt-name "archive")
|
||||
|
||||
(define plt-name (make-parameter default-plt-name))
|
||||
(define plt-files-replace (make-parameter #f))
|
||||
(define plt-files-plt-relative? (make-parameter #f))
|
||||
(define plt-files-plt-home-relative? (make-parameter #f))
|
||||
(define plt-force-install-dir? (make-parameter #f))
|
||||
(define plt-setup-collections (make-parameter null))
|
||||
(define plt-include-compiled (make-parameter #f))
|
||||
|
||||
(define mzc-symbol (string->symbol (short-program+command-name)))
|
||||
|
||||
(define-values (plt-output source-files)
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("--collect") "<path>s specify collections instead of files/dirs"
|
||||
(collection? #t)]
|
||||
[("--plt-name") name "Set the printed <name> describing the archive"
|
||||
(plt-name name)]
|
||||
[("--replace") "Files in archive replace existing files when unpacked"
|
||||
(plt-files-replace #t)]
|
||||
[("--at-plt") "Files/dirs in archive are relative to user's add-ons directory"
|
||||
(plt-files-plt-relative? #t)]
|
||||
#:once-any
|
||||
[("--all-users") "Files/dirs in archive go to PLT installation if writable"
|
||||
(plt-files-plt-home-relative? #t)]
|
||||
[("--force-all-users") "Files/dirs forced to PLT installation"
|
||||
(plt-files-plt-home-relative? #t) (plt-force-install-dir? #t)]
|
||||
#:once-each
|
||||
[("--include-compiled") "Include \"compiled\" subdirectories in the archive"
|
||||
(plt-include-compiled #t)]
|
||||
#:multi
|
||||
[("++setup") collect "Setup <collect> after the archive is unpacked"
|
||||
(plt-setup-collections (append (plt-setup-collections) (list collect)))]
|
||||
#:once-each
|
||||
[("-v") "Verbose mode"
|
||||
(verbose #t)]
|
||||
#:args (dest-file . path)
|
||||
(values dest-file path)))
|
||||
|
||||
(if (not (collection?))
|
||||
;; Files and directories
|
||||
(begin
|
||||
(for ([fd source-files])
|
||||
(unless (relative-path? fd)
|
||||
(error mzc-symbol
|
||||
"file/directory is not relative to the current directory: \"~a\""
|
||||
fd)))
|
||||
(pack-plt plt-output
|
||||
(plt-name)
|
||||
source-files
|
||||
#:collections (map list (plt-setup-collections))
|
||||
#:file-mode (if (plt-files-replace) 'file-replace 'file)
|
||||
#:plt-relative? (or (plt-files-plt-relative?)
|
||||
(plt-files-plt-home-relative?))
|
||||
#:at-plt-home? (plt-files-plt-home-relative?)
|
||||
#:test-plt-dirs (if (or (plt-force-install-dir?)
|
||||
(not (plt-files-plt-home-relative?)))
|
||||
#f
|
||||
'("collects" "doc" "include" "lib"))
|
||||
#:requires
|
||||
null)
|
||||
(when (verbose)
|
||||
(printf " [output to \"~a\"]\n" plt-output)))
|
||||
;; Collection
|
||||
(begin
|
||||
(pack-collections-plt
|
||||
plt-output
|
||||
(if (eq? default-plt-name (plt-name)) #f (plt-name))
|
||||
(map (lambda (sf)
|
||||
(let loop ([sf sf])
|
||||
(let ([m (regexp-match "^([^/]*)/(.*)$" sf)])
|
||||
(if m (cons (cadr m) (loop (caddr m))) (list sf)))))
|
||||
source-files)
|
||||
#:replace? (plt-files-replace)
|
||||
#:extra-setup-collections (map list (plt-setup-collections))
|
||||
#:file-filter (if (plt-include-compiled)
|
||||
(lambda (path)
|
||||
(or (regexp-match #rx#"compiled$" (path->bytes path))
|
||||
(std-filter path)))
|
||||
std-filter)
|
||||
#:at-plt-home? (plt-files-plt-home-relative?)
|
||||
#:test-plt-collects? (not (plt-force-install-dir?)))
|
||||
(when (verbose)
|
||||
(printf " [output to \"~a\"]\n" plt-output))))
|
||||
|
||||
(module test racket/base)
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (submod "expand.rkt" expand))
|
||||
|
||||
(show-program (lambda (e) e))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,102 +0,0 @@
|
|||
#lang scheme/base
|
||||
(require scheme/cmdline
|
||||
raco/command-name
|
||||
setup/unpack
|
||||
racket/file
|
||||
racket/port
|
||||
racket/match
|
||||
racket/string
|
||||
racket/pretty)
|
||||
|
||||
(define verbose (make-parameter #f))
|
||||
|
||||
(define just-show? (make-parameter #f))
|
||||
(define replace? (make-parameter #f))
|
||||
(define show-config? (make-parameter #f))
|
||||
|
||||
(define mzc-symbol (string->symbol (short-program+command-name)))
|
||||
|
||||
(define files
|
||||
(command-line
|
||||
#:program (short-program+command-name)
|
||||
#:once-each
|
||||
[("-l" "--list") "just list archive content"
|
||||
(just-show? #t)]
|
||||
[("-c" "--config") "show archive configuration"
|
||||
(show-config? #t)]
|
||||
[("-f" "--force") "replace existing files when unpacking"
|
||||
(replace? #t)]
|
||||
#:args archive
|
||||
archive))
|
||||
|
||||
(define (desc->path dir)
|
||||
(if (path? dir)
|
||||
dir
|
||||
(apply build-path
|
||||
(symbol->string (car dir))
|
||||
(cdr dir))))
|
||||
|
||||
(for ([filename (in-list files)])
|
||||
(fold-plt-archive filename
|
||||
(lambda (config a)
|
||||
(when (show-config?)
|
||||
(match config
|
||||
[`(lambda (request failure)
|
||||
(case request
|
||||
((name) ,name)
|
||||
((unpacker) (quote mzscheme))
|
||||
((requires) (quote ,reqs))
|
||||
((conflicts) (quote ,conflicts))
|
||||
((plt-relative?) ,plt-rel?)
|
||||
((plt-home-relative?) ,plt-home-rel?)
|
||||
((test-plt-dirs) ,test-plt-dirs)
|
||||
(else (failure))))
|
||||
(printf "config:\n")
|
||||
(printf " name: ~s\n" name)
|
||||
(printf " requires:\n")
|
||||
(for ([c (in-list reqs)])
|
||||
(printf " ~s ~s\n" (string-join (car c) "/") (cadr c)))
|
||||
(printf " conflicts:\n")
|
||||
(for ([c (in-list conflicts)])
|
||||
(printf " ~s\n" (string-join c "/")))
|
||||
(cond
|
||||
[plt-home-rel? (printf " unpack to main installation\n")]
|
||||
[plt-rel? (printf " unpack to user add-ons\n")]
|
||||
[else (printf " unpack locally\n")])]
|
||||
[else
|
||||
(printf "config function:\n")
|
||||
(pretty-write config)]))
|
||||
a)
|
||||
(lambda (setup i a)
|
||||
(when (show-config?)
|
||||
(match setup
|
||||
[`(unit (import main-collects-parent-dir mzuntar) (export) (mzuntar void) (quote ,c))
|
||||
(printf "setup collections:\n")
|
||||
(for ([c (in-list c)])
|
||||
(printf " ~s\n" (string-join c "/")))]
|
||||
[else
|
||||
(printf "setup unit:\n")
|
||||
(pretty-write setup)]))
|
||||
a)
|
||||
(lambda (dir a)
|
||||
(unless (eq? dir 'same)
|
||||
(if (just-show?)
|
||||
(printf "~a\n" (path->directory-path (desc->path dir)))
|
||||
(make-directory* (desc->path dir))))
|
||||
a)
|
||||
(lambda (file i kind a)
|
||||
(if (just-show?)
|
||||
(printf "~a~a\n" (desc->path file)
|
||||
(if (eq? kind 'file-replace)
|
||||
" [replace]"
|
||||
""))
|
||||
(call-with-output-file*
|
||||
(desc->path file)
|
||||
#:exists (if (or (eq? kind 'file-replace)
|
||||
(replace?))
|
||||
'truncate/replace
|
||||
'error)
|
||||
(lambda (o)
|
||||
(copy-port i o))))
|
||||
a)
|
||||
(void)))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require compiler/compiler compiler/sig racket/unit)
|
||||
(provide compiler@)
|
||||
(define-unit-from-context compiler@ compiler^)
|
||||
|
|
@ -1,738 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/linklet
|
||||
compiler/zo-parse
|
||||
compiler/zo-marshal
|
||||
syntax/modcollapse
|
||||
racket/port
|
||||
racket/match
|
||||
racket/list
|
||||
racket/set
|
||||
racket/path
|
||||
(only-in '#%linklet compiled-position->primitive)
|
||||
"private/deserialize.rkt")
|
||||
|
||||
(provide decompile)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define primitive-table
|
||||
(let ([value-names (let ([ns (make-base-empty-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require ''#%kernel)
|
||||
(namespace-require ''#%unsafe)
|
||||
(namespace-require ''#%flfxnum)
|
||||
(namespace-require ''#%extfl)
|
||||
(namespace-require ''#%futures)
|
||||
(namespace-require ''#%foreign)
|
||||
(namespace-require ''#%paramz)
|
||||
(for/hasheq ([name (in-list (namespace-mapped-symbols))])
|
||||
(values (namespace-variable-value name #t (lambda () #f))
|
||||
name))))])
|
||||
(for/hash ([i (in-naturals)]
|
||||
#:break (not (compiled-position->primitive i)))
|
||||
(define v (compiled-position->primitive i))
|
||||
(values i (or (hash-ref value-names v #f) `',v)))))
|
||||
|
||||
(define (list-ref/protect l pos who)
|
||||
(list-ref l pos)
|
||||
#;
|
||||
(if (pos . < . (length l))
|
||||
(list-ref l pos)
|
||||
`(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-struct glob-desc (vars))
|
||||
|
||||
;; Main entry:
|
||||
(define (decompile top #:to-linklets? [to-linklets? #f])
|
||||
(cond
|
||||
[(linkl-directory? top)
|
||||
(cond
|
||||
[to-linklets?
|
||||
(cons
|
||||
'linklet-directory
|
||||
(apply
|
||||
append
|
||||
(for/list ([(k v) (in-hash (linkl-directory-table top))])
|
||||
(list '#:name k '#:bundle (decompile v #:to-linklets? to-linklets?)))))]
|
||||
[else
|
||||
(define main (hash-ref (linkl-directory-table top) '() #f))
|
||||
(cond
|
||||
[(and main
|
||||
(hash-ref (linkl-bundle-table main) 'decl #f))
|
||||
(decompile-module-with-submodules top '() main)]
|
||||
[main
|
||||
(decompile-single-top main)]
|
||||
[else
|
||||
(decompile-multi-top top)])])]
|
||||
[(linkl-bundle? top)
|
||||
(cond
|
||||
[to-linklets?
|
||||
(cons
|
||||
'linklet-bundle
|
||||
(apply
|
||||
append
|
||||
(for/list ([(k v) (in-hash (linkl-bundle-table top))])
|
||||
(case (and (not to-linklets?) k)
|
||||
[(stx-data)
|
||||
(list '#:stx-data (decompile-data-linklet v))]
|
||||
[else
|
||||
(list '#:key k '#:value (decompile v #:to-linklets? to-linklets?))]))))]
|
||||
[else
|
||||
(decompile-module top)])]
|
||||
[(linkl? top)
|
||||
(decompile-linklet top)]
|
||||
[else `(quote ,top)]))
|
||||
|
||||
(define (decompile-module-with-submodules l-dir name-list main-l)
|
||||
(decompile-module main-l
|
||||
(lambda ()
|
||||
(for/list ([(k l) (in-hash (linkl-directory-table l-dir))]
|
||||
#:when (and (list? k)
|
||||
(= (length k) (add1 (length name-list)))
|
||||
(for/and ([s1 (in-list name-list)]
|
||||
[s2 (in-list k)])
|
||||
(eq? s1 s2))))
|
||||
(decompile-module-with-submodules l-dir k l)))))
|
||||
|
||||
(define (decompile-module l [get-nested (lambda () '())])
|
||||
(define ht (linkl-bundle-table l))
|
||||
(define phases (sort (for/list ([k (in-hash-keys ht)]
|
||||
#:when (exact-integer? k))
|
||||
k)
|
||||
<))
|
||||
(define-values (mpi-vector requires provides)
|
||||
(let ([data-l (hash-ref ht 'data #f)]
|
||||
[decl-l (hash-ref ht 'decl #f)])
|
||||
(define (zo->linklet l)
|
||||
(let ([o (open-output-bytes)])
|
||||
(zo-marshal-to (linkl-bundle (hasheq 'data l)) o)
|
||||
(parameterize ([read-accept-compiled #t])
|
||||
(define b (read (open-input-bytes (get-output-bytes o))))
|
||||
(hash-ref (linklet-bundle->hash b) 'data))))
|
||||
(cond
|
||||
[(and data-l
|
||||
decl-l)
|
||||
(define data-i (instantiate-linklet (zo->linklet data-l)
|
||||
(list deserialize-instance)))
|
||||
(define decl-i (instantiate-linklet (zo->linklet decl-l)
|
||||
(list deserialize-instance
|
||||
data-i)))
|
||||
(values (instance-variable-value data-i '.mpi-vector)
|
||||
(instance-variable-value decl-i 'requires)
|
||||
(instance-variable-value decl-i 'provides))]
|
||||
[else (values '#() '() '#hasheqv())])))
|
||||
(define (phase-wrap phase l)
|
||||
(case phase
|
||||
[(0) l]
|
||||
[(1) `((for-syntax ,@l))]
|
||||
[(-1) `((for-template ,@l))]
|
||||
[(#f) `((for-label ,@l))]
|
||||
[else `((for-meta ,phase ,@l))]))
|
||||
`(module ,(hash-ref ht 'name 'unknown) ....
|
||||
(require ,@(apply
|
||||
append
|
||||
(for/list ([phase+mpis (in-list requires)])
|
||||
(phase-wrap (car phase+mpis)
|
||||
(map collapse-module-path-index (cdr phase+mpis))))))
|
||||
(provide ,@(apply
|
||||
append
|
||||
(for/list ([(phase ht) (in-hash provides)])
|
||||
(phase-wrap phase (hash-keys ht)))))
|
||||
,@(let loop ([phases phases] [depth 0])
|
||||
(cond
|
||||
[(null? phases) '()]
|
||||
[(= depth (car phases))
|
||||
(append
|
||||
(decompile-linklet (hash-ref ht (car phases)) #:just-body? #t)
|
||||
(loop (cdr phases) depth))]
|
||||
[else
|
||||
(define l (loop phases (add1 depth)))
|
||||
(define (convert-syntax-definition s wrap)
|
||||
(match s
|
||||
[`(let ,bindings ,body)
|
||||
(convert-syntax-definition body
|
||||
(lambda (rhs)
|
||||
`(let ,bindings
|
||||
,rhs)))]
|
||||
[`(begin (.set-transformer! ',id ,rhs) ',(? void?))
|
||||
`(define-syntaxes ,id ,(wrap rhs))]
|
||||
[`(begin (.set-transformer! ',ids ,rhss) ... ',(? void?))
|
||||
`(define-syntaxes ,ids ,(wrap `(values . ,rhss)))]
|
||||
[_ #f]))
|
||||
(let loop ([l l] [accum '()])
|
||||
(cond
|
||||
[(null? l) (if (null? accum)
|
||||
'()
|
||||
`((begin-for-syntax ,@(reverse accum))))]
|
||||
[(convert-syntax-definition (car l) values)
|
||||
=> (lambda (s)
|
||||
(append (loop null accum)
|
||||
(cons s (loop (cdr l) null))))]
|
||||
[else
|
||||
(loop (cdr l) (cons (car l) accum))]))]))
|
||||
,@(get-nested)
|
||||
,@(let ([l (hash-ref ht 'stx-data #f)])
|
||||
(if l
|
||||
`((begin-for-all
|
||||
(define (.get-syntax-literal! pos)
|
||||
....
|
||||
,(decompile-data-linklet l)
|
||||
....)))
|
||||
null))))
|
||||
|
||||
(define (decompile-single-top b)
|
||||
(define forms (decompile-linklet (hash-ref (linkl-bundle-table b) 0) #:just-body? #t))
|
||||
(if (= (length forms) 1)
|
||||
(car forms)
|
||||
`(begin ,@forms)))
|
||||
|
||||
(define (decompile-multi-top ld)
|
||||
`(begin
|
||||
,@(let loop ([i 0])
|
||||
(define b (hash-ref (linkl-directory-table ld) (list (string->symbol (format "~a" i))) #f))
|
||||
(define l (and b (hash-ref (linkl-bundle-table b) 0 #f)))
|
||||
(cond
|
||||
[l (append (decompile-linklet l #:just-body? #t)
|
||||
(loop (add1 i)))]
|
||||
[else null]))))
|
||||
|
||||
(define (decompile-linklet l #:just-body? [just-body? #f])
|
||||
(match l
|
||||
[(struct linkl (name importss import-shapess exports internals lifts source-names body max-let-depth needs-instance?))
|
||||
(define closed (make-hasheq))
|
||||
(define globs (glob-desc
|
||||
(append
|
||||
(list 'root)
|
||||
(apply append importss)
|
||||
exports
|
||||
internals
|
||||
lifts)))
|
||||
(define body-l
|
||||
(for/list ([form (in-list body)])
|
||||
(decompile-form form globs '(#%globals) closed)))
|
||||
(if just-body?
|
||||
body-l
|
||||
`(linklet
|
||||
,importss
|
||||
,exports
|
||||
'(import-shapes: ,@(for/list ([imports (in-list importss)]
|
||||
[import-shapes (in-list import-shapess)]
|
||||
#:when #t
|
||||
[import (in-list imports)]
|
||||
[import-shape (in-list import-shapes)]
|
||||
#:when import-shape)
|
||||
`[,import ,import-shape]))
|
||||
,@body-l))]))
|
||||
|
||||
(define (decompile-data-linklet l)
|
||||
(match l
|
||||
[(struct linkl (_ _ _ _ _ _ _ (list vec-def (struct def-values (_ deser-lam))) _ _))
|
||||
(match deser-lam
|
||||
[(struct lam (_ _ _ _ _ _ _ _ _ (struct seq ((list vec-copy! _)))))
|
||||
(match vec-copy!
|
||||
[(struct application (_ (list _ _ (struct application (_ (list mpi-vector inspector bulk-binding-registry
|
||||
num-mutables mutable-vec
|
||||
num-shares share-vec
|
||||
mutable-fill-vec
|
||||
result-vec))))))
|
||||
(decompile-deserialize '.mpi-vector '.inspector '.bulk-binding-registry
|
||||
num-mutables mutable-vec
|
||||
num-shares share-vec
|
||||
mutable-fill-vec
|
||||
result-vec)]
|
||||
[else
|
||||
(decompile-linklet l)])]
|
||||
[else
|
||||
(decompile-linklet l)])]
|
||||
[else
|
||||
(decompile-linklet l)]))
|
||||
|
||||
(define (decompile-form form globs stack closed)
|
||||
(match form
|
||||
[(struct def-values (ids rhs))
|
||||
`(define-values ,(map (lambda (tl)
|
||||
(match tl
|
||||
[(struct toplevel (depth pos const? set-const?))
|
||||
(list-ref/protect (glob-desc-vars globs) pos 'def-vals)]))
|
||||
ids)
|
||||
,(if (inline-variant? rhs)
|
||||
`(begin
|
||||
,(list 'quote '%%inline-variant%%)
|
||||
,(decompile-expr (inline-variant-inline rhs) globs stack closed)
|
||||
,(decompile-expr (inline-variant-direct rhs) globs stack closed))
|
||||
(decompile-expr rhs globs stack closed)))]
|
||||
[(struct seq (forms))
|
||||
`(begin ,@(map (lambda (form)
|
||||
(decompile-form form globs stack closed))
|
||||
forms))]
|
||||
[else
|
||||
(decompile-expr form globs stack closed)]))
|
||||
|
||||
(define (extract-name name)
|
||||
(if (symbol? name)
|
||||
(gensym name)
|
||||
(if (vector? name)
|
||||
(gensym (vector-ref name 0))
|
||||
#f)))
|
||||
|
||||
(define (extract-id expr)
|
||||
(match expr
|
||||
[(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
|
||||
(extract-name name)]
|
||||
[(struct case-lam (name lams))
|
||||
(extract-name name)]
|
||||
[(struct closure (lam gen-id))
|
||||
(extract-id lam)]
|
||||
[else #f]))
|
||||
|
||||
(define (extract-ids! body ids)
|
||||
(match body
|
||||
[(struct let-rec (procs body))
|
||||
(for ([proc (in-list procs)]
|
||||
[delta (in-naturals)])
|
||||
(when (< -1 delta (vector-length ids))
|
||||
(vector-set! ids delta (extract-id proc))))
|
||||
(extract-ids! body ids)]
|
||||
[(struct install-value (val-count pos boxes? rhs body))
|
||||
(extract-ids! body ids)]
|
||||
[(struct boxenv (pos body))
|
||||
(extract-ids! body ids)]
|
||||
[else #f]))
|
||||
|
||||
(define (decompile-tl expr globs stack closed no-check?)
|
||||
(match expr
|
||||
[(struct toplevel (depth pos const? ready?))
|
||||
(let ([id (list-ref/protect (glob-desc-vars globs) pos 'toplevel)])
|
||||
(cond
|
||||
[no-check? id]
|
||||
[(and (not const?) (not ready?))
|
||||
`(#%checked ,id)]
|
||||
#;[(and const? ready?) `(#%const ,id)]
|
||||
#;[const? `(#%iconst ,id)]
|
||||
[else id]))]))
|
||||
|
||||
(define (decompile-expr expr globs stack closed)
|
||||
(match expr
|
||||
[(struct toplevel (depth pos const? ready?))
|
||||
(decompile-tl expr globs stack closed #f)]
|
||||
[(struct varref (tl dummy constant? from-unsafe?))
|
||||
`(#%variable-reference . ,(cond
|
||||
[(not tl) '()]
|
||||
[(eq? tl #t) '(<constant-local>)]
|
||||
[(symbol? tl) (list tl)] ; primitive
|
||||
[else (list (decompile-tl tl globs stack closed #t))]))]
|
||||
[(struct primval (id))
|
||||
(hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))]
|
||||
[(struct assign (id rhs undef-ok?))
|
||||
`(set! ,(decompile-expr id globs stack closed)
|
||||
,(decompile-expr rhs globs stack closed))]
|
||||
[(struct localref (unbox? offset clear? other-clears? type))
|
||||
(let ([id (list-ref/protect stack offset 'localref)])
|
||||
(let ([e (if unbox?
|
||||
`(#%unbox ,id)
|
||||
id)])
|
||||
(if clear?
|
||||
`(#%sfs-clear ,e)
|
||||
e)))]
|
||||
[(? lam?)
|
||||
`(lambda . ,(decompile-lam expr globs stack closed))]
|
||||
[(struct case-lam (name lams))
|
||||
`(case-lambda
|
||||
,@(map (lambda (lam)
|
||||
(decompile-lam lam globs stack closed))
|
||||
lams))]
|
||||
[(struct let-one (rhs body type unused?))
|
||||
(let ([id (or (extract-id rhs)
|
||||
(gensym (or type (if unused? 'unused 'local))))])
|
||||
`(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
|
||||
,(decompile-expr body globs (cons id stack) closed)))]
|
||||
[(struct let-void (count boxes? body))
|
||||
(let ([ids (make-vector count #f)])
|
||||
(extract-ids! body ids)
|
||||
(let ([vars (for/list ([i (in-range count)]
|
||||
[id (in-vector ids)])
|
||||
(or id (gensym (if boxes? 'localvb 'localv))))])
|
||||
`(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)])
|
||||
vars)
|
||||
,(decompile-expr body globs (append vars stack) closed))))]
|
||||
[(struct let-rec (procs body))
|
||||
`(begin
|
||||
(#%set!-rec-values ,(for/list ([p (in-list procs)]
|
||||
[i (in-naturals)])
|
||||
(list-ref/protect stack i 'let-rec))
|
||||
,@(map (lambda (proc)
|
||||
(decompile-expr proc globs stack closed))
|
||||
procs))
|
||||
,(decompile-expr body globs stack closed))]
|
||||
[(struct install-value (count pos boxes? rhs body))
|
||||
`(begin
|
||||
(,(if boxes? '#%set-boxes! 'set!-values)
|
||||
,(for/list ([i (in-range count)])
|
||||
(list-ref/protect stack (+ i pos) 'install-value))
|
||||
,(decompile-expr rhs globs stack closed))
|
||||
,(decompile-expr body globs stack closed))]
|
||||
[(struct boxenv (pos body))
|
||||
(let ([id (list-ref/protect stack pos 'boxenv)])
|
||||
`(begin
|
||||
(set! ,id (#%box ,id))
|
||||
,(decompile-expr body globs stack closed)))]
|
||||
[(struct branch (test then else))
|
||||
`(if ,(decompile-expr test globs stack closed)
|
||||
,(decompile-expr then globs stack closed)
|
||||
,(decompile-expr else globs stack closed))]
|
||||
[(struct application (rator rands))
|
||||
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
|
||||
stack)])
|
||||
(annotate-unboxed
|
||||
rands
|
||||
(annotate-inline
|
||||
`(,(decompile-expr rator globs stack closed)
|
||||
,@(map (lambda (rand)
|
||||
(decompile-expr rand globs stack closed))
|
||||
rands)))))]
|
||||
[(struct apply-values (proc args-expr))
|
||||
`(#%apply-values ,(decompile-expr proc globs stack closed)
|
||||
,(decompile-expr args-expr globs stack closed))]
|
||||
[(struct with-immed-mark (key-expr val-expr body-expr))
|
||||
(let ([id (gensym 'cmval)])
|
||||
`(#%call-with-immediate-continuation-mark
|
||||
,(decompile-expr key-expr globs stack closed)
|
||||
(lambda (,id) ,(decompile-expr body-expr globs (cons id stack) closed))
|
||||
,(decompile-expr val-expr globs stack closed)))]
|
||||
[(struct seq (exprs))
|
||||
`(begin ,@(for/list ([expr (in-list exprs)])
|
||||
(decompile-expr expr globs stack closed)))]
|
||||
[(struct beg0 (exprs))
|
||||
`(begin0
|
||||
,@(for/list ([expr (in-list exprs)])
|
||||
(decompile-expr expr globs stack closed))
|
||||
;; Make sure a single expression doesn't look like tail position:
|
||||
,@(if (null? (cdr exprs)) (list #f) null))]
|
||||
[(struct with-cont-mark (key val body))
|
||||
`(with-continuation-mark
|
||||
,(decompile-expr key globs stack closed)
|
||||
,(decompile-expr val globs stack closed)
|
||||
,(decompile-expr body globs stack closed))]
|
||||
[(struct closure (lam gen-id))
|
||||
(if (hash-ref closed gen-id #f)
|
||||
gen-id
|
||||
(begin
|
||||
(hash-set! closed gen-id #t)
|
||||
`(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))]
|
||||
[else `(quote ,expr)]))
|
||||
|
||||
(define (decompile-lam expr globs stack closed)
|
||||
(match expr
|
||||
[(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)]
|
||||
[(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body))
|
||||
(let ([vars (for/list ([i (in-range num-params)]
|
||||
[type (in-list arg-types)])
|
||||
(gensym (format "~a~a-"
|
||||
(case type
|
||||
[(ref) "argbox"]
|
||||
[(val) "arg"]
|
||||
[else (format "arg~a" type)])
|
||||
i)))]
|
||||
[rest-vars (if rest? (list (gensym 'rest)) null)]
|
||||
[captures (map (lambda (v)
|
||||
(list-ref/protect stack v 'lam))
|
||||
(vector->list closure-map))])
|
||||
`((,@vars . ,(if rest?
|
||||
(car rest-vars)
|
||||
null))
|
||||
,@(if (and name (not (null? name)))
|
||||
`(',name)
|
||||
null)
|
||||
,@(if (null? flags) null `('(flags: ,@flags)))
|
||||
,@(if (null? captures)
|
||||
null
|
||||
`('(captures: ,@(map (lambda (c t)
|
||||
(if t
|
||||
`(,t ,c)
|
||||
c))
|
||||
captures
|
||||
closure-types)
|
||||
,@(if (not tl-map)
|
||||
'()
|
||||
(list
|
||||
(for/list ([pos (in-list (sort (set->list tl-map) <))])
|
||||
(list-ref/protect (glob-desc-vars globs)
|
||||
pos
|
||||
'lam)))))))
|
||||
,(decompile-expr body globs
|
||||
(append captures
|
||||
(append vars rest-vars))
|
||||
closed)))]))
|
||||
|
||||
(define (annotate-inline a)
|
||||
a)
|
||||
|
||||
(define (annotate-unboxed args a)
|
||||
a)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (decompile-deserialize mpis inspector bulk-binding-registry
|
||||
num-mutables mutable-vec
|
||||
num-shares share-vec
|
||||
mutable-fill-vec
|
||||
result-vec)
|
||||
;; Names for shared values:
|
||||
(define shared (for/vector ([i (in-range (+ num-mutables num-shares))])
|
||||
(string->symbol (format "~a:~a"
|
||||
(if (i . < . num-mutables)
|
||||
'mutable
|
||||
'shared)
|
||||
i))))
|
||||
(define (infer-name! d i)
|
||||
(when (pair? d)
|
||||
(define new-name
|
||||
(case (car d)
|
||||
[(deserialize-scope) 'scope]
|
||||
[(srcloc) 'srcloc]
|
||||
[else #f]))
|
||||
(when new-name
|
||||
(vector-set! shared i (string->symbol (format "~a:~a" new-name i))))))
|
||||
|
||||
(define mutables (make-vector num-mutables #f))
|
||||
;; Make mutable shells
|
||||
(for/fold ([pos 0]) ([i (in-range num-mutables)])
|
||||
(define-values (d next-pos)
|
||||
(decode-shell mutable-vec pos mpis inspector bulk-binding-registry shared))
|
||||
(vector-set! mutables i d)
|
||||
(infer-name! d i)
|
||||
next-pos)
|
||||
|
||||
;; Construct shared values
|
||||
(define shareds (make-vector num-shares #f))
|
||||
(for/fold ([pos 0]) ([i (in-range num-shares)])
|
||||
(define-values (d next-pos)
|
||||
(decode share-vec pos mpis inspector bulk-binding-registry shared))
|
||||
(vector-set! shareds i d)
|
||||
(infer-name! d (+ i num-mutables))
|
||||
next-pos)
|
||||
|
||||
;; Fill in mutable shells
|
||||
(define-values (fill-pos rev-fills)
|
||||
(for/fold ([pos 0] [rev-fills null]) ([i (in-range num-mutables)]
|
||||
[v (in-vector shared)])
|
||||
(define-values (fill next-pos)
|
||||
(decode-fill! v mutable-fill-vec pos mpis inspector bulk-binding-registry shared))
|
||||
(values next-pos (if fill
|
||||
(cons fill rev-fills)
|
||||
rev-fills))))
|
||||
|
||||
;; Construct the final result
|
||||
(define-values (result done-pos)
|
||||
(decode result-vec 0 mpis inspector bulk-binding-registry shared))
|
||||
|
||||
`(let (,(for/list ([i (in-range num-mutables)])
|
||||
`(,(vector-ref shared i) ,(vector-ref mutables i))))
|
||||
(let* (,(for/list ([i (in-range num-shares)])
|
||||
`(,(vector-ref shared (+ i num-mutables)) ,(vector-ref shareds i))))
|
||||
,@(reverse rev-fills)
|
||||
,result)))
|
||||
|
||||
;; Decode the construction of a mutable variable
|
||||
(define (decode-shell vec pos mpis inspector bulk-binding-registry shared)
|
||||
(case (vector-ref vec pos)
|
||||
[(#:box) (values (list 'box #f) (add1 pos))]
|
||||
[(#:vector) (values `(make-vector ,(vector-ref vec (add1 pos))) (+ pos 2))]
|
||||
[(#:hash) (values (list 'make-hasheq) (add1 pos))]
|
||||
[(#:hasheq) (values (list 'make-hasheq) (add1 pos))]
|
||||
[(#:hasheqv) (values (list 'make-hasheqv) (add1 pos))]
|
||||
[else (decode vec pos mpis inspector bulk-binding-registry shared)]))
|
||||
|
||||
;; The decoder that is used for most purposes
|
||||
(define (decode vec pos mpis inspector bulk-binding-registry shared)
|
||||
(define-syntax decodes
|
||||
(syntax-rules ()
|
||||
[(_ (id ...) rhs) (decodes #:pos (add1 pos) (id ...) rhs)]
|
||||
[(_ #:pos pos () rhs) (values rhs pos)]
|
||||
[(_ #:pos pos ([#:ref id0] id ...) rhs)
|
||||
(let-values ([(id0 next-pos) (let ([i (vector-ref vec pos)])
|
||||
(if (exact-integer? i)
|
||||
(values (vector-ref shared i) (add1 pos))
|
||||
(decode vec pos mpis inspector bulk-binding-registry shared)))])
|
||||
(decodes #:pos next-pos (id ...) rhs))]
|
||||
[(_ #:pos pos (id0 id ...) rhs)
|
||||
(let-values ([(id0 next-pos) (decode vec pos mpis inspector bulk-binding-registry shared)])
|
||||
(decodes #:pos next-pos (id ...) rhs))]))
|
||||
(define-syntax-rule (decode* (deser id ...))
|
||||
(decodes (id ...) `(deser ,id ...)))
|
||||
(case (vector-ref vec pos)
|
||||
[(#:ref)
|
||||
(values (vector-ref shared (vector-ref vec (add1 pos)))
|
||||
(+ pos 2))]
|
||||
[(#:inspector) (values inspector (add1 pos))]
|
||||
[(#:bulk-binding-registry) (values bulk-binding-registry (add1 pos))]
|
||||
[(#:syntax #:datum->syntax)
|
||||
(decodes
|
||||
(content [#:ref context] [#:ref srcloc])
|
||||
`(deserialize-syntax
|
||||
,content
|
||||
,context
|
||||
,srcloc
|
||||
#f
|
||||
#f
|
||||
,inspector))]
|
||||
[(#:syntax+props)
|
||||
(decodes
|
||||
(content [#:ref context] [#:ref srcloc] props tamper)
|
||||
`(deserialize-syntax
|
||||
,content
|
||||
,context
|
||||
,srcloc
|
||||
,props
|
||||
,tamper
|
||||
,inspector))]
|
||||
[(#:srcloc)
|
||||
(decode* (srcloc source line column position span))]
|
||||
[(#:quote)
|
||||
(values (vector-ref vec (add1 pos)) (+ pos 2))]
|
||||
[(#:mpi)
|
||||
(values `(vector-ref ,mpis ,(vector-ref vec (add1 pos)))
|
||||
(+ pos 2))]
|
||||
[(#:box)
|
||||
(decode* (box-immutable v))]
|
||||
[(#:cons)
|
||||
(decode* (cons a d))]
|
||||
[(#:list #:vector #:set #:seteq #:seteqv)
|
||||
(define len (vector-ref vec (add1 pos)))
|
||||
(define r (make-vector len))
|
||||
(define next-pos
|
||||
(for/fold ([pos (+ pos 2)]) ([i (in-range len)])
|
||||
(define-values (v next-pos) (decodes #:pos pos (v) v))
|
||||
(vector-set! r i v)
|
||||
next-pos))
|
||||
(values `(,(case (vector-ref vec pos)
|
||||
[(#:list) 'list]
|
||||
[(#:vector) 'vector]
|
||||
[(#:set) 'set]
|
||||
[(#:seteq) 'seteq]
|
||||
[(#:seteqv) 'seteqv])
|
||||
,@(vector->list r))
|
||||
next-pos)]
|
||||
[(#:hash #:hasheq #:hasheqv)
|
||||
(define len (vector-ref vec (add1 pos)))
|
||||
(define-values (l next-pos)
|
||||
(for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)])
|
||||
(decodes #:pos pos (k v) (list* v k l))))
|
||||
(values `(,(case (vector-ref vec pos)
|
||||
[(#:hash) 'hash]
|
||||
[(#:hasheq) 'hasheq]
|
||||
[(#:hasheqv) 'hasheqv])
|
||||
,@(reverse l))
|
||||
next-pos)]
|
||||
[(#:prefab)
|
||||
(define-values (key next-pos) (decodes #:pos (add1 pos) (k) k))
|
||||
(define len (vector-ref vec next-pos))
|
||||
(define-values (r done-pos)
|
||||
(for/fold ([r null] [pos (add1 next-pos)]) ([i (in-range len)])
|
||||
(decodes #:pos pos (v) (cons v r))))
|
||||
(values `(make-prefab-struct ',key ,@(reverse r))
|
||||
done-pos)]
|
||||
[(#:scope)
|
||||
(decode* (deserialize-scope))]
|
||||
[(#:scope+kind)
|
||||
(decode* (deserialize-scope kind))]
|
||||
[(#:multi-scope)
|
||||
(decode* (deserialize-multi-scope name scopes))]
|
||||
[(#:shifted-multi-scope)
|
||||
(decode* (deserialize-shifted-multi-scope phase multi-scope))]
|
||||
[(#:table-with-bulk-bindings)
|
||||
(decode* (deserialize-table-with-bulk-bindings syms bulk-bindings))]
|
||||
[(#:bulk-binding-at)
|
||||
(decode* (deserialize-bulk-binding-at scopes bulk))]
|
||||
[(#:representative-scope)
|
||||
(decode* (deserialize-representative-scope kind phase))]
|
||||
[(#:module-binding)
|
||||
(decode* (deserialize-full-module-binding
|
||||
module sym phase
|
||||
nominal-module
|
||||
nominal-phase
|
||||
nominal-sym
|
||||
nominal-require-phase
|
||||
free=id
|
||||
extra-inspector
|
||||
extra-nominal-bindings))]
|
||||
[(#:simple-module-binding)
|
||||
(decode* (deserialize-simple-module-binding module sym phase nominal-module))]
|
||||
[(#:local-binding)
|
||||
(decode* (deserialize-full-local-binding key free=id))]
|
||||
[(#:bulk-binding)
|
||||
(decode* (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry))]
|
||||
[(#:provided)
|
||||
(decode* (deserialize-provided binding protected? syntax?))]
|
||||
[else
|
||||
(values `(quote ,(vector-ref vec pos)) (add1 pos))]))
|
||||
|
||||
;; Decode the filling of mutable values, which has its own encoding
|
||||
;; variant
|
||||
(define (decode-fill! v vec pos mpis inspector bulk-binding-registry shared)
|
||||
(case (vector-ref vec pos)
|
||||
[(#f) (values #f (add1 pos))]
|
||||
[(#:set-box!)
|
||||
(define-values (c next-pos)
|
||||
(decode vec (add1 pos) mpis inspector bulk-binding-registry shared))
|
||||
(values `(set-box! ,v ,c)
|
||||
next-pos)]
|
||||
[(#:set-vector!)
|
||||
(define len (vector-ref vec (add1 pos)))
|
||||
(define-values (l next-pos)
|
||||
(for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)])
|
||||
(define-values (c next-pos)
|
||||
(decode vec pos mpis inspector bulk-binding-registry shared))
|
||||
(values (cons `(vector-set! ,v ,i ,c) l)
|
||||
next-pos)))
|
||||
(values `(begin ,@(reverse l)) next-pos)]
|
||||
[(#:set-hash!)
|
||||
(define len (vector-ref vec (add1 pos)))
|
||||
(define-values (l next-pos)
|
||||
(for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)])
|
||||
(define-values (key next-pos)
|
||||
(decode vec pos mpis inspector bulk-binding-registry shared))
|
||||
(define-values (val done-pos)
|
||||
(decode vec next-pos mpis inspector bulk-binding-registry shared))
|
||||
(values (cons `(hash-set! ,v ,key ,val) l)
|
||||
done-pos)))
|
||||
(values `(begin ,@(reverse l)) next-pos)]
|
||||
[(#:scope-fill!)
|
||||
(define-values (c next-pos)
|
||||
(decode vec (add1 pos) mpis inspector bulk-binding-registry shared))
|
||||
(values `(deserialize-scope-fill! ,v ,c)
|
||||
next-pos)]
|
||||
[(#:representative-scope-fill!)
|
||||
(define-values (a next-pos)
|
||||
(decode vec (add1 pos) mpis inspector bulk-binding-registry shared))
|
||||
(define-values (d done-pos)
|
||||
(decode vec next-pos mpis inspector bulk-binding-registry shared))
|
||||
(values `(deserialize-representative-scope-fill! ,v ,a ,d)
|
||||
done-pos)]
|
||||
[else
|
||||
(error 'deserialize "bad fill encoding: ~v" (vector-ref vec pos))]))
|
||||
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
#;
|
||||
(begin
|
||||
(require scheme/pretty)
|
||||
(define (try e)
|
||||
(pretty-print
|
||||
(decompile
|
||||
(zo-parse (let-values ([(in out) (make-pipe)])
|
||||
(write (parameterize ([current-namespace (make-base-namespace)])
|
||||
(compile e))
|
||||
out)
|
||||
(close-output-port out)
|
||||
in)))))
|
||||
(pretty-print
|
||||
(decompile
|
||||
(zo-parse (open-input-file "/home/mflatt/proj/plt/collects/tests/mzscheme/benchmarks/common/sboyer_ss.zo"))))
|
||||
#;
|
||||
(try '(lambda (q . more)
|
||||
(letrec ([f (lambda (x) f)])
|
||||
(lambda (g) f)))))
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
racket/set
|
||||
raco/command-name
|
||||
"main.rkt")
|
||||
|
||||
(let ([output-file (make-parameter #f)])
|
||||
(command-line #:program (short-program+command-name)
|
||||
#:multi
|
||||
[("-e" "--exclude-modules") path "Exclude <path> from flattening"
|
||||
(current-excluded-modules (set-add (current-excluded-modules) path))]
|
||||
#:once-each
|
||||
[("-o") dest-filename "Write output as <dest-filename>"
|
||||
(output-file (string->path dest-filename))]
|
||||
[("-g" "--garbage-collect") "Garbage-collect final module (unsound)"
|
||||
(garbage-collect-toplevels-enabled #t)]
|
||||
[("-r" "--recompile") "Recompile final module to re-run optimizations"
|
||||
(recompile-enabled #t)]
|
||||
#:args (filename)
|
||||
(demodularize filename (output-file))))
|
||||
|
||||
(module test racket/base)
|
||||
|
|
@ -1,169 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (only-in '#%linklet primitive->compiled-position)
|
||||
racket/set
|
||||
compiler/zo-structs
|
||||
"run.rkt"
|
||||
"name.rkt")
|
||||
|
||||
(provide wrap-bundle)
|
||||
|
||||
(define (wrap-bundle body internals lifts excluded-module-mpis get-merge-info)
|
||||
(define-values (runs
|
||||
import-keys
|
||||
ordered-importss
|
||||
import-shapess
|
||||
any-syntax-literals?
|
||||
any-transformer-registers?
|
||||
saw-zero-pos-toplevel?)
|
||||
(get-merge-info))
|
||||
|
||||
(define module-name 'demodularized)
|
||||
(define (primitive v)
|
||||
(primval (or (primitive->compiled-position v)
|
||||
(error "cannot find primitive" v))))
|
||||
|
||||
(define new-linkl
|
||||
(linkl module-name
|
||||
(list* (if any-syntax-literals? '(.get-syntax-literal!) '())
|
||||
(if any-transformer-registers? '(.set-transformer!) '())
|
||||
ordered-importss)
|
||||
(list* (if any-syntax-literals? (list (function-shape 1 #f)) '())
|
||||
(if any-transformer-registers? (list (function-shape 2 #f)) '())
|
||||
import-shapess)
|
||||
'() ; exports
|
||||
internals
|
||||
lifts
|
||||
#hasheq()
|
||||
body
|
||||
(for/fold ([m 0]) ([r (in-list runs)])
|
||||
(max m (linkl-max-let-depth (run-linkl r))))
|
||||
saw-zero-pos-toplevel?))
|
||||
|
||||
(define data-linkl
|
||||
(linkl 'data
|
||||
'((deserialize-module-path-indexes))
|
||||
'((#f))
|
||||
'(.mpi-vector)
|
||||
'()
|
||||
'()
|
||||
#hasheq()
|
||||
(list
|
||||
(def-values (list (toplevel 0 2 #f #f)) ; .mpi-vector
|
||||
(application (toplevel 2 1 #f #f) ; deserialize-module-path-indexes
|
||||
;; Construct two vectors: one for mpi construction, and
|
||||
;; another for selecting the slots that are externally referenced
|
||||
;; mpis (where the selection vector matches th `import-keys` order).
|
||||
;; If all import keys are primitive modules, then we just make
|
||||
;; a vector with those specs in order, but if there's a more
|
||||
;; complex mpi, then we have to insert extra slots in the first
|
||||
;; vector to hold intermediate mpi constructions.
|
||||
;; We could do better here by sharing common tails.
|
||||
(let loop ([import-keys import-keys]
|
||||
[specs (list (box module-name))]
|
||||
[results (list 0)])
|
||||
(cond
|
||||
[(null? import-keys)
|
||||
(list (list->vector (reverse specs))
|
||||
(list->vector (reverse results)))]
|
||||
[else
|
||||
(define path/submod+phase (car import-keys))
|
||||
(define path (car path/submod+phase))
|
||||
(cond
|
||||
[(symbol? path)
|
||||
(loop (cdr import-keys)
|
||||
(cons (vector `(quote ,path)) specs)
|
||||
(cons (length specs) results))]
|
||||
[(path? path)
|
||||
(define-values (i new-specs)
|
||||
(begin
|
||||
(let mpi-loop ([mpi (hash-ref excluded-module-mpis path)])
|
||||
(define-values (name base) (module-path-index-split mpi))
|
||||
(cond
|
||||
[(and (not name) (not base))
|
||||
(values 0 specs)]
|
||||
[(not base)
|
||||
(values (length specs) (cons (vector name) specs))]
|
||||
[else
|
||||
(define-values (next-i next-specs) (mpi-loop base))
|
||||
(values (length next-specs) (cons (vector name next-i) next-specs))]))))
|
||||
(loop (cdr import-keys)
|
||||
new-specs
|
||||
(cons i results))]
|
||||
[else
|
||||
(error 'wrap-bundle "unrecognized import path shape: ~s" path)])])))))
|
||||
16
|
||||
#f))
|
||||
|
||||
(define decl-linkl
|
||||
(let ([deserialize-pos 1]
|
||||
[module-use-pos 2]
|
||||
[mpi-vector-pos 3]
|
||||
[exports-pos 4])
|
||||
(linkl 'decl
|
||||
'((deserialize
|
||||
module-use)
|
||||
(.mpi-vector))
|
||||
'((#f)
|
||||
(#f))
|
||||
'(self-mpi requires provides phase-to-link-modules)
|
||||
'()
|
||||
'()
|
||||
#hasheq()
|
||||
(list
|
||||
(def-values (list (toplevel 0 (+ exports-pos 0) #f #f)) ; .self-mpi
|
||||
(application (primitive vector-ref)
|
||||
(list (toplevel 2 mpi-vector-pos #f #f)
|
||||
'0)))
|
||||
(def-values (list (toplevel 0 (+ exports-pos 1) #f #f)) ; requires
|
||||
(let ([arg-count 9])
|
||||
(application (toplevel arg-count deserialize-pos #f #f)
|
||||
(list
|
||||
(toplevel arg-count mpi-vector-pos #f #f)
|
||||
#f #f 0 '#() 0 '#() '#()
|
||||
(list->vector
|
||||
(let loop ([phases (sort (set->list
|
||||
(for/set ([path/submod+phase (in-list import-keys)])
|
||||
(cdr path/submod+phase)))
|
||||
<)])
|
||||
(cond
|
||||
[(null? phases) (list '())]
|
||||
[else
|
||||
(define phase (car phases))
|
||||
(define n (for/sum ([path/submod+phase (in-list import-keys)])
|
||||
(if (eqv? phase (cdr path/submod+phase)) 1 0)))
|
||||
(append `(#:cons #:list ,(add1 n) ,(- 0 phase))
|
||||
(apply
|
||||
append
|
||||
(for/list ([path/submod+phase (in-list import-keys)]
|
||||
[i (in-naturals 1)]
|
||||
#:when (eqv? phase (cdr path/submod+phase)))
|
||||
`(#:mpi ,i)))
|
||||
(loop (cdr phases)))])))))))
|
||||
(def-values (list (toplevel 0 (+ exports-pos 2) #f #f)) ; provides
|
||||
(application (primitive hasheqv) null))
|
||||
(def-values (list (toplevel 0 (+ exports-pos 3) #f #f)) ; phase-to-link-modules
|
||||
(let ([depth 2])
|
||||
(application (primitive hasheqv)
|
||||
(list 0
|
||||
(let ([depth (+ depth (length import-keys))])
|
||||
(application (primitive list)
|
||||
(for/list ([path/submod+phase (in-list import-keys)]
|
||||
[i (in-naturals 1)])
|
||||
(let ([depth (+ depth 2)])
|
||||
(application (toplevel depth module-use-pos #f #f)
|
||||
(list
|
||||
(let ([depth (+ depth 2)])
|
||||
(application (primitive vector-ref)
|
||||
(list
|
||||
(toplevel depth mpi-vector-pos #f #f)
|
||||
i)))
|
||||
(cdr path/submod+phase))))))))))))
|
||||
(+ 32 (length import-keys))
|
||||
#f)))
|
||||
|
||||
;; By not including a 'stx-data linklet, we get a default
|
||||
;; linklet that supplies #f for any syntax-literal reference.
|
||||
|
||||
(linkl-bundle (hasheq 0 new-linkl
|
||||
'data data-linkl
|
||||
'decl decl-linkl)))
|
||||
|
|
@ -1,164 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/set
|
||||
compiler/zo-parse
|
||||
syntax/modcode
|
||||
racket/linklet
|
||||
"../private/deserialize.rkt"
|
||||
"module-path.rkt"
|
||||
"run.rkt")
|
||||
|
||||
(provide find-modules
|
||||
current-excluded-modules)
|
||||
|
||||
(struct mod (compiled zo)) ; includes submodules; `zo` is #f for excluded
|
||||
(struct one-mod (compiled zo decl)) ; module without submodules
|
||||
|
||||
(define current-excluded-modules (make-parameter (set)))
|
||||
|
||||
(define (find-modules orig-path #:submodule [submod '()])
|
||||
(define mods (make-hash)) ; path -> mod
|
||||
(define one-mods (make-hash)) ; path+submod -> one-mod
|
||||
(define runs-done (make-hash)) ; path+submod+phase -> #t
|
||||
(define runs null) ; list of `run`
|
||||
(define excluded-module-mpis (make-hash)) ; path -> mpi
|
||||
|
||||
(define (find-modules! orig-path+submod exclude?)
|
||||
(define orig-path (if (pair? orig-path+submod) (car orig-path+submod) orig-path+submod))
|
||||
(define submod (if (pair? orig-path+submod) (cdr orig-path+submod) '()))
|
||||
(define path (normal-case-path (simplify-path (path->complete-path orig-path))))
|
||||
|
||||
(unless (hash-ref mods path #f)
|
||||
(define-values (zo-path kind) (get-module-path path))
|
||||
(unless (eq? kind 'zo)
|
||||
(error 'demodularize "not available in bytecode form\n path: ~a" path))
|
||||
(define zo (and (not exclude?)
|
||||
(call-with-input-file zo-path zo-parse)))
|
||||
(define compiled (parameterize ([read-accept-compiled #t]
|
||||
[current-load-relative-directory
|
||||
(let-values ([(dir file-name dir?) (split-path path)])
|
||||
dir)])
|
||||
(call-with-input-file zo-path read)))
|
||||
(hash-set! mods path (mod compiled zo)))
|
||||
|
||||
(unless (hash-ref one-mods (cons path submod) #f)
|
||||
(define m (hash-ref mods path))
|
||||
(define compiled (mod-compiled m))
|
||||
(define zo (mod-zo m))
|
||||
|
||||
(define (raise-no-submod)
|
||||
(error 'demodularize "no such submodule\n path: ~a\n submod: ~a"
|
||||
path submod))
|
||||
(define one-compiled
|
||||
(let loop ([compiled compiled] [submod submod])
|
||||
(cond
|
||||
[(linklet-bundle? compiled)
|
||||
(unless (null? submod) (raise-no-submod))
|
||||
compiled]
|
||||
[else
|
||||
(cond
|
||||
[(null? submod)
|
||||
(or (hash-ref (linklet-directory->hash compiled) #f #f)
|
||||
(raise-no-submod))]
|
||||
[else
|
||||
(loop (or (hash-ref (linklet-directory->hash compiled) (car submod) #f)
|
||||
(raise-no-submod))
|
||||
(cdr submod))])])))
|
||||
(define one-zo
|
||||
(cond
|
||||
[(not zo) #f]
|
||||
[(linkl-bundle? zo)
|
||||
(unless (null? submod) (raise-no-submod))
|
||||
zo]
|
||||
[else
|
||||
(or (hash-ref (linkl-directory-table zo) submod #f)
|
||||
(raise-no-submod))]))
|
||||
|
||||
(define h (linklet-bundle->hash one-compiled))
|
||||
(define data-linklet (hash-ref h 'data #f))
|
||||
(define decl-linklet (hash-ref h 'decl #f))
|
||||
(unless data-linklet
|
||||
(error 'demodularize "could not find module path metadata\n path: ~a\n submod: ~a"
|
||||
path submod))
|
||||
(unless decl-linklet
|
||||
(error 'demodularize "could not find module metadata\n path: ~a\n submod: ~a"
|
||||
path submod))
|
||||
|
||||
(define data-instance (instantiate-linklet data-linklet
|
||||
(list deserialize-instance)))
|
||||
(define decl (instantiate-linklet decl-linklet
|
||||
(list deserialize-instance
|
||||
data-instance)))
|
||||
|
||||
(hash-set! one-mods (cons path submod) (one-mod one-compiled one-zo decl))
|
||||
|
||||
;; Transitive requires
|
||||
|
||||
(define reqs (instance-variable-value decl 'requires))
|
||||
|
||||
(for ([phase+reqs (in-list reqs)]
|
||||
#:when (car phase+reqs)
|
||||
[req (in-list (cdr phase+reqs))])
|
||||
(define path/submod (module-path-index->path req path submod))
|
||||
(define req-path (if (pair? path/submod) (car path/submod) path/submod))
|
||||
(unless (symbol? req-path)
|
||||
(find-modules! path/submod
|
||||
;; Even if this module is excluded, traverse it to get all
|
||||
;; modules that it requires, so that we don't duplicate those
|
||||
;; modules by accessing them directly
|
||||
(or exclude? (set-member? (current-excluded-modules) req-path)))))))
|
||||
|
||||
(define (find-phase-runs! orig-path+submod orig-mpi #:phase [phase 0])
|
||||
(define orig-path (if (pair? orig-path+submod) (car orig-path+submod) orig-path+submod))
|
||||
(define submod (if (pair? orig-path+submod) (cdr orig-path+submod) '()))
|
||||
(define path (normal-case-path (simplify-path (path->complete-path orig-path))))
|
||||
(define path/submod (if (pair? submod) (cons path submod) path))
|
||||
|
||||
(unless (hash-ref runs-done (cons (cons path submod) phase) #f)
|
||||
(define one-m (hash-ref one-mods (cons path submod) #f))
|
||||
(when (one-mod-zo one-m) ; not excluded
|
||||
(define decl (one-mod-decl one-m))
|
||||
|
||||
(define linkl (hash-ref (linkl-bundle-table (one-mod-zo one-m)) phase #f))
|
||||
(define uses
|
||||
(list*
|
||||
;; The first implicit import might get used for syntax literals;
|
||||
;; recognize it with a 'syntax-literals "phase"
|
||||
(cons path/submod 'syntax-literals)
|
||||
;; The second implicit import might get used to register a macro;
|
||||
;; we'll map those registrations to the same implicit import:
|
||||
'(#%transformer-register . transformer-register)
|
||||
(for/list ([u (hash-ref (instance-variable-value decl 'phase-to-link-modules)
|
||||
phase
|
||||
null)])
|
||||
(define path/submod (module-path-index->path (module-use-module u) path submod))
|
||||
|
||||
;; In case the import turns out to stay imported:
|
||||
(define req-path (if (pair? path/submod) (car path/submod) path/submod))
|
||||
(hash-set! excluded-module-mpis req-path (module-path-index-reroot (module-use-module u) orig-mpi))
|
||||
|
||||
(cons path/submod (module-use-phase u)))))
|
||||
|
||||
(define r (run (if (null? submod) path (cons path submod)) phase linkl uses))
|
||||
(hash-set! runs-done (cons (cons path submod) phase) #t)
|
||||
|
||||
(define reqs (instance-variable-value decl 'requires))
|
||||
(for* ([phase+reqs (in-list reqs)]
|
||||
#:when (car phase+reqs)
|
||||
[req (in-list (cdr phase+reqs))])
|
||||
(define at-phase (- phase (car phase+reqs)))
|
||||
(define path/submod (module-path-index->path req path submod))
|
||||
(define full-mpi (module-path-index-reroot req orig-mpi))
|
||||
(define req-path (if (pair? path/submod) (car path/submod) path/submod))
|
||||
(unless (or (symbol? req-path)
|
||||
(set-member? (current-excluded-modules) req-path))
|
||||
(find-phase-runs! path/submod full-mpi #:phase at-phase)))
|
||||
|
||||
;; Adding after requires, so that `runs` ends up in the
|
||||
;; reverse order that we want to emit code
|
||||
(when linkl (set! runs (cons r runs))))))
|
||||
|
||||
(find-modules! (cons orig-path submod) #f)
|
||||
(find-phase-runs! (cons orig-path submod) (module-path-index-join #f #f))
|
||||
|
||||
(values (reverse runs)
|
||||
excluded-module-mpis))
|
||||
|
|
@ -1,164 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/match
|
||||
racket/set
|
||||
compiler/zo-structs
|
||||
"remap.rkt")
|
||||
|
||||
;; Prune unnused definitions,
|
||||
;; * soundly, with a simple approximation of `pure?`, by default
|
||||
;; * unsoundly, assuming all definitions are pure, optionally
|
||||
|
||||
(provide gc-definitions)
|
||||
|
||||
(define (gc-definitions body internals lifts internals-pos
|
||||
#:assume-pure? assume-pure?)
|
||||
(define used (make-hasheqv)) ; pos -> 'used or thunk
|
||||
(define graph (make-hasheq))
|
||||
|
||||
(define (used-pos! pos)
|
||||
(when (pos . >= . internals-pos)
|
||||
(define v (hash-ref used pos #f))
|
||||
(hash-set! used pos 'used)
|
||||
(when (procedure? v)
|
||||
(v))))
|
||||
|
||||
(define (used! b)
|
||||
(match b
|
||||
[(toplevel depth pos const? ready?)
|
||||
(used-pos! pos)]
|
||||
[(inline-variant direct inline)
|
||||
(used! direct)
|
||||
(used! inline)]
|
||||
[(closure code gen-id)
|
||||
(unless (hash-ref graph gen-id #f)
|
||||
(hash-set! graph gen-id #t)
|
||||
(used! code))]
|
||||
[(let-one rhs body type unused?)
|
||||
(used! rhs)
|
||||
(used! body)]
|
||||
[(let-void count boxes? body)
|
||||
(used! body)]
|
||||
[(install-value count pos boxes? rhs body)
|
||||
(used! rhs)
|
||||
(used! body)]
|
||||
[(let-rec procs body)
|
||||
(for-each used! procs)
|
||||
(used! body)]
|
||||
[(boxenv pos body)
|
||||
(used! body)]
|
||||
[(application rator rands)
|
||||
(used! rator)
|
||||
(for-each used! rands)]
|
||||
[(branch tst thn els)
|
||||
(used! tst)
|
||||
(used! thn)
|
||||
(used! els)]
|
||||
[(with-cont-mark key val body)
|
||||
(used! key)
|
||||
(used! val)
|
||||
(used! body)]
|
||||
[(beg0 forms)
|
||||
(for-each used! forms)]
|
||||
[(seq forms)
|
||||
(for-each used! forms)]
|
||||
[(varref toplevel dummy constant? unsafe?)
|
||||
(used! toplevel)
|
||||
(used! dummy)]
|
||||
[(assign id rhs undef-ok?)
|
||||
(used! id)
|
||||
(used! rhs)]
|
||||
[(apply-values proc args-expr)
|
||||
(used! proc)
|
||||
(used! args-expr)]
|
||||
[(with-immed-mark key def-val body)
|
||||
(used! key)
|
||||
(used! def-val)
|
||||
(used! body)]
|
||||
[(case-lam name clauses)
|
||||
(for-each used! clauses)]
|
||||
[_
|
||||
(cond
|
||||
[(lam? b)
|
||||
(define tl-map (lam-toplevel-map b))
|
||||
(when tl-map
|
||||
(for/set ([pos (in-set tl-map)])
|
||||
(when (pos . >= . internals-pos)
|
||||
(used-pos! pos))))
|
||||
(used! (lam-body b))]
|
||||
[else (void)])]))
|
||||
|
||||
(define (pure? b)
|
||||
(match b
|
||||
[(closure code gen-id) #t]
|
||||
[(inline-variant direct inline) #t]
|
||||
[(case-lam name clauses) #t]
|
||||
[_ (lam? b)]))
|
||||
|
||||
(for ([b (in-list body)])
|
||||
(match b
|
||||
[(def-values ids rhs)
|
||||
(define done? #f)
|
||||
(define (used-rhs!)
|
||||
(unless done?
|
||||
(set! done? #t)
|
||||
(used! rhs))
|
||||
;; All in group are used together:
|
||||
(for-each used! ids))
|
||||
(for ([id (in-list ids)])
|
||||
(define pos (toplevel-pos id))
|
||||
(cond
|
||||
[(eq? 'used (hash-ref used pos #f))
|
||||
(used-rhs!)]
|
||||
[else
|
||||
(hash-set! used pos used-rhs!)]))
|
||||
(unless (or assume-pure?
|
||||
(pure? rhs))
|
||||
(used-rhs!))]
|
||||
[_ (used! b)]))
|
||||
|
||||
;; Anything not marked as used at this point can be dropped
|
||||
(define new-internals
|
||||
(for/list ([name (in-list internals)]
|
||||
[pos (in-naturals internals-pos)]
|
||||
#:when (or (eq? 'used (hash-ref used pos #f))
|
||||
(begin
|
||||
(log-debug "drop ~s" name)
|
||||
#f)))
|
||||
name))
|
||||
|
||||
(define lifts-pos (+ internals-pos (length internals)))
|
||||
(define new-lifts
|
||||
(for/list ([name (in-list lifts)]
|
||||
[pos (in-naturals lifts-pos)]
|
||||
#:when (or (eq? 'used (hash-ref used pos #f))
|
||||
(begin
|
||||
(log-debug "drop ~s" name)
|
||||
#f)))
|
||||
name))
|
||||
|
||||
(define old-pos-to-new-pos (make-hasheqv))
|
||||
(for/fold ([new-pos internals-pos]) ([name (in-list (append internals lifts))]
|
||||
[pos (in-naturals internals-pos)])
|
||||
(cond
|
||||
[(eq? 'used (hash-ref used pos #f))
|
||||
(hash-set! old-pos-to-new-pos pos new-pos)
|
||||
(add1 new-pos)]
|
||||
[else new-pos]))
|
||||
|
||||
(define used-body
|
||||
;; Drop unused definitions
|
||||
(for/list ([b (in-list body)]
|
||||
#:when (match b
|
||||
[(def-values ids rhs)
|
||||
(for/or ([id (in-list ids)])
|
||||
(eq? 'used (hash-ref used (toplevel-pos id) #f)))]
|
||||
[else (not (void? b))]))
|
||||
b))
|
||||
|
||||
(define new-body (remap-positions used-body
|
||||
(lambda (pos)
|
||||
(if (pos . < . internals-pos)
|
||||
pos
|
||||
(hash-ref old-pos-to-new-pos pos)))))
|
||||
|
||||
(values new-body new-internals new-lifts))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out import))
|
||||
|
||||
(struct import (name shape [pos #:mutable]))
|
||||
|
|
@ -1,63 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/set
|
||||
compiler/cm
|
||||
"find.rkt"
|
||||
"name.rkt"
|
||||
"merge.rkt"
|
||||
"gc.rkt"
|
||||
"bundle.rkt"
|
||||
"write.rkt")
|
||||
|
||||
(provide demodularize
|
||||
|
||||
garbage-collect-toplevels-enabled
|
||||
current-excluded-modules
|
||||
recompile-enabled)
|
||||
|
||||
(define garbage-collect-toplevels-enabled (make-parameter #f))
|
||||
(define recompile-enabled (make-parameter #f))
|
||||
|
||||
(define logger (make-logger 'demodularizer (current-logger)))
|
||||
|
||||
(define (demodularize input-file [given-output-file #f])
|
||||
(parameterize ([current-logger logger]
|
||||
[current-excluded-modules (for/set ([path (in-set (current-excluded-modules))])
|
||||
(normal-case-path (simplify-path (path->complete-path path))))])
|
||||
|
||||
(log-info "Compiling module")
|
||||
(parameterize ([current-namespace (make-base-empty-namespace)])
|
||||
(managed-compile-zo input-file))
|
||||
|
||||
(log-info "Finding modules")
|
||||
(define-values (runs excluded-module-mpis) (find-modules input-file))
|
||||
|
||||
(log-info "Selecting names")
|
||||
(define-values (names internals lifts imports) (select-names runs))
|
||||
|
||||
(log-info "Merging linklets")
|
||||
(define-values (body first-internal-pos get-merge-info)
|
||||
(merge-linklets runs names internals lifts imports))
|
||||
|
||||
(log-info "GCing definitions")
|
||||
(define-values (new-body new-internals new-lifts)
|
||||
(gc-definitions body internals lifts first-internal-pos
|
||||
#:assume-pure? (garbage-collect-toplevels-enabled)))
|
||||
|
||||
(log-info "Bundling linklet")
|
||||
(define bundle (wrap-bundle new-body new-internals new-lifts
|
||||
excluded-module-mpis
|
||||
get-merge-info))
|
||||
|
||||
(log-info "Writing bytecode")
|
||||
(define output-file (or given-output-file
|
||||
(path-add-suffix input-file #"_merged.zo")))
|
||||
(write-module output-file bundle)
|
||||
|
||||
(when (recompile-enabled)
|
||||
(log-info "Recompiling and rewriting bytecode")
|
||||
(define zo (compiled-expression-recompile
|
||||
(parameterize ([read-accept-compiled #t])
|
||||
(call-with-input-file* output-file read))))
|
||||
(call-with-output-file* output-file
|
||||
#:exists 'replace
|
||||
(lambda (out) (write zo out))))))
|
||||
|
|
@ -1,144 +0,0 @@
|
|||
#lang racket/base
|
||||
(require compiler/zo-structs
|
||||
"run.rkt"
|
||||
"name.rkt"
|
||||
"import.rkt"
|
||||
"remap.rkt")
|
||||
|
||||
(provide merge-linklets)
|
||||
|
||||
(define (merge-linklets runs names internals lifts imports)
|
||||
(define (syntax-literals-import? path/submod+phase)
|
||||
(eq? (cdr path/submod+phase) 'syntax-literals))
|
||||
(define (transformer-register-import? path/submod+phase)
|
||||
(eq? (cdr path/submod+phase) 'transformer-register))
|
||||
|
||||
;; Pick an order for the remaining imports:
|
||||
(define import-keys (for/list ([path/submod+phase (in-hash-keys imports)]
|
||||
;; References to a 'syntax-literals "phase" are
|
||||
;; references to the implicit syntax-literals
|
||||
;; module; drop those:
|
||||
#:unless (or (syntax-literals-import? path/submod+phase)
|
||||
(transformer-register-import? path/submod+phase)))
|
||||
path/submod+phase))
|
||||
|
||||
(define any-syntax-literals?
|
||||
(for/or ([path/submod+phase (in-hash-keys imports)])
|
||||
(syntax-literals-import? path/submod+phase)))
|
||||
(define any-transformer-registers?
|
||||
(for/or ([path/submod+phase (in-hash-keys imports)])
|
||||
(transformer-register-import? path/submod+phase)))
|
||||
(define syntax-literals-pos 1)
|
||||
(define transformer-register-pos (+ (if any-syntax-literals? 1 0)
|
||||
syntax-literals-pos))
|
||||
(define import-counter (+ (if any-transformer-registers? 1 0)
|
||||
transformer-register-pos))
|
||||
|
||||
;; Map each remaining import to its position
|
||||
(define ordered-importss
|
||||
(for/list ([key (in-list import-keys)])
|
||||
(define ordered-imports (hash-ref imports key))
|
||||
(for ([name (in-list ordered-imports)])
|
||||
(define i (hash-ref names (cons key name)))
|
||||
(set-import-pos! i import-counter)
|
||||
(set! import-counter (add1 import-counter)))
|
||||
ordered-imports))
|
||||
;; Keep all the same import shapes
|
||||
(define import-shapess
|
||||
(for/list ([key (in-list import-keys)])
|
||||
(for/list ([name (in-list (hash-ref imports key))])
|
||||
(import-shape (hash-ref names (cons key name))))))
|
||||
|
||||
;; Map all syntax-literal references to the same import.
|
||||
;; We could update each call to the access to use a suitable
|
||||
;; vector index.
|
||||
(for ([(path/submod+phase imports) (in-hash imports)]
|
||||
#:when (syntax-literals-import? path/submod+phase)
|
||||
[name (in-list imports)])
|
||||
(define i (hash-ref names (cons path/submod+phase name)))
|
||||
(set-import-pos! i syntax-literals-pos))
|
||||
|
||||
;; Map the transformer-register import, if any
|
||||
(let* ([path/submod+phase '(#%transformer-register . transformer-register)]
|
||||
[imports (hash-ref imports path/submod+phase null)])
|
||||
(for ([name (in-list imports)])
|
||||
(define i (hash-ref names (cons path/submod+phase name)))
|
||||
(set-import-pos! i transformer-register-pos)))
|
||||
|
||||
;; Map internals and lifts to positions
|
||||
(define first-internal-pos import-counter)
|
||||
(define positions
|
||||
(for/hash ([name (in-list (append internals lifts))]
|
||||
[i (in-naturals first-internal-pos)])
|
||||
(values name i)))
|
||||
|
||||
;; For each linklet that we merge, make a mapping from
|
||||
;; the linklet's old position to new names (which can
|
||||
;; then be mapped to new positions):
|
||||
(define (make-position-mapping r)
|
||||
(define h (make-hasheqv))
|
||||
(define linkl (run-linkl r))
|
||||
(define importss (linkl-importss linkl))
|
||||
(define pos 1)
|
||||
(for ([imports (in-list importss)]
|
||||
[use (in-list (run-uses r))])
|
||||
(for ([name (in-list imports)])
|
||||
(hash-set! h pos (find-name names use name))
|
||||
(set! pos (add1 pos))))
|
||||
(define path/submod+phase (cons (run-path/submod r) (run-phase r)))
|
||||
(for ([name (in-list (append (linkl-exports linkl)
|
||||
(linkl-internals linkl)
|
||||
(linkl-lifts linkl)))]
|
||||
[pos (in-naturals pos)])
|
||||
(hash-set! h pos (find-name names path/submod+phase name)))
|
||||
h)
|
||||
|
||||
;; Do we need the implicit initial variable for `(#%variable-reference)`?
|
||||
;; The slot will be reserved whether we use it or not, but the
|
||||
;; slot is not necessarily initialized if we don't need it.
|
||||
(define saw-zero-pos-toplevel? #f)
|
||||
|
||||
(define body
|
||||
(apply
|
||||
append
|
||||
(for/list ([r (in-list runs)])
|
||||
(define pos-to-name/import (make-position-mapping r))
|
||||
(define (remap-toplevel-pos pos)
|
||||
(cond
|
||||
[(zero? pos)
|
||||
;; Implicit variable for `(#%variable-reference)` stays in place:
|
||||
(set! saw-zero-pos-toplevel? #t)
|
||||
0]
|
||||
[else
|
||||
(define new-name/import (hash-ref pos-to-name/import pos))
|
||||
(if (import? new-name/import)
|
||||
(import-pos new-name/import)
|
||||
(hash-ref positions new-name/import))]))
|
||||
|
||||
(remap-positions (linkl-body (run-linkl r))
|
||||
remap-toplevel-pos
|
||||
#:application-hook
|
||||
(lambda (rator rands remap)
|
||||
;; Check for a `(.get-syntax-literal! '<pos>)` call
|
||||
(cond
|
||||
[(and (toplevel? rator)
|
||||
(let ([i (hash-ref pos-to-name/import (toplevel-pos rator))])
|
||||
(and (import? i)
|
||||
(eqv? syntax-literals-pos (import-pos i)))))
|
||||
;; This is a `(.get-syntax-literal! '<pos>)` call
|
||||
(application (remap rator)
|
||||
;; To support syntax objects, change the offset
|
||||
rands)]
|
||||
[else #f]))))))
|
||||
|
||||
(values body
|
||||
first-internal-pos
|
||||
;; Communicates into to `wrap-bundle`:
|
||||
(lambda ()
|
||||
(values runs
|
||||
import-keys
|
||||
ordered-importss
|
||||
import-shapess
|
||||
any-syntax-literals?
|
||||
any-transformer-registers?
|
||||
saw-zero-pos-toplevel?))))
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
#lang racket/base
|
||||
(require syntax/modresolve)
|
||||
|
||||
(provide module-path-index->path
|
||||
module-path-index-reroot)
|
||||
|
||||
(define (module-path-index->path req path submod)
|
||||
(define mpi (module-path-index-build req path submod))
|
||||
|
||||
(define p (resolve-module-path-index mpi path))
|
||||
|
||||
;; Make sure a path name is normalized
|
||||
(define p-path (if (pair? p) (cadr p) p))
|
||||
(define p-submod (if (pair? p) (cddr p) '()))
|
||||
(define p-simple-path (if (path? p-path)
|
||||
(normal-case-path (simplify-path p-path))
|
||||
p-path))
|
||||
|
||||
;; Combine path back with submod
|
||||
(if (null? p-submod)
|
||||
p-simple-path
|
||||
(cons p-simple-path p-submod)))
|
||||
|
||||
(define (module-path-index-build req path submod)
|
||||
(module-path-index-reroot req
|
||||
(if (null? submod)
|
||||
(module-path-index-join #f #f)
|
||||
(module-path-index-join `(submod "." ,@submod)
|
||||
(module-path-index-join #f #f)))))
|
||||
|
||||
(define (module-path-index-reroot req root-mpi)
|
||||
(let loop ([req req])
|
||||
(define-values (mod-path base) (module-path-index-split req))
|
||||
(cond
|
||||
[(not mod-path) root-mpi]
|
||||
[else
|
||||
(module-path-index-join mod-path
|
||||
(and base (loop base)))])))
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
#lang racket/base
|
||||
(require compiler/zo-structs
|
||||
"run.rkt"
|
||||
"import.rkt")
|
||||
|
||||
(provide select-names
|
||||
find-name)
|
||||
|
||||
(define (select-names runs)
|
||||
(define names (make-hash)) ; path/submod+phase+sym -> symbol
|
||||
(define used-names (make-hasheq))
|
||||
(define internals (box '()))
|
||||
(define lifts (box '()))
|
||||
(define imports (make-hash)) ; path/submod+phase -> list-of-sym
|
||||
|
||||
;; Reserve the syntax-literals and transformer-register names:
|
||||
(hash-set! used-names '.get-syntax-literal! #t)
|
||||
(hash-set! used-names '.set-transformer! #t)
|
||||
|
||||
(define (pick-name name)
|
||||
(let loop ([try-name name] [i 0])
|
||||
(cond
|
||||
[(hash-ref used-names try-name #f)
|
||||
(let ([i (add1 i)])
|
||||
(loop (string->symbol (format "~a_~a" name i)) i))]
|
||||
[else
|
||||
(hash-set! used-names try-name #t)
|
||||
try-name])))
|
||||
|
||||
(for ([r (in-list (reverse runs))]) ; biases names to starting module
|
||||
(define linkl (run-linkl r))
|
||||
(define path/submod+phase (cons (run-path/submod r) (run-phase r)))
|
||||
|
||||
;; Process local definitions, first
|
||||
(define (select-names! name-list category)
|
||||
(for ([name (in-list name-list)])
|
||||
(define new-name (pick-name name))
|
||||
(hash-set! names (cons path/submod+phase name) new-name)
|
||||
(set-box! category (cons new-name (unbox category)))))
|
||||
|
||||
(select-names! (linkl-exports linkl) internals)
|
||||
(select-names! (linkl-internals linkl) internals)
|
||||
(select-names! (linkl-lifts linkl) lifts))
|
||||
|
||||
;; Record any imports that will remain as imports; anything
|
||||
;; not yet mapped must be a leftover import
|
||||
(for ([r (in-list runs)])
|
||||
(define linkl (run-linkl r))
|
||||
(for ([import-names (in-list (linkl-importss linkl))]
|
||||
[import-shapes (in-list (linkl-import-shapess linkl))]
|
||||
[use (in-list (run-uses r))])
|
||||
(for ([name (in-list import-names)]
|
||||
[shape (in-list import-shapes)])
|
||||
(unless (hash-ref names (cons use name) #f)
|
||||
(hash-set! imports use (cons name (hash-ref imports use null)))
|
||||
(hash-set! names (cons use name) (import name shape #f))))))
|
||||
|
||||
(values names (unbox internals) (unbox lifts) imports))
|
||||
|
||||
(define (find-name names use name)
|
||||
(hash-ref names (cons use name)))
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/match
|
||||
racket/set
|
||||
compiler/zo-structs)
|
||||
|
||||
(provide remap-positions)
|
||||
|
||||
(define (remap-positions body
|
||||
remap-toplevel-pos ; integer -> integer
|
||||
#:application-hook [application-hook (lambda (rator rands remap) #f)])
|
||||
(define graph (make-hasheq))
|
||||
(make-reader-graph
|
||||
(for/list ([b (in-list body)])
|
||||
(let remap ([b b])
|
||||
(match b
|
||||
[(toplevel depth pos const? ready?)
|
||||
(define new-pos (remap-toplevel-pos pos))
|
||||
(toplevel depth new-pos const? ready?)]
|
||||
[(def-values ids rhs)
|
||||
(def-values (map remap ids) (remap rhs))]
|
||||
[(inline-variant direct inline)
|
||||
(inline-variant (remap direct) (remap inline))]
|
||||
[(closure code gen-id)
|
||||
(cond
|
||||
[(hash-ref graph gen-id #f)
|
||||
=> (lambda (ph) ph)]
|
||||
[else
|
||||
(define ph (make-placeholder #f))
|
||||
(hash-set! graph gen-id ph)
|
||||
(define cl (closure (remap code) gen-id))
|
||||
(placeholder-set! ph cl)
|
||||
cl])]
|
||||
[(let-one rhs body type unused?)
|
||||
(let-one (remap rhs) (remap body) type unused?)]
|
||||
[(let-void count boxes? body)
|
||||
(let-void count boxes? (remap body))]
|
||||
[(install-value count pos boxes? rhs body)
|
||||
(install-value count pos boxes? (remap rhs) (remap body))]
|
||||
[(let-rec procs body)
|
||||
(let-rec (map remap procs) (remap body))]
|
||||
[(boxenv pos body)
|
||||
(boxenv pos (remap body))]
|
||||
[(application rator rands)
|
||||
(cond
|
||||
[(application-hook rator rands (lambda (b) (remap b)))
|
||||
=> (lambda (v) v)]
|
||||
[else
|
||||
;; Any other application
|
||||
(application (remap rator) (map remap rands))])]
|
||||
[(branch tst thn els)
|
||||
(branch (remap tst) (remap thn) (remap els))]
|
||||
[(with-cont-mark key val body)
|
||||
(with-cont-mark (remap key) (remap val) (remap body))]
|
||||
[(beg0 forms)
|
||||
(beg0 (map remap forms))]
|
||||
[(seq forms)
|
||||
(seq (map remap forms))]
|
||||
[(varref toplevel dummy constant? unsafe?)
|
||||
(varref (remap toplevel) (remap dummy) constant? unsafe?)]
|
||||
[(assign id rhs undef-ok?)
|
||||
(assign (remap id) (remap rhs) undef-ok?)]
|
||||
[(apply-values proc args-expr)
|
||||
(apply-values (remap proc) (remap args-expr))]
|
||||
[(with-immed-mark key def-val body)
|
||||
(with-immed-mark (remap key) (remap def-val) (remap body))]
|
||||
[(case-lam name clauses)
|
||||
(case-lam name (map remap clauses))]
|
||||
[_
|
||||
(cond
|
||||
[(lam? b)
|
||||
(define tl-map (lam-toplevel-map b))
|
||||
(define new-tl-map
|
||||
(and tl-map
|
||||
(for/set ([pos (in-set tl-map)])
|
||||
(remap-toplevel-pos pos))))
|
||||
(struct-copy lam b
|
||||
[body (remap (lam-body b))]
|
||||
[toplevel-map new-tl-map])]
|
||||
[else b])])))))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out run))
|
||||
|
||||
(struct run (path/submod phase linkl uses))
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
#lang racket/base
|
||||
(require compiler/zo-marshal)
|
||||
|
||||
(provide write-module)
|
||||
|
||||
(define (write-module output-file bundle)
|
||||
(call-with-output-file*
|
||||
output-file
|
||||
#:exists 'truncate/replace
|
||||
(lambda (o)
|
||||
(zo-marshal-to bundle o))))
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
|
||||
(module embed-sig racket/base
|
||||
(require racket/unit)
|
||||
(provide compiler:embed^)
|
||||
|
||||
(define-signature compiler:embed^
|
||||
(create-embedding-executable
|
||||
make-embedding-executable
|
||||
write-module-bundle
|
||||
embedding-executable-is-directory?
|
||||
embedding-executable-is-actually-directory?
|
||||
embedding-executable-put-file-extension+style+filters
|
||||
embedding-executable-add-suffix)))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/unit
|
||||
racket/contract
|
||||
"sig.rkt"
|
||||
compiler/embed
|
||||
"embed-sig.rkt")
|
||||
|
||||
(define-unit-from-context compiler:embed@ compiler:embed^)
|
||||
(provide compiler:embed@)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/unit compiler/sig compiler/option)
|
||||
|
||||
(provide compiler:option@)
|
||||
|
||||
(define-unit-from-context compiler:option@ compiler:option^)
|
||||
|
|
@ -1,121 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/linklet)
|
||||
|
||||
;; Re-implement just enough deserialization to deal with 'decl
|
||||
;; linklets, so we can get `required`, etc.
|
||||
|
||||
(provide deserialize-instance
|
||||
(struct-out module-use))
|
||||
|
||||
(struct module-use (module phase))
|
||||
(struct provided (binding protected? syntax?))
|
||||
|
||||
(define (deserialize-module-path-indexes gen-vec order-vec)
|
||||
(define gen (make-vector (vector-length gen-vec) #f))
|
||||
(for ([d (in-vector gen-vec)]
|
||||
[i (in-naturals)])
|
||||
(vector-set!
|
||||
gen
|
||||
i
|
||||
(cond
|
||||
[(eq? d 'top) (error 'deserialize-module-path-indexes "expected top")]
|
||||
[(box? d) (module-path-index-join #f #f)]
|
||||
[else
|
||||
(module-path-index-join (vector-ref d 0)
|
||||
(and ((vector-length d) . > . 1)
|
||||
(vector-ref gen (vector-ref d 1))))])))
|
||||
(for/vector #:length (vector-length order-vec) ([p (in-vector order-vec)])
|
||||
(vector-ref gen p)))
|
||||
|
||||
(define (deserialize mpis inspector bulk-binding-registry
|
||||
num-mutables mutable-vec
|
||||
num-shared shared-vec
|
||||
mutable-fill-vec
|
||||
result-vec)
|
||||
(unless (zero? num-mutables) (error 'deserialize "mutables not supported"))
|
||||
|
||||
(define shared-vs (make-vector num-shared #f))
|
||||
(define shared-rest
|
||||
(for/fold ([r (vector->list shared-vec)]) ([i (in-range num-shared)])
|
||||
(define-values (v rest) (decode r mpis shared-vs))
|
||||
(vector-set! shared-vs i v)
|
||||
rest))
|
||||
(unless (null? shared-rest)
|
||||
(error 'deserialize "unexpected leftover serialized form for shared: ~s" shared-rest))
|
||||
|
||||
(define-values (v v-rest) (decode (vector->list result-vec) mpis shared-vs))
|
||||
(unless (null? v-rest)
|
||||
(error 'deserialize "unexpected leftover serialized form: ~s" v-rest))
|
||||
|
||||
v)
|
||||
|
||||
(define (decode r mpis shared-vs)
|
||||
(let loop ([r r])
|
||||
(define (discard r n)
|
||||
(for/fold ([r (cdr r)]) ([i (in-range n)])
|
||||
(define-values (v v-rest) (loop r))
|
||||
v-rest))
|
||||
(cond
|
||||
[(null? r) (error 'deserialize "unexpected end of serialized form")]
|
||||
[else
|
||||
(define i (car r))
|
||||
(case i
|
||||
[(#:ref)
|
||||
(values (vector-ref shared-vs (cadr r)) (cddr r))]
|
||||
[(#:inspector)
|
||||
(values 'inspector (cdr r))]
|
||||
[(#:cons)
|
||||
(define-values (a a-rest) (loop (cdr r)))
|
||||
(define-values (d d-rest) (loop a-rest))
|
||||
(values (cons a d) d-rest)]
|
||||
[(#:list)
|
||||
(define-values (rev rest)
|
||||
(for/fold ([accum '()] [r (cddr r)]) ([i (in-range (cadr r))])
|
||||
(define-values (a a-rest) (loop r))
|
||||
(values (cons a accum) a-rest)))
|
||||
(values (reverse rev) rest)]
|
||||
[(#:mpi)
|
||||
(values (vector-ref mpis (cadr r)) (cddr r))]
|
||||
[(#:hash #:hasheq #:hasheqv)
|
||||
(define ht (case i
|
||||
[(#:hash) (hash)]
|
||||
[(#:hasheq) (hasheq)]
|
||||
[(#:hasheqv) (hasheqv)]))
|
||||
(for/fold ([ht ht] [r (cddr r)]) ([i (in-range (cadr r))])
|
||||
(define-values (k k-rest) (loop r))
|
||||
(define-values (v v-rest) (loop k-rest))
|
||||
(values (hash-set ht k v) v-rest))]
|
||||
[(#:provided)
|
||||
(define-values (bdg bdg-rest) (loop (cdr r)))
|
||||
(define-values (prot? prot?-rest) (loop bdg-rest))
|
||||
(define-values (stx? stx?-rest) (loop prot?-rest))
|
||||
(values (provided bdg prot? stx?) stx?-rest)]
|
||||
[(#:module-binding)
|
||||
(values 'binding (discard r 10))]
|
||||
[(#:simple-module-binding)
|
||||
(values 'binding (discard r 4))]
|
||||
[else
|
||||
(cond
|
||||
[(or (symbol? i)
|
||||
(number? i)
|
||||
(string? i)
|
||||
(null? i)
|
||||
(hash? i)
|
||||
(boolean? i))
|
||||
(values i (cdr r))]
|
||||
[else
|
||||
(error 'deserialize "unsupported instruction: ~s" i)])])])))
|
||||
|
||||
(define (syntax-module-path-index-shift . args)
|
||||
(error 'syntax-module-path-index-shift "not supported"))
|
||||
|
||||
(define (syntax-shift-phase-level . args)
|
||||
(error 'syntax-shift-phase-level "not supported"))
|
||||
|
||||
(define deserialize-instance
|
||||
(make-instance 'deserialize #f 'constant
|
||||
'deserialize-module-path-indexes deserialize-module-path-indexes
|
||||
'syntax-module-path-index-shift syntax-module-path-index-shift
|
||||
'syntax-shift-phase-level syntax-shift-phase-level
|
||||
'module-use module-use
|
||||
'deserialize deserialize))
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/unit)
|
||||
|
||||
(provide compiler:option^
|
||||
compiler^)
|
||||
|
||||
;; Compiler options
|
||||
(define-signature compiler:option^
|
||||
(somewhat-verbose ; default = #f
|
||||
verbose ; default = #f
|
||||
|
||||
|
||||
setup-prefix ; string to embed in public names;
|
||||
; used mainly for compiling extensions
|
||||
; with the collection name so that
|
||||
; cross-extension conflicts are less
|
||||
; likely in architectures that expose
|
||||
; the public names of loaded extensions
|
||||
; default = ""
|
||||
|
||||
3m ; #t => build for 3m
|
||||
; default = #f
|
||||
|
||||
compile-subcollections ; #t => compile collection subdirectories
|
||||
; default = #t
|
||||
|
||||
))
|
||||
|
||||
;; Compiler procedures
|
||||
(define-signature compiler^
|
||||
(compile-zos
|
||||
|
||||
compile-collection-zos
|
||||
compile-directory-zos
|
||||
compile-directory-srcs
|
||||
|
||||
current-compiler-dynamic-require-wrapper
|
||||
compile-notify-handler))
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define collection 'multi)
|
||||
|
||||
(define deps '(["base" #:version "6.5.0.2"]
|
||||
"scheme-lib"
|
||||
"rackunit-lib"
|
||||
"zo-lib"))
|
||||
|
||||
(define implies '("zo-lib"))
|
||||
|
||||
(define pkg-desc "implementation (no documentation) part of \"compiler\"")
|
||||
|
||||
(define pkg-authors '(mflatt))
|
||||
|
||||
(define version "1.7")
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
#lang racket/signature
|
||||
|
||||
make-gracket-launcher
|
||||
make-racket-launcher
|
||||
make-mred-launcher
|
||||
make-mzscheme-launcher
|
||||
|
||||
make-gracket-program-launcher
|
||||
make-racket-program-launcher
|
||||
make-mred-program-launcher
|
||||
make-mzscheme-program-launcher
|
||||
|
||||
gracket-program-launcher-path
|
||||
racket-program-launcher-path
|
||||
mred-program-launcher-path
|
||||
mzscheme-program-launcher-path
|
||||
|
||||
install-gracket-program-launcher
|
||||
install-racket-program-launcher
|
||||
install-mred-program-launcher
|
||||
install-mzscheme-program-launcher
|
||||
|
||||
gracket-launcher-up-to-date?
|
||||
racket-launcher-up-to-date?
|
||||
mred-launcher-up-to-date?
|
||||
mzscheme-launcher-up-to-date?
|
||||
|
||||
gracket-launcher-is-directory?
|
||||
racket-launcher-is-directory?
|
||||
mred-launcher-is-directory?
|
||||
mzscheme-launcher-is-directory?
|
||||
|
||||
gracket-launcher-is-actually-directory?
|
||||
racket-launcher-is-actually-directory?
|
||||
mred-launcher-is-actually-directory?
|
||||
mzscheme-launcher-is-actually-directory?
|
||||
|
||||
gracket-launcher-add-suffix
|
||||
racket-launcher-add-suffix
|
||||
mred-launcher-add-suffix
|
||||
mzscheme-launcher-add-suffix
|
||||
|
||||
gracket-launcher-put-file-extension+style+filters
|
||||
racket-launcher-put-file-extension+style+filters
|
||||
mred-launcher-put-file-extension+style+filters
|
||||
mzscheme-launcher-put-file-extension+style+filters
|
||||
|
||||
build-aux-from-path
|
||||
extract-aux-from-path
|
||||
current-launcher-variant
|
||||
available-mred-variants
|
||||
available-mzscheme-variants
|
||||
available-gracket-variants
|
||||
available-racket-variants
|
||||
|
||||
installed-executable-path->desktop-path
|
||||
installed-desktop-path->icon-path
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/unit "launcher-sig.rkt" launcher/launcher)
|
||||
|
||||
(provide launcher@)
|
||||
|
||||
(define-unit-from-context launcher@ launcher^)
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
(module option-sig racket/base
|
||||
(require racket/unit)
|
||||
|
||||
(provide setup-option^)
|
||||
|
||||
(define-signature setup-option^
|
||||
(setup-program-name
|
||||
setup-compiled-file-paths
|
||||
verbose
|
||||
make-verbose
|
||||
compiler-verbose
|
||||
clean
|
||||
compile-mode
|
||||
make-only
|
||||
make-zo
|
||||
make-info-domain
|
||||
make-foreign-libs
|
||||
make-launchers
|
||||
make-docs
|
||||
make-user
|
||||
make-planet
|
||||
avoid-main-installation
|
||||
make-tidy
|
||||
make-doc-index
|
||||
check-dependencies
|
||||
fix-dependencies
|
||||
call-install
|
||||
call-post-install
|
||||
pause-on-errors
|
||||
parallel-workers
|
||||
force-unpacks
|
||||
doc-pdf-dest
|
||||
specific-collections
|
||||
specific-planet-dirs
|
||||
archives
|
||||
archive-implies-reindex
|
||||
current-target-directory-getter
|
||||
current-target-plt-directory-getter)))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/unit setup/option "option-sig.rkt")
|
||||
|
||||
(provide setup:option@ set-flag-params)
|
||||
|
||||
(define-unit-from-context setup:option@ setup-option^)
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/unit setup/setup-core)
|
||||
|
||||
(provide setup@)
|
||||
(define-unit setup@
|
||||
(import)
|
||||
(export)
|
||||
(setup-core))
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
compiler-test
|
||||
Copyright (c) 2010-2018 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
|
||||
applications, provided you follow the rules stated in the LGPL. You
|
||||
can also modify this package; if you distribute a modified version,
|
||||
you must distribute it under the terms of the LGPL, which in
|
||||
particular means that you must release the source code for the
|
||||
modified software. See http://www.gnu.org/copyleft/lesser.html
|
||||
for more information.
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define collection 'multi)
|
||||
|
||||
(define deps '("base" "icons"))
|
||||
|
||||
(define pkg-desc "tests for \"compiler-lib\"")
|
||||
|
||||
(define pkg-authors '(mflatt))
|
||||
(define build-deps '("compiler-lib"
|
||||
"eli-tester"
|
||||
"rackunit-lib"
|
||||
"net-lib"
|
||||
"scheme-lib"
|
||||
"compatibility-lib"
|
||||
"gui-lib"
|
||||
"htdp-lib"
|
||||
"plai-lib"
|
||||
"rackunit-lib"
|
||||
"dynext-lib"
|
||||
"mzscheme-lib"))
|
||||
(define update-implies '("compiler-lib"))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket
|
||||
(require compiler/compiler)
|
||||
|
||||
;; minimal sanity check:
|
||||
(compile-collection-zos "setup")
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket
|
||||
(require rackunit)
|
||||
(require (only-in (submod compiler/commands/test paths) collection-paths))
|
||||
|
||||
(check-exn exn? (lambda () (collection-paths ".")))
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
#lang racket
|
||||
(require setup/dirs)
|
||||
|
||||
(define raco (build-path (find-console-bin-dir)
|
||||
(if (eq? (system-type) 'windows)
|
||||
"raco.exe"
|
||||
"raco")))
|
||||
|
||||
(define tmp (make-temporary-file))
|
||||
|
||||
(system* raco
|
||||
"ctool"
|
||||
"--3m"
|
||||
"--c-mods"
|
||||
tmp
|
||||
"++lib"
|
||||
"racket")
|
||||
|
||||
(delete-file tmp)
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
#lang racket
|
||||
(require tests/eli-tester
|
||||
racket/runtime-path
|
||||
compiler/find-exe)
|
||||
|
||||
(define (capture-output command . args)
|
||||
(define o (open-output-string))
|
||||
(define e (open-output-string))
|
||||
(parameterize ([current-input-port (open-input-string "")]
|
||||
[current-output-port o]
|
||||
[current-error-port e])
|
||||
(apply system* command args))
|
||||
(values (get-output-string o) (get-output-string e)))
|
||||
|
||||
(define (test-on-program filename [exceptions null])
|
||||
;; run modular program, capture output
|
||||
(define-values (modular-output modular-error)
|
||||
(capture-output (find-exe) filename))
|
||||
|
||||
(define demod-filename
|
||||
(let-values ([(base filename dir?) (split-path filename)])
|
||||
(path->string
|
||||
(build-path
|
||||
(find-system-path 'temp-dir)
|
||||
(path-add-suffix filename #"_merged.zo")))))
|
||||
|
||||
;; demodularize
|
||||
(parameterize ([current-input-port (open-input-string "")])
|
||||
(apply system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename
|
||||
(append exceptions
|
||||
(list filename))))
|
||||
|
||||
;; run whole program
|
||||
(define-values (whole-output whole-error)
|
||||
(capture-output (find-exe) demod-filename))
|
||||
|
||||
;; compare output
|
||||
(test
|
||||
#:failure-prefix (format "~a stdout" filename)
|
||||
whole-output => modular-output
|
||||
#:failure-prefix (format "~a stderr" filename)
|
||||
whole-error => modular-error))
|
||||
|
||||
(define-runtime-path tests "tests")
|
||||
|
||||
(define (modular-program? filename)
|
||||
(and (not (regexp-match #rx"merged" filename))
|
||||
(regexp-match #rx"rkt$" filename)))
|
||||
|
||||
(test
|
||||
(for ([i (in-list (directory-list tests))])
|
||||
(define ip (build-path tests i))
|
||||
(when (modular-program? ip)
|
||||
(printf "Checking ~a\n" ip)
|
||||
(test-on-program (path->string ip))
|
||||
(printf "Checking ~a, skip racket/private/pre-base\n" ip)
|
||||
(test-on-program (path->string ip)
|
||||
(list "-e"
|
||||
(path->string
|
||||
(collection-file-path "pre-base.rkt" "racket/private")))))))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define test-timeouts '(("demod-test.rkt" 300)))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang racket/base
|
||||
5
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(module kernel-5 '#%kernel
|
||||
(#%require racket/private/map)
|
||||
(define-values (id) (λ (x) x))
|
||||
(define-values (xs) (list 1 2 3 4 5))
|
||||
(map id (map id xs)))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang racket
|
||||
5
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-advanced-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-beginner-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-beginner-abbr-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-intermediate-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
;; The first three lines of this file were inserted by DrRacket. They record metadata
|
||||
;; about the language level of this file in a form that our tools can easily process.
|
||||
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname ex) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
|
||||
10
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(module embed-me1 mzscheme
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1\n"))
|
||||
'append))
|
||||
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
(module embed-me10 mzscheme
|
||||
(require openssl/mzssl)
|
||||
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf "~a\n" ssl-available?))
|
||||
'append))
|
||||
|
||||
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
(module embed-me11-rd mzscheme
|
||||
(provide (rename *read-syntax read-syntax)
|
||||
(rename *read read))
|
||||
|
||||
(define (*read port)
|
||||
`(module embed-me11 mzscheme
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf ,(read port)
|
||||
;; Use `getenv' at read time!!!
|
||||
,(getenv "ELEVEN")))
|
||||
'append)))
|
||||
|
||||
(define (*read-syntax src port)
|
||||
(*read port)))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#reader(lib "embed-me11-rd.ss" "tests" "compiler" "embed")
|
||||
"It goes to ~a!\n"
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
(module embed-me11-rd mzscheme
|
||||
(provide (rename *read-syntax read-syntax)
|
||||
(rename *read read))
|
||||
|
||||
(define (*read port)
|
||||
`(module embed-me11 mzscheme
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf ,(read port)
|
||||
;; Use `getenv' at read time!!!
|
||||
,(getenv "ELEVEN")))
|
||||
'append)))
|
||||
|
||||
(define (*read-syntax src port)
|
||||
(*read port)))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#reader(lib "embed-me12-rd.rkt" "tests" "compiler" "embed")
|
||||
"It goes to ~a!\n"
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/runtime-path)
|
||||
(define-runtime-module-path-index _mod "embed-me14.rkt")
|
||||
(dynamic-require _mod #f)
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
(require "embed-me13.rkt")
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 14\n"))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
#lang racket/base
|
||||
(define two 2)
|
||||
(provide two)
|
||||
|
||||
(module* one #f
|
||||
(require (submod "." ".." three))
|
||||
(define one 1)
|
||||
(provide one two three))
|
||||
|
||||
(module three racket/base
|
||||
(define three 3)
|
||||
(provide three))
|
||||
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (submod "embed-me15-one.rkt" one))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is ~a.\n" (+ 9 one two three)))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
;; a `main' submodule:
|
||||
(module main racket/base
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 16.\n"))
|
||||
#:exists 'append))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (submod "embed-me17a.rkt" sub))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(define print-17
|
||||
(lambda () (printf "This is 17.\n")))
|
||||
|
||||
(module+ sub
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
print-17
|
||||
#:exists 'append))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (submod tests/compiler/embed/embed-me18a sub))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(dynamic-require '(submod tests/compiler/embed/embed-me18a sub) 'print-18)
|
||||
#:exists 'append)
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket/base
|
||||
(module sub racket/base
|
||||
(provide print-18)
|
||||
(define (print-18)
|
||||
(printf "This is 18.\n")))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/runtime-path)
|
||||
|
||||
(define-runtime-module-path plai plai)
|
||||
(define-runtime-module-path plai-reader plai/lang/reader)
|
||||
(define-runtime-module-path runtime racket/runtime-config)
|
||||
|
||||
(parameterize ([read-accept-reader #t])
|
||||
(namespace-require 'racket/base)
|
||||
(eval (read (open-input-string "#lang plai 10"))))
|
||||
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 19.\n"))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path
|
||||
(for-syntax scheme/base))
|
||||
(define-runtime-path file '(lib "icons/file.gif"))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1b\n"))
|
||||
#:exists 'append)
|
||||
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path
|
||||
(for-syntax scheme/base))
|
||||
(define-runtime-path file '(lib "etc.ss")) ; in mzlib
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1c\n"))
|
||||
#:exists 'append)
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path
|
||||
(for-syntax scheme/base))
|
||||
(define-runtime-path file '(lib "file.gif" "icons"))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1d\n"))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path
|
||||
(for-syntax scheme/base))
|
||||
(define-runtime-path file '(lib "html"))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 1e\n"))
|
||||
#:exists 'append)
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/runtime-path)
|
||||
|
||||
;; Check that relative paths are preserved:
|
||||
(define-runtime-path f1 "embed-me1f1.rktl")
|
||||
(define-runtime-path f2 "sub/embed-me1f2.rktl")
|
||||
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (parameterize ([current-namespace (make-base-namespace)])
|
||||
(load f1)))
|
||||
#:exists 'append)
|
||||
|
|
@ -1 +0,0 @@
|
|||
(load-relative "sub/embed-me1f2.rktl")
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
(module embed-me2 mzscheme
|
||||
(require "embed-me1.ss"
|
||||
mzlib/etc)
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 2: ~a\n" true))
|
||||
'append))
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
;; like "embed-me16.rkt" using `module+'
|
||||
(module+ main
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 20.\n"))
|
||||
#:exists 'append))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/match)
|
||||
|
||||
;; check using `racket/match', particularly with a pattern
|
||||
;; that eneds run-time support that may go through a
|
||||
;; compile-time `lazy-require':
|
||||
|
||||
(match "x"
|
||||
[(pregexp "x")
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "This is 21.\n"))
|
||||
#:exists 'append)])
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
#lang racket/kernel
|
||||
|
||||
(printf "This is 22.\n")
|
||||
|
||||
(module configure-runtime racket/kernel
|
||||
(printf "Configure!\n"))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/serialize)
|
||||
|
||||
(serializable-struct foo (a b))
|
||||
|
||||
(define f (deserialize (serialize (foo 1 2))))
|
||||
(foo-a f)
|
||||
(foo-b f)
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
"Ok"
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module+ main
|
||||
12)
|
||||
|
||||
(module submod racket/base
|
||||
11)
|
||||
|
||||
10
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module+ main
|
||||
12)
|
||||
|
||||
(module submod racket/base
|
||||
11)
|
||||
|
||||
10
|
||||
(require (submod "embed-me27.rkt" other-submod))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module+ other-submod 'y)
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/place)
|
||||
|
||||
(define (go)
|
||||
(place pch
|
||||
(place-channel-put pch 28)))
|
||||
|
||||
(module+ main
|
||||
(define p (go))
|
||||
(define n (place-channel-get p))
|
||||
(void (place-wait p))
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda () (printf "~a\n" n))
|
||||
#:exists 'append))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module inside racket/base
|
||||
(define inside 'inside)
|
||||
(provide inside))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(module main racket/base
|
||||
(require (submod "embed-me29-2.rkt" inside))
|
||||
inside)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
(module embed-me3 mzscheme
|
||||
(require mzlib/etc)
|
||||
(with-output-to-file (build-path (find-system-path 'temp-dir) "stdout")
|
||||
(lambda ()
|
||||
(printf "3 is here, too? ~a\n" true))
|
||||
'append))
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user