add Racket-based bootstrap support
Move "racket/src/cs/bootstrap" from the Racket source repository to this one, because the bootstrapping implementation needs to track the Chez Scheme source much more closely than the Racket implementation. Currently, any Racket v7.1 or later works. Also update "README.md" and "BUILDING" to get all the information consistent and in sync with revised build options. original commit: a9e6e99ea414b4625fe9705e4f3cfd62bbf38ae2
This commit is contained in:
Matthew Flatt
parent
29bdb304cf
commit
aa9bba9328
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -48,3 +48,4 @@
|
|||
/release_notes/*.htoc
|
||||
/release_notes/*.log
|
||||
/release_notes/release_notes.pdf
|
||||
/rktboot/compiled/
|
||||
|
|
|
|||
460
BUILDING
460
BUILDING
|
|
@ -1,11 +1,11 @@
|
|||
Building Chez Scheme Version 9.5.3
|
||||
Building Chez Scheme Version 9.5.3.x (Racket variant)
|
||||
Copyright 1984-2019 Cisco Systems, Inc.
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License");
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS,
|
||||
|
|
@ -13,334 +13,328 @@ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|||
See the License for the specific language governing permissions and
|
||||
limitations under the License.
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
This variant of Chez Scheme is patched for Racket. It doesn't include
|
||||
boot files; instead, Racket can generate initial boot files from Chez
|
||||
Scheme's source. For more information, see "racket/src/cs/README.txt"
|
||||
in Racket sources. After you have boot files, then the directions below
|
||||
should work.
|
||||
PREREQUISITES
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
On Unix variants:
|
||||
|
||||
This directory contains the sources for Chez Scheme, plus boot and header
|
||||
files for various supported machine types.
|
||||
* GNU Make
|
||||
* GCC, Clang, or a similarly capable compiler
|
||||
* Header files and libraries for ncurses [unless --disable-curses]
|
||||
* Header files and libraries for X windows [unless --disable-x11]
|
||||
* Header files and libraries for uuid
|
||||
|
||||
BASICS
|
||||
On Windows:
|
||||
|
||||
Building and installing Chez Scheme on a recent version of Linux or OS X
|
||||
is typically as simple as installing the prerequisites listed below and
|
||||
running (Windows build instructions appear under the heading WINDOWS
|
||||
later in this file):
|
||||
* Microsoft Visual Studio 2019, 2017, or 2015
|
||||
|
||||
./configure
|
||||
sudo make install
|
||||
or
|
||||
|
||||
This should not take more than a minute or so, after which the commands
|
||||
'scheme' and 'petite' can be used to run Chez Scheme and Petite Chez
|
||||
Scheme, while 'man scheme' and 'man petite' can be used to view the
|
||||
manual pages. Chez Scheme and Petite Chez Scheme are terminal-based
|
||||
programs, not GUIs. They both incorporate sophisticated command-line
|
||||
editing reminiscent of tcsh but with support for expressions that span
|
||||
multiple lines.
|
||||
* Bash/WSL, MinGW/MSYS, or Cygwin with bash, git, grep, make, sed,
|
||||
etc.
|
||||
|
||||
Prerequisites:
|
||||
|
||||
* GNU Make
|
||||
* gcc
|
||||
* Header files and libraries for ncurses [unless --disable-curses]
|
||||
* Header files and libraries for X windows [unless --disable-x11]
|
||||
* Header files and libraries for uuid
|
||||
GETTING STARTED
|
||||
|
||||
This directory contains the sources for Chez Scheme. It may also
|
||||
contain boot and header files in "boot/pb" for the "portable bytecode"
|
||||
Chez Scheme machine type, which can be used to build for native
|
||||
machine types, or you may have to create initial boot files using
|
||||
Racket.
|
||||
|
||||
In you're on Windows, see the WINDOWS VIA COMMAND PROMPT or WINDOWS
|
||||
VIA SHELL section later in this file. Otherwise, to get further
|
||||
instructions, try running
|
||||
|
||||
./configure
|
||||
make <machine type>
|
||||
|
||||
The output will either suggest using Racket as
|
||||
|
||||
racket rktboot/main.rkt --machine <machine type>
|
||||
|
||||
or using the pb boot files with
|
||||
|
||||
./configure --pb
|
||||
make <machine type>.bootquick
|
||||
|
||||
and then trying again with `./configure`.
|
||||
|
||||
If you plan to build on multiple different machines, then it may be a
|
||||
good idea to generate pb boot files via Racket:
|
||||
|
||||
racket rktboot/main.rkt --machine pb
|
||||
|
||||
Then, you can use the ob boot files on different machines instead of
|
||||
having to install Racket on each machine.
|
||||
|
||||
|
||||
CONFIGURING AND BUILDING
|
||||
|
||||
After you have boot files for the current platform, builing an
|
||||
installing is the usual sequence:
|
||||
|
||||
./configure
|
||||
make
|
||||
sudo make install
|
||||
|
||||
This should not take more than a minute or so, after which the
|
||||
commands `scheme` and `petite` can be used to run Chez Scheme and
|
||||
Petite Chez Scheme, while `man scheme` and `man petite` can be used to
|
||||
view the manual pages. Chez Scheme and Petite Chez Scheme are
|
||||
terminal-based programs, not GUIs. They both incorporate sophisticated
|
||||
command-line editing reminiscent of tcsh but with support for
|
||||
expressions that span multiple lines.
|
||||
|
||||
Uninstalling on Unix-like systems is as simple as running:
|
||||
|
||||
sudo make uninstall
|
||||
sudo make uninstall
|
||||
|
||||
BUILDING VERSION 9.5 AND EARLIER
|
||||
|
||||
If the environment variable CHEZSCHEMELIBDIRS is set, please unset
|
||||
it before running make. Depending on the variable's value, it can
|
||||
cause the build process to fail.
|
||||
|
||||
DETAILS
|
||||
|
||||
The sources for Chez Scheme come in two parts:
|
||||
|
||||
* A set of Scheme source files found in the subdirectory s. Compiling
|
||||
these produces the boot files petite.boot and scheme.boot, along with
|
||||
two header files, equates.h and scheme.h.
|
||||
* A set of Scheme source files found in the subdirectory "s".
|
||||
Compiling these produces the boot files "petite.boot" and
|
||||
"scheme.boot", along with two header files, "equates.h" and
|
||||
"scheme.h".
|
||||
|
||||
* A set of C source files found in the subdirectory c. Compiling and
|
||||
linking these files produces the executable scheme (scheme.exe under
|
||||
Windows). Compiling the C sources requires the two header files
|
||||
produced by compiling the Scheme sources.
|
||||
* A set of C source files found in the subdirectory "c". Compiling
|
||||
and linking these files produces the executable "scheme" (or
|
||||
"scheme.exe" on Windows). Compiling the C sources requires the two
|
||||
header files produced by compiling the Scheme sources.
|
||||
|
||||
Since the Scheme sources can be compiled only by a working version of
|
||||
Chez Scheme, it's not actually possible to build Chez Scheme from source.
|
||||
That's why the boot and header files are packaged with the sources.
|
||||
The Scheme sources can be compiled only by a working version of Chez
|
||||
Scheme or via Racket; it's not possible to build Chez Scheme from
|
||||
source using only standard Unix tools, such as a C compiler, unless
|
||||
the "pb" boot files are packaged with the source.
|
||||
|
||||
'./configure' attempts to determine what type of machine it's on and,
|
||||
if successful, creates several files and directories:
|
||||
The "configure" script attempts to determine what type of machine it's
|
||||
on and, if successful, creates several files and directories:
|
||||
|
||||
* The directory nanopass containing the Nanopass Infrastructure,
|
||||
retrieved from GitHub.
|
||||
* The directory "nanopass" containing the Nanopass Infrastructure,
|
||||
retrieved from GitHub.
|
||||
|
||||
* A make file, Makefile, in the root (top level) directory.
|
||||
* "Makefile" in the root (top level) directory.
|
||||
|
||||
* A "workarea", or subdirectory named for the machine type (e.g.,
|
||||
a6le for nonthreaded 64-bit linux). The workarea is a mirror of
|
||||
the root directory, with subdirectories named c, s, and so on.
|
||||
* A workarea as a subdirectory named for the machine type (e.g.,
|
||||
"ta6le" for threaded 64-bit linux). The workarea is a mirror of the
|
||||
root directory, with subdirectories named "c", "s", and so on.
|
||||
Compilation takes place in the workarea.
|
||||
|
||||
* Within the workarea, the files Makefile, Mf-install, and Mf-boot.
|
||||
* Within the workarea, the files "Makefile", "Mf-install", "Mf-boot",
|
||||
etc.
|
||||
|
||||
'./configure' recognizes various options for controlling the type
|
||||
of build and the installation location. For example, '--threads'
|
||||
requests a build with support for native threads, '--32' requests
|
||||
a 32-bit build, and '--installprefix <pathname>' specifies the
|
||||
installation root. './configure --help' prints the supported
|
||||
options.
|
||||
The "configure" script recognizes various options for controlling the
|
||||
type of build and the installation location. For example,
|
||||
`--nothreads` requests a build without support for native threads,
|
||||
`--32` requests a 32-bit build, and `--installprefix <pathname>`
|
||||
specifies the installation root. Run `./configure --help` for
|
||||
information on the supported options.
|
||||
|
||||
The make file supports several targets:
|
||||
The makefile supports several targets:
|
||||
|
||||
'make' or 'make build'
|
||||
compiles and links the C sources to produce the executable, then
|
||||
bootstraps the Scheme sources. Bootstrapping involves using the
|
||||
freshly built scheme executable along with the distributed boot files
|
||||
to compile the Scheme sources. If the new boot files are equivalent
|
||||
to the old boot files, the system is bootstrapped. Otherwise, the new
|
||||
boot files are used to create a newer set, and those are compared.
|
||||
If this succeeds, the system is bootstrapped. Otherwise, the make
|
||||
fails. This should not fail unless the distributed boot files are
|
||||
out of sync with the sources.
|
||||
* `make` or `make build`
|
||||
|
||||
When you make a modification to the system that causes the C side to
|
||||
get out of sync with the Scheme side so that the build fails, try
|
||||
the following from $W if you have a recent version of Chez Scheme
|
||||
installed in your path:
|
||||
Compiles and links the C sources to produce the executable, then
|
||||
bootstraps the Scheme sources. Bootstrapping involves using the
|
||||
freshly built scheme executable along with initial boot files to
|
||||
compile the Scheme sources. If the new boot files are equivalent to
|
||||
the old boot files, the system is bootstrapped. Otherwise, the new
|
||||
boot files are used to create a newer set, and those are compared.
|
||||
If this succeeds, the system is bootstrapped. Otherwise, the make
|
||||
fails --- which should not happen, unless the initial boot files
|
||||
are incorrect or become out of sync with the sources.
|
||||
|
||||
make -C s clean all patchfile=patch Scheme=scheme SCHEMEHEAPDIRS={see below}
|
||||
make build
|
||||
When you make a modification to the system that causes the C side
|
||||
to get out of sync with the Scheme side so that the build fails,
|
||||
the simplest approach is to re-bootstrapp via Racket.
|
||||
|
||||
Set SCHEMEHEAPDIRS to /usr/lib/csv%v/%m:/usr/local/lib/csv%v/%m on
|
||||
Unix-like systems and to %x/../../boot/%m on Windows systems.
|
||||
* `make run`
|
||||
|
||||
Alternatively, if you have a build before the changes at full path
|
||||
<orig>, use
|
||||
Runs the build Chez Scheme without installing.
|
||||
|
||||
make from-orig ORIG=<orig>
|
||||
Alternatively, you can run the executable directly and tell it
|
||||
where to find boot files, either by setting `SCHEMEHEAPDIRS` as
|
||||
|
||||
To run Chez Scheme without installing, you need to tell the
|
||||
executable where to find the boot files. The run target of the
|
||||
makefile will do that
|
||||
env SCHEMEHEAPDIRS=<workarea>/boot/<machine type> \
|
||||
<workarea>/bin/<machine type>/scheme
|
||||
|
||||
make run
|
||||
or this through the `-b` command-line flag, which requires
|
||||
absolute paths:
|
||||
|
||||
or this can be done manually via command-line arguments, e.g.:
|
||||
<workarea>/bin/<machine type>/scheme \
|
||||
-b /path/to/<workarea>/boot/<machine type>/petite.boot \
|
||||
-b /path/to/<workarea>/boot/<machine type>/scheme.boot
|
||||
|
||||
$W/bin/$M/scheme -b $W/boot/$M/petite.boot -b $W/boot/$M/scheme.boot
|
||||
Note that <workarea> and <machine type> are typically the same.
|
||||
|
||||
or by setting the SCHEMEHEAPDIRS variable to point to the directory
|
||||
containing the boot files. For example, in bash:
|
||||
* `sudo make install`
|
||||
|
||||
SCHEMEHEAPDIRS=$W/boot/$M $W/bin/$M/scheme
|
||||
Installs the biult executables, boot files, example files, and
|
||||
manual pages.
|
||||
|
||||
and in tcsh:
|
||||
* `sudo make uninstall`
|
||||
|
||||
setenv SCHEMEHEAPDIRS "$W/boot/$M"
|
||||
$W/bin/$M/scheme
|
||||
Uninstalls the executables, boot files, example files, and manual
|
||||
pages.
|
||||
|
||||
In all cases, $W should be replaced with the name of the workarea,
|
||||
and $M should be replaced with the machine type. (Unless the default
|
||||
is overridden via an argument to ./configure, $W is the same as $M.)
|
||||
* `make test`
|
||||
|
||||
'sudo make install'
|
||||
runs the build plus installs the resulting executables, boot files,
|
||||
example files, and manual pages.
|
||||
Runs the build plus runs a set of test programs in various
|
||||
different ways, e.g., with different compiler options. It can take
|
||||
30 minutes or more, depending on the speed of the machine. It
|
||||
produces voluminous output, so it's best to redirect its stdout and
|
||||
stderr to a file.
|
||||
|
||||
'sudo make uninstall'
|
||||
uninstalls the executables, boot files, example files, and manual pages.
|
||||
A complete run does *not* imply no errors occurred. To check for
|
||||
errors, look at the file "<workarea>/mats/summary", which should
|
||||
contain one line per test run, something like this:
|
||||
|
||||
'make test'
|
||||
runs the build plus runs a set of test programs in various different
|
||||
ways, e.g., with different compiler options. It can take 30 minutes
|
||||
or more, depending on the speed of the machine. It produces voluminous
|
||||
output, so it's best to redirect its stdout and stderr to a file.
|
||||
-------- o=0 --------
|
||||
-------- o=3 --------
|
||||
-------- o=0 cp0=t --------
|
||||
-------- o=3 cp0=t --------
|
||||
-------- o=0 spi=t p=t --------
|
||||
-------- o=3 spi=t p=t --------
|
||||
-------- o=0 eval=interpret --------
|
||||
-------- o=3 eval=interpret --------
|
||||
-------- o=0 cp0=t eval=interpret --------
|
||||
-------- o=3 cp0=t eval=interpret --------
|
||||
-------- o=0 ehc=t eoc=f --------
|
||||
-------- o=3 ehc=t eval=interpret --------
|
||||
|
||||
NB: A complete run does not imply no errors occurred. To check for
|
||||
errors, look at the file $W/mats/summary, where $W is the name of the
|
||||
workarea created by ./configure. $W/mats/summary should contain one
|
||||
line per test run, something like this:
|
||||
If there is anything else in "<workarea>/mats/summary", something
|
||||
unexpected occurred.
|
||||
|
||||
-------- o=0 --------
|
||||
-------- o=3 --------
|
||||
-------- o=0 cp0=t --------
|
||||
-------- o=3 cp0=t --------
|
||||
-------- o=0 spi=t p=t --------
|
||||
-------- o=3 spi=t p=t --------
|
||||
-------- o=0 eval=interpret --------
|
||||
-------- o=3 eval=interpret --------
|
||||
-------- o=0 cp0=t eval=interpret --------
|
||||
-------- o=3 cp0=t eval=interpret --------
|
||||
-------- o=0 ehc=t eoc=f --------
|
||||
-------- o=3 ehc=t eval=interpret --------
|
||||
* `make <machine type>.boot` or `make <machine type>.bootquick`
|
||||
|
||||
If there is anything else in $W/mats/summary, something unexpected
|
||||
occurred.
|
||||
Creates boot files for a supported machine type, which is not
|
||||
necessarily the current machine type. The boot files aer written to
|
||||
a subdirectory in "boot".
|
||||
|
||||
'make bootfiles'
|
||||
runs the build plus uses the locally built system to recreate the
|
||||
distributed boot and header files for each supported machine type.
|
||||
It should be run whenever modifications made to the Scheme sources
|
||||
are to be committed to the source-code repository so that up-to-date
|
||||
boot and header files can be committed as well. 'make bootfiles'
|
||||
can take 5 minutes or more.
|
||||
The difference between `boot` and `bootquick` is that the latter
|
||||
assumes that up-to-date boot files are in place for the current
|
||||
machine type, and it compile the cross compiler in unsafe mode. So,
|
||||
`bootquick` is faster, but `boot` is more helpful during
|
||||
development.
|
||||
|
||||
'make bootfiles' builds boot files for each machine type for which
|
||||
a subdirectory exists in the top-level boot directory. To build
|
||||
for a supported machine type that isn't built by default, simply
|
||||
add the appropriate subdirectory, i.e., 'mkdir boot/$M', where M
|
||||
is the machine type, before running 'make bootfiles'. You can
|
||||
also run '(cd $W ; make -f Mf-boot $M.boot)', where W is the name
|
||||
of a built work area for the host machine type, to build just the
|
||||
boot files for machine-type M.
|
||||
* `make bootfiles`
|
||||
|
||||
'make clean'
|
||||
removes binaries from the workarea.
|
||||
Runs the build plus uses the locally built system to recreate the
|
||||
boot and header files for multiple machine types --- each machine
|
||||
type for which a subdirectory exists in the top-level "boot"
|
||||
directory. To include a supported machine type that isn't already
|
||||
represented in "boot", simply add the appropriate subdirectory as
|
||||
empty or use `make <machine type>.boot` first.
|
||||
|
||||
'make distclean'
|
||||
removes nanopass, Makefile, and all workareas.
|
||||
* `make clean`
|
||||
|
||||
OTHER UNIX VARIANTS
|
||||
Removes binaries from the workarea.
|
||||
|
||||
To build on Unix variants other than Linux and OS X, you will first
|
||||
need to build boot files on a Linux or OS X machine. On that machine,
|
||||
after building Chez Scheme, create boot files for the target machine
|
||||
<machine> with:
|
||||
* `make distclean`
|
||||
|
||||
make boot XM=<machine>
|
||||
Removes "nanopass", "Makefile", and all workareas.
|
||||
|
||||
Copy the generated boot/<machine> directory to the target machine,
|
||||
adding to or replacing the boot directory with pre-built boot files
|
||||
there, and then build as on Linux.
|
||||
|
||||
Remember to use gmake if make is not GNU make. If you run into linker
|
||||
trouble, try running configure with --libkernel so that the build
|
||||
avoids running ld directly.
|
||||
WINDOWS VIA COMMAND PROMPT
|
||||
|
||||
On OpenBSD, Chez Scheme must be built and installed on a filesystem
|
||||
that is mounted with wxallowed.
|
||||
To build the Chez Scheme executable using Microsoft Visual Studio,
|
||||
first set up command-line tools. The "c\vs.bat" script can help if you
|
||||
supply `amd64` for a 64-bit build or `x86` for a 32-bit build:
|
||||
|
||||
On NetBSD, note that the makefiles run "paxctl +m" to enable WX pages
|
||||
(i.e., pages that have both write and execute enabled).
|
||||
c\vs.bat amd64
|
||||
|
||||
WINDOWS
|
||||
Then, run "c\build.bat" with a machine type, either `ta6nt` (64-bit
|
||||
threaded), `a6nt` (64-bit non-threaded), `ti3nt` (32-bit threaded), or
|
||||
`i3nt` (32-bit non-threaded):
|
||||
|
||||
c\build.bat ta6nt
|
||||
|
||||
The resulting executable in "<machine type>\bin\<machine type>" relies
|
||||
on bootfiles in "..\boot\<machine type>" relative to the executable.
|
||||
|
||||
|
||||
WINDOWS VIA SHELL
|
||||
|
||||
Building Chez Scheme under 64-bit Windows with Bash/WSL, MinGW/MSYS,
|
||||
or Cygwin follows the instructions above, except that 'make install'
|
||||
and 'make uninstall' are not supported. Alternatively, the main Chez
|
||||
Scheme executable can be built from the Windows command line or
|
||||
cross-compiled using MinGW as described further below.
|
||||
or Cygwin follows the instructions in GETTING STARTED above, except
|
||||
that `make install` and `make uninstall` are not supported.
|
||||
Alternatively, the main Chez Scheme executable can be built from the
|
||||
Windows command line or cross-compiled using MinGW as described
|
||||
further below.
|
||||
|
||||
On Bash/WSL, the build directory must be in a location with a Windows
|
||||
path such as /mnt/c, and the 'OS' environment variable must be set to
|
||||
'Windows_NT' to indicate a build for Windows, as opposed to a build
|
||||
path such as /mnt/c, and the `OS` environment variable must be set to
|
||||
`Windows_NT` to indicate a build for Windows, as opposed to a build
|
||||
for Linux on Windows:
|
||||
|
||||
env OS=Windows_NT ./configure
|
||||
env OS=Windows_NT make
|
||||
env OS=Windows_NT ./configure
|
||||
env OS=Windows_NT make
|
||||
|
||||
Prerequisites:
|
||||
The generated executables "scheme.exe" and "petite.exe" are in
|
||||
"<machine type>\bin\<machine type>", and each relies on bootfiles in
|
||||
"..\boot\<machine type>" relative to the executable.
|
||||
|
||||
* Bash/WSL, MinGW/MSYS, or Cygwin with bash, git, grep, make, sed, etc.
|
||||
* Microsoft Visual Studio 2019, 2017, or 2015
|
||||
* WiX Toolset (for making an install)
|
||||
|
||||
Be sure that git config core.autocrlf is set to false.
|
||||
|
||||
If you're using Visual Studio 2019, install "Desktop development with C++"
|
||||
on the "Workloads" tabs and the "C++ 2019 Redistributable MSMs" on the
|
||||
"Individual components" tab under the "Compilers, build tools, and runtimes"
|
||||
section.
|
||||
|
||||
To run Chez Scheme or Petite Chez Scheme from a Windows command prompt,
|
||||
set PATH:
|
||||
|
||||
set PATH=$W\bin\$M;%PATH%
|
||||
|
||||
again with $W and $M replaced with the workarea name and machine
|
||||
type, and start Chez Scheme with the command "scheme" or Petite
|
||||
Chez with the command "petite".
|
||||
If you're using Visual Studio 2019, install "Desktop development with
|
||||
C++" on the "Workloads" tabs and the "C++ 2019 Redistributable MSMs"
|
||||
on the "Individual components" tab under the "Compilers, build tools,
|
||||
and runtimes" section.
|
||||
|
||||
The executables are dynamically linked against the Microsoft Visual
|
||||
C++ run-time library vcruntime140.dll. If you distribute the
|
||||
executables to a different system, be sure to include the
|
||||
redistributable run-time library.
|
||||
|
||||
Making an Install for Windows
|
||||
To create an installer:
|
||||
|
||||
cd wininstall
|
||||
make workareas
|
||||
make
|
||||
cd wininstall
|
||||
make workareas
|
||||
make
|
||||
|
||||
This will create workareas and compile binaries for the a6nt, i3nt,
|
||||
ta6nt, and ti3nt configurations and then include them in a single
|
||||
Windows installer package Chez Scheme.exe. The package also includes
|
||||
example files and the redistributable Microsoft Visual C++ run-time
|
||||
libraries.
|
||||
These commands will create workareas and compile binaries for the
|
||||
`a6nt`, `i3nt`, `ta6nt`, and `ti3nt` machine types and then include
|
||||
them in a single Windows installer package "Chez Scheme.exe". The
|
||||
package also includes example files and the redistributable Microsoft
|
||||
Visual C++ run-time libraries.
|
||||
|
||||
Testing under Windows
|
||||
|
||||
The iconv tests in mats/io.ms require that a 32-bit or 64-bit (as
|
||||
appropriate) iconv.dll, libiconv.dll, or libiconv-2.dll implementing
|
||||
GNU libiconv be located in $W\bin\$M or the path. Windows sources for
|
||||
When testing on Windows, the iconv tests in "mats/io.ms" require that
|
||||
a 32-bit or 64-bit (as appropriate) "iconv.dll", "libiconv.dll", or
|
||||
"libiconv-2.dll" implementing GNU libiconv be located alongside the
|
||||
executable or via the `PATH` environment variable. Windows sources for
|
||||
libiconv can be found at:
|
||||
|
||||
http://gnuwin32.sourceforge.net/packages/libiconv.htm
|
||||
http://gnuwin32.sourceforge.net/packages/libiconv.htm
|
||||
|
||||
An alternative that uses the Windows API can be found at:
|
||||
An alternative implementation that uses the Windows API can be found
|
||||
at:
|
||||
|
||||
https://github.com/burgerrg/win-iconv/releases
|
||||
https://github.com/burgerrg/win-iconv/releases
|
||||
|
||||
If the DLL is not present, the iconv tests will fail. No other tests
|
||||
should be affected.
|
||||
|
||||
Unset the TZ environment variable before running the tests, because
|
||||
Unset the `TZ` environment variable before running the tests, because
|
||||
the Cygwin values are incompatible with the Microsoft C Runtime
|
||||
Library.
|
||||
|
||||
Use 'make test' described above to run the tests.
|
||||
|
||||
WINDOWS EXECUTABLE VIA COMMAND PROMPT
|
||||
|
||||
To build the Chez Scheme executable using Microsoft Visual Studio,
|
||||
first set up command-line tools. The c\vs.bat script can help if you
|
||||
supply amd64 for a 64-bit build or x86 for a 32-bit build:
|
||||
|
||||
c\vs.bat amd64
|
||||
|
||||
Then, run c\build/bat with a machine name, either ta6nt (64-bit
|
||||
threaded), a6nt (64-bit non-threaded), ti3nt (32-bit threaded), or
|
||||
i3nt (32-bit non-threaded):
|
||||
|
||||
c\build.bat ta6nt
|
||||
|
||||
The resulting executable in <machine>\bin\<machine> relies on
|
||||
bootfiles in ..\boot\<machine> relative to the executable.
|
||||
|
||||
CROSS-COMPILING THE WINDOWS EXECUTABLE
|
||||
WINDOWS VIA CROSS-COMPILER
|
||||
|
||||
To cross-compile the main Chez Scheme executable for Windows using
|
||||
MinGW, specify suitable build tools to configure, perhaps using
|
||||
--toolprefix= like this:
|
||||
|
||||
./configure -m=ta6nt --threads --toolprefix=x86_64-w64-mingw32-
|
||||
./configure -m=ta6nt --toolprefix=x86_64-w64-mingw32-
|
||||
|
||||
Then, make with c/Mf-<machine> while supplying cross=t and o=o,
|
||||
possibly like this:
|
||||
Then, make with "c/Mf-<machine type>" while supplying `cross=t` and
|
||||
`o=o`, possibly like this:
|
||||
|
||||
(cd ta6nt/c && make -f Mf-ta6nt cross=t o=o)
|
||||
(cd ta6nt/c && make -f Mf-ta6nt cross=t o=o)
|
||||
|
||||
The executable is written to <machine>/bin/<machine>, and it should be
|
||||
installed with bootfiles in ../boot/<machine>/ relative to the
|
||||
executable.
|
||||
The executable is written to <machine type>/bin/<machine type>, and it
|
||||
should be installed with bootfiles in ../boot/<machine type>/ relative
|
||||
to the executable.
|
||||
|
|
|
|||
13
README.md
13
README.md
|
|
@ -1,12 +1,7 @@
|
|||
This variant of Chez Scheme is patched for Racket. It doesn't include
|
||||
boot files; instead, Racket can generate initial boot files from Chez
|
||||
Scheme's source. For more information, see "racket/src/cs/README.txt"
|
||||
in Racket sources.
|
||||
|
||||
----------------------------------------
|
||||
|
||||
Chez Scheme is both a programming language and an implementation
|
||||
of that language, with supporting tools and documentation.
|
||||
Chez Scheme is both a programming language and an implementation of
|
||||
that language, with supporting tools and documentation.
|
||||
This variant of Chez Scheme is extended to support the implementation
|
||||
of [Racket](https://racket-lang.org/).
|
||||
|
||||
As a superset of the language described in the
|
||||
[Revised<sup>6</sup> Report on the Algorithmic Language Scheme](http://www.r6rs.org)
|
||||
|
|
|
|||
40
configure
vendored
40
configure
vendored
|
|
@ -430,15 +430,43 @@ if [ "$help" = "yes" ]; then
|
|||
fi
|
||||
|
||||
if [ "$m" = "" -o ! -f boot/$m/scheme.boot ] ; then
|
||||
echo "No suitable machine type found."
|
||||
if [ "$machine_supplied" = "no" ] ; then
|
||||
echo "Try rerunning as $0 -m=<machine type>"
|
||||
if [ "$m" = "" ] ; then
|
||||
maybem="<machine type>"
|
||||
else
|
||||
maybem=$m
|
||||
fi
|
||||
echo "Available machine types: $machs"
|
||||
echo 'No suitable machine type found in "boot".'
|
||||
echo ""
|
||||
echo "Available machine types:"
|
||||
echo " $machs"
|
||||
if [ "$machine_supplied" = "no" ] ; then
|
||||
echo ""
|
||||
if [ "$m" = "" ] ; then
|
||||
echo "If the problem is that the machine type was not inferred,"
|
||||
echo "you can try"
|
||||
else
|
||||
echo "If the problem is that the inferred machine type $m is"
|
||||
echo "not correct, you can try"
|
||||
fi
|
||||
echo " $0 -m=<machine type>"
|
||||
echo "to specify one of the available machine types."
|
||||
fi
|
||||
echo ""
|
||||
if [ "$m" = "" ] ; then
|
||||
echo 'If no directory in "boot" exists for the correct machine type,'
|
||||
echo "then you can use Racket v7.1 or later with"
|
||||
else
|
||||
echo "Since no directory in "'"boot"'" exists for $m, you can try"
|
||||
echo "using Racket v7.1 or later with"
|
||||
fi
|
||||
echo " racket rktboot/main.rkt --machine $maybem"
|
||||
echo "to create the boot files, and then try $0 again."
|
||||
if [ -f boot/pb/scheme.boot ] ; then
|
||||
echo "A pb machine type is available, so you might also try"
|
||||
echo ""
|
||||
echo "Alternatively, a pb machine type is available, so try"
|
||||
echo " $0 --pb"
|
||||
echo " make <machine type>.bootquick"
|
||||
echo " make $maybem.bootquick"
|
||||
echo "to create the boot files using a portable-bytecode build,"
|
||||
echo "and then try $0 again."
|
||||
fi
|
||||
exit 1
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ build:
|
|||
(cd s && $(MAKE) bootstrap)
|
||||
|
||||
.PHONY: install
|
||||
install: build
|
||||
install:
|
||||
$(MAKE) -f Mf-install
|
||||
|
||||
.PHONY: uninstall
|
||||
|
|
|
|||
19
rktboot/README.txt
Normal file
19
rktboot/README.txt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
This directory constains enough of a Chez Scheme simulation to load
|
||||
the Chez Scheme compiler purely from source into Racket and apply the
|
||||
compiler to itself, thus bootstrapping Chez Scheme. (So, using an
|
||||
existing Racket v7.1 or later, but without using an existing Chez
|
||||
Scheme.)
|
||||
|
||||
The "make-boot.rkt" programs builds Chez Scheme ".boot" and ".h" files
|
||||
from source. The output is written to "<machine>/boot/<machine>" in a
|
||||
Chez Scheme source directory. Build boot files that way before
|
||||
`configure` and `make` to bootstrap the build.
|
||||
|
||||
The Chez Scheme simulation hasn't been made especially fast, so expect
|
||||
the bootstrap process to take 10 times as long as using an existing
|
||||
Chez Scheme.
|
||||
|
||||
While the similation of Chez Scheme should be robust to many Chez
|
||||
Scheme changes, it does rely on details of the Chez Scheme
|
||||
implementation and source, So, the simulation will have to be updated
|
||||
to accommodate some Chez Scheme changes.
|
||||
34
rktboot/config.rkt
Normal file
34
rktboot/config.rkt
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
#lang racket/base
|
||||
(require ffi/unsafe/global)
|
||||
|
||||
(provide scheme-dir
|
||||
target-machine
|
||||
optimize-level-init)
|
||||
|
||||
(define ht (get-place-table))
|
||||
|
||||
(define scheme-dir (or (hash-ref ht 'make-boot-scheme-dir #f)
|
||||
(let ([scheme-dir
|
||||
(getenv "SCHEME_SRC")])
|
||||
(and scheme-dir
|
||||
(simplify-path
|
||||
(path->complete-path scheme-dir))))))
|
||||
(hash-set! ht 'make-boot-scheme-dir scheme-dir)
|
||||
|
||||
(define target-machine (or (hash-ref ht 'make-boot-targate-machine #f)
|
||||
(getenv "MACH")
|
||||
(case (system-type)
|
||||
[(macosx) (if (eqv? 64 (system-type 'word))
|
||||
"ta6osx"
|
||||
"ti3osx")]
|
||||
[(windows) (if (eqv? 64 (system-type 'word))
|
||||
"ta6nt"
|
||||
"ti3nt")]
|
||||
[else
|
||||
(case (path->string (system-library-subpath #f))
|
||||
[("x86_64-linux") "ta6le"]
|
||||
[("i386-linux") "ti3le"]
|
||||
[else #f])])))
|
||||
(hash-set! ht 'make-boot-targate-machine target-machine)
|
||||
|
||||
(define optimize-level-init 3)
|
||||
92
rktboot/constant.rkt
Normal file
92
rktboot/constant.rkt
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
#lang racket/base
|
||||
(require racket/match
|
||||
"scheme-readtable.rkt"
|
||||
"config.rkt")
|
||||
|
||||
;; Extract constants that we need to get started by reading
|
||||
;; "cmacros.ss" and the machine ".def" file (without trying to run or
|
||||
;; expand the files)
|
||||
|
||||
(define ht (make-hasheq))
|
||||
|
||||
(define (read-constants i)
|
||||
(parameterize ([current-readtable scheme-readtable])
|
||||
(let loop ()
|
||||
(define e (read i))
|
||||
(unless (eof-object? e)
|
||||
(match e
|
||||
[`(define-constant ,id2 (case (constant ,id1)
|
||||
[(,v1) ,rv1]
|
||||
[(,v2) ,rv2]
|
||||
. ,_))
|
||||
(define v (hash-ref ht id1))
|
||||
(hash-set! ht id2
|
||||
(cond
|
||||
[(eqv? v v1) rv1]
|
||||
[(eqv? v v2) rv2]
|
||||
[else (error "unknown")]))]
|
||||
[`(define-constant ,id ,e)
|
||||
(let/cc esc
|
||||
(hash-set! ht id (constant-eval e esc)))]
|
||||
[`(define-constant-default ,id ,e)
|
||||
(hash-ref ht id
|
||||
(lambda ()
|
||||
(let/cc esc
|
||||
(hash-set! ht id (constant-eval e esc)))))]
|
||||
[`(include ,fn)
|
||||
(unless (equal? fn "machine.def")
|
||||
(read-constants-from-file fn))]
|
||||
[_ (void)])
|
||||
(loop)))))
|
||||
|
||||
(define (constant-eval e esc)
|
||||
(cond
|
||||
[(pair? e)
|
||||
(case (car e)
|
||||
[(if)
|
||||
(if (constant-eval (cadr e) esc)
|
||||
(constant-eval (caddr e) esc)
|
||||
(constant-eval (cadddr e) esc))]
|
||||
[(constant)
|
||||
(hash-ref ht (cadr e) esc)]
|
||||
[(=)
|
||||
(= (constant-eval (cadr e) ht)
|
||||
(constant-eval (caddr e) ht))]
|
||||
[(quote)
|
||||
(cadr e)]
|
||||
[else (esc)])]
|
||||
[else e]))
|
||||
|
||||
(define (read-constants-from-file fn)
|
||||
(call-with-input-file
|
||||
(build-path scheme-dir "s" fn)
|
||||
read-constants))
|
||||
|
||||
(when scheme-dir
|
||||
(read-constants-from-file
|
||||
(string-append target-machine ".def"))
|
||||
(read-constants-from-file "cmacros.ss"))
|
||||
|
||||
(define-syntax-rule (define-constant id ...)
|
||||
(begin
|
||||
(provide id ...)
|
||||
(define id (hash-ref ht 'id #f)) ...))
|
||||
|
||||
(hash-set! ht 'ptr-bytes (/ (hash-ref ht 'ptr-bits 64) 8))
|
||||
|
||||
(define-constant
|
||||
ptr-bytes
|
||||
fixnum-bits
|
||||
max-float-alignment
|
||||
annotation-debug
|
||||
annotation-profile
|
||||
visit-tag
|
||||
revisit-tag
|
||||
prelex-is-flags-offset
|
||||
prelex-was-flags-offset
|
||||
prelex-sticky-mask
|
||||
prelex-is-mask
|
||||
scheme-version)
|
||||
|
||||
(provide record-ptr-offset)
|
||||
(define record-ptr-offset 1)
|
||||
78
rktboot/define-datatype.rkt
Normal file
78
rktboot/define-datatype.rkt
Normal file
|
|
@ -0,0 +1,78 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(provide define-datatype)
|
||||
|
||||
(define-syntax define-datatype
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name (variant field ...) ...)
|
||||
(identifier? #'name)
|
||||
#'(define-datatype (name) (variant field ...) ...)]
|
||||
[(_ (name base-field ...) (variant field ...) ...)
|
||||
(let ([clean (lambda (l)
|
||||
(map (lambda (f)
|
||||
(syntax-case f ()
|
||||
[(_ id) #'id]
|
||||
[id #'id]))
|
||||
(syntax->list l)))])
|
||||
(with-syntax ([(base-field ...) (clean #'(base-field ...))]
|
||||
[((field ...) ...) (map clean
|
||||
(syntax->list #'((field ...) ...)))]
|
||||
[(name-variant ...) (for/list ([variant (in-list (syntax->list #'(variant ...)))])
|
||||
(format-id variant "~a-~a" #'name variant))]
|
||||
[([set-name-base-field! name-base-field-set!] ...)
|
||||
(for/list ([base-field (in-list (syntax->list #'(base-field ...)))])
|
||||
(define field (syntax-case base-field ()
|
||||
[(_ id) #'id]
|
||||
[id #'id]))
|
||||
(list (format-id field "set-~a-~a!" #'name field)
|
||||
(format-id field "~a-~a-set!" #'name field)))]
|
||||
[name-case (format-id #'name "~a-case" #'name)])
|
||||
#'(begin
|
||||
(define-struct name (base-field ...) #:mutable)
|
||||
(define name-base-field-set! set-name-base-field!) ...
|
||||
(define-struct (name-variant name) (field ...))
|
||||
...
|
||||
(define-syntax (name-case stx)
|
||||
(generate-case stx #'[(name base-field ...)
|
||||
(variant field ...) ...])))))])))
|
||||
|
||||
(define-for-syntax (generate-case stx spec)
|
||||
(syntax-case spec ()
|
||||
[[(name base-field ...) (variant field ...) ...]
|
||||
(let ([variants (syntax->list #'(variant ...))]
|
||||
[fieldss (syntax->list #'((field ...) ...))])
|
||||
(syntax-case stx ()
|
||||
[(_ expr clause ...)
|
||||
(with-syntax ([([lhs rhs ...] ...)
|
||||
(for/list ([clause (in-list (syntax->list #'(clause ...)))])
|
||||
(syntax-case clause (else)
|
||||
[[else . _] clause]
|
||||
[[c-variant (c-field ...) rhs ...]
|
||||
(or (for/or ([variant (in-list variants)]
|
||||
[fields (in-list fieldss)]
|
||||
#:when (eq? (syntax-e #'c-variant) (syntax-e variant)))
|
||||
(with-syntax ([variant? (format-id variant "~a-~a?" #'name variant)]
|
||||
[(field-ref ...) (for/list ([field (in-list (syntax->list fields))])
|
||||
(format-id field "~a-~a-~a" #'name variant field))])
|
||||
#`[(variant? v)
|
||||
(let ([c-field (field-ref v)] ...)
|
||||
rhs ...)]))
|
||||
(raise-syntax-error #f
|
||||
"no matching variant"
|
||||
stx
|
||||
clause))]
|
||||
[_ (raise-syntax-error #f
|
||||
"unrecognized clause"
|
||||
stx
|
||||
clause)]))])
|
||||
#'(let ([v expr])
|
||||
(cond
|
||||
[lhs rhs ...] ...)))]))]))
|
||||
|
||||
(define-for-syntax (format-id ctx fmt . args)
|
||||
(datum->syntax
|
||||
ctx
|
||||
(string->symbol
|
||||
(apply format fmt (map syntax-e args)))))
|
||||
162
rktboot/format.rkt
Normal file
162
rktboot/format.rkt
Normal file
|
|
@ -0,0 +1,162 @@
|
|||
#lang racket/base
|
||||
(require "gensym.rkt")
|
||||
|
||||
(provide s:format
|
||||
s:printf
|
||||
s:fprintf
|
||||
s:error)
|
||||
|
||||
(define (s:format fmt . args)
|
||||
(define o (open-output-string))
|
||||
(do-printf o fmt args)
|
||||
(get-output-string o))
|
||||
|
||||
(define (s:printf fmt . args)
|
||||
(do-printf (current-output-port) fmt args))
|
||||
|
||||
(define (s:fprintf o fmt . args)
|
||||
(do-printf o fmt args))
|
||||
|
||||
(define (s:error sym fmt . args)
|
||||
(define o (open-output-string))
|
||||
(do-printf o fmt args)
|
||||
(error sym "~a" (get-output-string o)))
|
||||
|
||||
(define (do-printf o fmt args)
|
||||
(cond
|
||||
[(and (equal? fmt "~s")
|
||||
(not (print-gensym))
|
||||
(and (pair? args)
|
||||
(gensym? (car args))))
|
||||
(write-string (gensym->pretty-string (car args)) o)]
|
||||
[(and (let loop ([i 0])
|
||||
(cond
|
||||
[(= i (string-length fmt))
|
||||
#t]
|
||||
[(and (char=? #\~ (string-ref fmt i))
|
||||
(< i (sub1 (string-length fmt))))
|
||||
(define c (string-ref fmt (add1 i)))
|
||||
(if (or (char=? c #\a)
|
||||
(char=? c #\s)
|
||||
(char=? c #\v)
|
||||
(char=? c #\e))
|
||||
(loop (+ i 2))
|
||||
#f)]
|
||||
[else (loop (add1 i))]))
|
||||
(or (null? args)
|
||||
(not (bytes? (car args)))))
|
||||
(apply fprintf o fmt args)]
|
||||
[else
|
||||
;; implement additional format functionality
|
||||
(let loop ([i 0] [args args] [mode '()])
|
||||
(cond
|
||||
[(= i (string-length fmt))
|
||||
(unless (null? args) (error 'format "leftover args"))]
|
||||
[(and (char=? #\~ (string-ref fmt i))
|
||||
(< i (sub1 (string-length fmt))))
|
||||
(define c (string-ref fmt (add1 i)))
|
||||
(case c
|
||||
[(#\a #\d)
|
||||
(define v (car args))
|
||||
(cond
|
||||
[(and (gensym? v)
|
||||
(not (print-gensym)))
|
||||
(display (gensym->pretty-string v) o)]
|
||||
[(bytes? v)
|
||||
(begin
|
||||
(write-bytes #"#vu8" o)
|
||||
(display (bytes->list v) o))]
|
||||
[else
|
||||
(display (if (memq 'upcase mode)
|
||||
(string-upcase v)
|
||||
v)
|
||||
o)])
|
||||
(loop (+ i 2) (cdr args) mode)]
|
||||
[(#\s #\v #\e)
|
||||
(define v (car args))
|
||||
(if (bytes? v)
|
||||
(begin
|
||||
(write-bytes #"#vu8" o)
|
||||
(display (bytes->list v) o))
|
||||
(write v o))
|
||||
(loop (+ i 2) (cdr args) mode)]
|
||||
[(#\x)
|
||||
(display (string-upcase (number->string (car args) 16)) o)
|
||||
(loop (+ i 2) (cdr args) mode)]
|
||||
[(#\: #\@)
|
||||
(case (string-ref fmt (+ i 2))
|
||||
[(#\[)
|
||||
(define (until i char print?)
|
||||
(let loop ([i i])
|
||||
(define c (string-ref fmt i))
|
||||
(cond
|
||||
[(and (char=? c #\~)
|
||||
(char=? char (string-ref fmt (add1 i))))
|
||||
(+ i 2)]
|
||||
[print?
|
||||
(write-char c o)
|
||||
(loop (add1 i))]
|
||||
[else (loop (add1 i))])))
|
||||
(define next-i (+ i 3))
|
||||
(case c
|
||||
[(#\@)
|
||||
(cond
|
||||
[(car args)
|
||||
(define-values (close-i rest-args) (loop next-i args mode))
|
||||
(loop close-i rest-args mode)]
|
||||
[else
|
||||
(define close-i (until next-i #\] #f))
|
||||
(loop close-i (cdr args) mode)])]
|
||||
[else
|
||||
(define sep-i (until next-i #\; (not (car args))))
|
||||
(define close-i (until sep-i #\] (car args)))
|
||||
(loop close-i (cdr args) mode)])]
|
||||
[(#\:)
|
||||
(case (string-ref fmt (+ i 3))
|
||||
[(#\()
|
||||
(define-values (close-i rest-args) (loop (+ i 4) args (cons 'upcase mode)))
|
||||
(loop close-i rest-args mode)]
|
||||
[else
|
||||
(error "unexpected after @:" (string-ref fmt (+ i 3)))])]
|
||||
[else
|
||||
(error "unexpected after : or @" (string-ref fmt (+ i 2)))])]
|
||||
[(#\{)
|
||||
(define lst (car args))
|
||||
(cond
|
||||
[(null? lst)
|
||||
(let eloop ([i (+ i 2)])
|
||||
(cond
|
||||
[(and (char=? #\~ (string-ref fmt i))
|
||||
(char=? #\} (string-ref fmt (add1 i))))
|
||||
(loop (+ i 2) (cdr args) mode)]
|
||||
[else (eloop (add1 i))]))]
|
||||
[else
|
||||
(define-values (next-i rest-args)
|
||||
(for/fold ([next-i (+ i 2)] [args (append lst (cdr args))]) ([x (in-list lst)])
|
||||
(loop (+ i 2) args mode)))
|
||||
(loop next-i rest-args mode)])]
|
||||
[(#\} #\] #\))
|
||||
;; assume we're in a loop via `~{` or `~[` or `~(`
|
||||
(values (+ i 2) args)]
|
||||
[(#\?)
|
||||
(do-printf o (car args) (cadr args))
|
||||
(loop (+ i 2) (cddr args) mode)]
|
||||
[(#\%)
|
||||
(newline o)
|
||||
(loop (+ i 2) args mode)]
|
||||
[(#\^)
|
||||
(if (null? args)
|
||||
(let eloop ([i (+ i 2)])
|
||||
(cond
|
||||
[(= i (string-length fmt))
|
||||
(values i args)]
|
||||
[(and (char=? #\~ (string-ref fmt i))
|
||||
(char=? #\} (string-ref fmt (add1 i))))
|
||||
(values (+ i 2) args)]
|
||||
[else (eloop (add1 i))]))
|
||||
(loop (+ i 2) args mode))]
|
||||
[else
|
||||
(error "unexpected" fmt)])]
|
||||
[else
|
||||
(write-char (string-ref fmt i) o)
|
||||
(loop (add1 i) args mode)]))]))
|
||||
64
rktboot/gensym.rkt
Normal file
64
rktboot/gensym.rkt
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
#lang racket/base
|
||||
(require (only-in racket/base
|
||||
[gensym r:gensym]))
|
||||
|
||||
;; Represent a gensym as a symbol of the form |{....}| where the
|
||||
;; "pretty name" must not contain spaces.
|
||||
|
||||
(provide print-gensym
|
||||
gensym
|
||||
$intern3
|
||||
gensym?
|
||||
gensym->unique-string
|
||||
gensym->pretty-string
|
||||
hash-curly
|
||||
uninterned-symbol?)
|
||||
|
||||
(define print-gensym (make-parameter #t))
|
||||
|
||||
(define gensym
|
||||
(case-lambda
|
||||
[() (gensym (r:gensym))]
|
||||
[(pretty-name)
|
||||
(gensym pretty-name (r:gensym "unique"))]
|
||||
[(pretty-name unique-name)
|
||||
(string->symbol
|
||||
(format "{~a ~a}" pretty-name unique-name))]))
|
||||
|
||||
(define ($intern3 gstring pretty-len full-len)
|
||||
(gensym (substring gstring 0 pretty-len) gstring))
|
||||
|
||||
(define (gensym? s)
|
||||
(and (symbol? s)
|
||||
(let ([str (symbol->string s)])
|
||||
(define len (string-length str))
|
||||
(and (positive? len)
|
||||
(char=? #\{ (string-ref str 0))
|
||||
(char=? #\} (string-ref str (sub1 len)))))))
|
||||
|
||||
(define (gensym->unique-string s)
|
||||
(cadr (regexp-match #rx"^{[^ ]* (.*)}$" (symbol->string s))))
|
||||
|
||||
(define (gensym->pretty-string s)
|
||||
(cadr (regexp-match #rx"^{([^ ]*) .*}$" (symbol->string s))))
|
||||
|
||||
(define (hash-curly c in src line col pos)
|
||||
(define sym
|
||||
(string->symbol
|
||||
(list->string
|
||||
(cons
|
||||
#\{
|
||||
(let loop ()
|
||||
(define ch (read-char in))
|
||||
(if (eqv? ch #\})
|
||||
'(#\})
|
||||
(cons ch (loop))))))))
|
||||
(when (regexp-match? #rx"[|]" (symbol->string sym))
|
||||
(error "here"))
|
||||
sym)
|
||||
|
||||
(define (uninterned-symbol? v)
|
||||
(and (symbol? v)
|
||||
(not (or (symbol-interned? v)
|
||||
(symbol-unreadable? v)))))
|
||||
|
||||
29
rktboot/hand-coded.rkt
Normal file
29
rktboot/hand-coded.rkt
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide $hand-coded)
|
||||
|
||||
(define ($hand-coded sym)
|
||||
(case sym
|
||||
[($install-library-entry-procedure)
|
||||
(lambda (key val)
|
||||
(hash-set! library-entries key val))]
|
||||
[($foreign-entry-procedure) void]
|
||||
[(callcc call1cc) call/cc]
|
||||
[(scan-remembered-set
|
||||
get-room
|
||||
call-error
|
||||
dooverflood
|
||||
dooverflow
|
||||
dorest0 dorest1 dorest2 dorest3 dorest4 dorest5 doargerr
|
||||
dounderflow nuate reify-cc
|
||||
dofargint32 dofretint32 dofretuns32 dofargint64 dofretint64
|
||||
dofretuns64 dofretu8* dofretu16* dofretu32* domvleterr
|
||||
values-error $shift-attachment)
|
||||
void]
|
||||
[(bytevector=?) equal?]
|
||||
[($wrapper-apply wrapper-apply arity-wrapper-apply) void]
|
||||
[(nonprocedure-code) (lambda args (error "not a procedure"))]
|
||||
[else
|
||||
(error '$hand-coded "missing ~s" sym)]))
|
||||
|
||||
(define library-entries (make-hasheqv))
|
||||
16
rktboot/immediate.rkt
Normal file
16
rktboot/immediate.rkt
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
#lang racket/base
|
||||
|
||||
(define-syntax-rule (immediate name name?)
|
||||
(begin
|
||||
(provide (rename-out [value name])
|
||||
name?)
|
||||
|
||||
;; mutable preserves `eq?` in datum->syntax->datum conversion
|
||||
(struct name ([v #:mutable]) #:prefab)
|
||||
|
||||
(define value (name #f))))
|
||||
|
||||
(immediate base-rtd base-rtd?)
|
||||
(immediate bwp bwp?)
|
||||
(immediate black-hole black-hole?)
|
||||
(immediate $unbound-object $unbound-object?)
|
||||
10
rktboot/info.rkt
Normal file
10
rktboot/info.rkt
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#lang info
|
||||
|
||||
(define collection "cs-bootstrap")
|
||||
(define pkg-name "cs-bootstrap") ; for `create-dirs-catalog`
|
||||
|
||||
(define deps '("base"))
|
||||
|
||||
(define pkg-desc "Creates Chez Scheme boot files from source")
|
||||
|
||||
(define pkg-authors '(mflatt))
|
||||
29
rktboot/main.rkt
Normal file
29
rktboot/main.rkt
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
racket/runtime-path)
|
||||
|
||||
;; Wrapper around "make-boot.rkt" to make it work in a more normal way
|
||||
;; with command-line arguments, instead of environment variables.
|
||||
|
||||
(define scheme-src #f)
|
||||
(define mach #f)
|
||||
|
||||
(command-line
|
||||
#:once-each
|
||||
[("--scheme-src") dir "Select the directory (defaults to current directory)"
|
||||
(set! scheme-src dir)]
|
||||
[("--machine") machine "Select the machine type (defaults to inferred)"
|
||||
(set! mach machine)])
|
||||
|
||||
(unless scheme-src
|
||||
(printf "Assuming current directory has Chez Scheme sources\n")
|
||||
(flush-output))
|
||||
|
||||
(void (putenv "SCHEME_SRC" (or scheme-src ".")))
|
||||
(when mach
|
||||
(void (putenv "MACH" mach)))
|
||||
|
||||
;; Dynamic, so that environment variables are visible to
|
||||
;; compile-time instantiation of `make-boot`:
|
||||
(define-runtime-path make-boot "make-boot.rkt")
|
||||
(dynamic-require make-boot #f)
|
||||
435
rktboot/make-boot.rkt
Normal file
435
rktboot/make-boot.rkt
Normal file
|
|
@ -0,0 +1,435 @@
|
|||
#lang racket/base
|
||||
(require racket/runtime-path
|
||||
racket/match
|
||||
racket/file
|
||||
racket/pretty
|
||||
(only-in "r6rs-lang.rkt"
|
||||
optimize-level)
|
||||
(only-in "scheme-lang.rkt"
|
||||
current-expand
|
||||
with-source-path)
|
||||
(submod "scheme-lang.rkt" callback)
|
||||
"syntax-mode.rkt"
|
||||
"r6rs-readtable.rkt"
|
||||
"scheme-readtable.rkt"
|
||||
"parse-makefile.rkt"
|
||||
"config.rkt"
|
||||
"strip.rkt")
|
||||
|
||||
;; Set `SCHEME_SRC` and `MACH` to specify the ChezScheme source
|
||||
;; directory and the target machine. Set the `MAKE_BOOT_FOR_CROSS`
|
||||
;; environment variable to generate just enough to run `configure`
|
||||
;; for a corss build.
|
||||
|
||||
(unless scheme-dir
|
||||
(error "set `SCHEME_SRC` environment variable"))
|
||||
(unless target-machine
|
||||
(error "set `MACH` environment variable"))
|
||||
|
||||
;; Writes ".boot" and ".h" files to a "boot" subdirectory of
|
||||
;; `SCHEME_SRC`.
|
||||
|
||||
(define-runtime-path here-dir ".")
|
||||
(define out-subdir (build-path scheme-dir "boot" target-machine))
|
||||
(define nano-dir (build-path scheme-dir "nanopass"))
|
||||
|
||||
(define (status msg)
|
||||
(printf "~a\n" msg)
|
||||
(flush-output))
|
||||
|
||||
(define sources-date
|
||||
(for/fold ([d 0]) ([dir (in-list (list here-dir
|
||||
nano-dir
|
||||
(build-path scheme-dir "s")))])
|
||||
(status (format "Use ~a" dir))
|
||||
(for/fold ([d d]) ([f (in-list (directory-list dir))]
|
||||
#:when (regexp-match? #rx"[.](?:rkt|ss|sls)$" f))
|
||||
(max d (file-or-directory-modify-seconds (build-path dir f))))))
|
||||
|
||||
(status (format "Check ~a" out-subdir))
|
||||
(when (for/and ([f (in-list (list "scheme.h"
|
||||
"equates.h"
|
||||
"petite.boot"
|
||||
"scheme.boot"))])
|
||||
(define d (file-or-directory-modify-seconds (build-path out-subdir f) #f (lambda () #f)))
|
||||
(and d (d . >= . sources-date)))
|
||||
(status "Up-to-date")
|
||||
(exit))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-runtime-module-path r6rs-lang-mod "r6rs-lang.rkt")
|
||||
(define-runtime-module-path scheme-lang-mod "scheme-lang.rkt")
|
||||
|
||||
(define-values (petite-sources scheme-sources)
|
||||
(get-sources-from-makefile scheme-dir))
|
||||
|
||||
(define ns (make-base-empty-namespace))
|
||||
(namespace-attach-module (current-namespace) r6rs-lang-mod ns)
|
||||
(namespace-attach-module (current-namespace) scheme-lang-mod ns)
|
||||
|
||||
(namespace-require r6rs-lang-mod ns) ; get `library`
|
||||
|
||||
;; Change some bindings from imported to top-level references so that
|
||||
;; expressions are compiled to reference variables that are updated by
|
||||
;; loading the Chez Scheme compiler. This approach is better than
|
||||
;; using `namespace-require/copy`, because we want most primitives to
|
||||
;; be referenced directly to make the compiler run faster.
|
||||
(define (reset-toplevels [more '()])
|
||||
(for-each (lambda (sym)
|
||||
(eval `(define ,sym ,sym) ns))
|
||||
(append
|
||||
more
|
||||
'(identifier?
|
||||
datum->syntax
|
||||
syntax->list
|
||||
syntax->datum
|
||||
generate-temporaries
|
||||
free-identifier=?
|
||||
bound-identifier=?
|
||||
make-compile-time-value
|
||||
current-eval
|
||||
eval
|
||||
expand
|
||||
compile
|
||||
error
|
||||
format))))
|
||||
|
||||
(reset-toplevels)
|
||||
|
||||
(status "Load nanopass")
|
||||
(define (load-nanopass)
|
||||
(load/cd (build-path nano-dir "nanopass/helpers.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/syntaxconvert.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/records.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/meta-syntax-dispatch.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/meta-parser.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/pass.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/language-node-counter.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/unparser.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/language-helpers.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/language.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/nano-syntax-dispatch.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass/parser.ss"))
|
||||
(load/cd (build-path nano-dir "nanopass.ss")))
|
||||
(parameterize ([current-namespace ns]
|
||||
[current-readtable r6rs-readtable])
|
||||
(load/cd (build-path nano-dir "nanopass/implementation-helpers.ikarus.ss"))
|
||||
(load-nanopass))
|
||||
|
||||
(namespace-require ''nanopass ns)
|
||||
|
||||
(namespace-require scheme-lang-mod ns)
|
||||
|
||||
(reset-toplevels '(run-cp0
|
||||
errorf
|
||||
$oops
|
||||
$undefined-violation
|
||||
generate-interrupt-trap))
|
||||
|
||||
(namespace-require `(for-syntax ,r6rs-lang-mod) ns)
|
||||
(namespace-require `(for-syntax ,scheme-lang-mod) ns)
|
||||
(namespace-require `(for-meta 2 ,r6rs-lang-mod) ns)
|
||||
(namespace-require `(for-meta 2 ,scheme-lang-mod) ns)
|
||||
|
||||
(namespace-require `(only (submod (file ,(path->string (resolved-module-path-name r6rs-lang-mod))) ikarus) with-implicit)
|
||||
ns)
|
||||
|
||||
(define show? #f)
|
||||
(define orig-eval (let ([e (current-eval)])
|
||||
(lambda args
|
||||
(when show? (pretty-write args))
|
||||
(apply e args))))
|
||||
|
||||
(define (call-with-expressions path proc)
|
||||
(call-with-input-file*
|
||||
path
|
||||
(lambda (i)
|
||||
(let loop ()
|
||||
(define e (read i))
|
||||
(unless (eof-object? e)
|
||||
(proc e)
|
||||
(loop))))))
|
||||
|
||||
(define (load-ss path)
|
||||
(define-values (base name dir) (split-path (path->complete-path path)))
|
||||
(parameterize ([current-directory base])
|
||||
(call-with-expressions path eval)))
|
||||
|
||||
(parameterize ([current-namespace ns]
|
||||
[current-readtable scheme-readtable]
|
||||
[compile-allow-set!-undefined #t]
|
||||
[current-eval (current-eval)])
|
||||
|
||||
(status "Load cmacro parts")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/cmacros.ss")
|
||||
(lambda (e)
|
||||
(define (define-macro? m)
|
||||
(memq m '(define-syntactic-monad define-flags set-flags)))
|
||||
(define (define-for-syntax? m)
|
||||
(memq m '(lookup-constant flag->mask)))
|
||||
(match e
|
||||
[`(define-syntax ,m . ,_)
|
||||
(when (define-macro? m)
|
||||
(orig-eval e))]
|
||||
[`(eval-when ,_ (define ,m . ,rhs))
|
||||
(when (define-for-syntax? m)
|
||||
(orig-eval `(begin-for-syntax (define ,m . ,rhs))))]
|
||||
[`(define-flags . ,_)
|
||||
(orig-eval e)]
|
||||
[_ (void)])))
|
||||
|
||||
(set-current-expand-set-callback!
|
||||
(lambda ()
|
||||
(start-fully-unwrapping-syntax!)
|
||||
(define $uncprep (orig-eval '$uncprep))
|
||||
(current-eval
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[("noexpand" form)
|
||||
(orig-eval (strip-$app (strip-$primitive ($uncprep (syntax-e #'form)))))]
|
||||
[_
|
||||
(orig-eval stx)])))
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/syntax.ss")
|
||||
(lambda (e)
|
||||
(let loop ([e e])
|
||||
(cond
|
||||
[(and (pair? e)
|
||||
(eq? 'define-syntax (car e)))
|
||||
((current-expand) `(define-syntax ,(cadr e)
|
||||
',(orig-eval (caddr e))))]
|
||||
[(and (pair? e)
|
||||
(eq? 'begin (car e)))
|
||||
(for-each loop (cdr e))]))))
|
||||
(status "Install evaluator")
|
||||
(current-eval
|
||||
(let ([e (current-eval)])
|
||||
(lambda (stx)
|
||||
(define (go ex)
|
||||
(define r (strip-$app
|
||||
(strip-$primitive
|
||||
(if (struct? ex)
|
||||
($uncprep ex)
|
||||
ex))))
|
||||
(e r))
|
||||
(let loop ([stx stx])
|
||||
(syntax-case* stx (#%top-interaction
|
||||
eval-when compile
|
||||
begin
|
||||
include) (lambda (a b)
|
||||
(eq? (syntax-e a) (syntax-e b)))
|
||||
[(#%top-interaction . rest) (loop #'rest)]
|
||||
[(eval-when (compile) . rest)
|
||||
#'(eval-when (compile eval load) . rest)]
|
||||
[(begin e ...)
|
||||
(for-each loop (syntax->list #'(e ...)))]
|
||||
[(include fn)
|
||||
(loop
|
||||
#`(begin #,@(with-source-path 'include (syntax->datum #'fn)
|
||||
(lambda (n)
|
||||
(call-with-input-file*
|
||||
n
|
||||
(lambda (i)
|
||||
(let loop ()
|
||||
(define r (read-syntax n i))
|
||||
(if (eof-object? r)
|
||||
'()
|
||||
(cons r (loop))))))))))]
|
||||
[_ (go ((current-expand) (syntax->datum stx)))])))))
|
||||
(status "Load cmacros using expander")
|
||||
(load-ss (build-path scheme-dir "s/cmacros.ss"))
|
||||
(status "Continue loading expander")))
|
||||
|
||||
(status "Load enum")
|
||||
(load-ss (build-path scheme-dir "s/enum.ss"))
|
||||
(eval '(define $annotation-options (make-enumeration '(debug profile))))
|
||||
(eval '(define $make-annotation-options (enum-set-constructor $annotation-options)))
|
||||
(eval
|
||||
'(define-syntax-rule (library-requirements-options id ...)
|
||||
(with-syntax ([members ($enum-set-members ($make-library-requirements-options (datum (id ...))))])
|
||||
#'($record (record-rtd $library-requirements-options) members))))
|
||||
|
||||
(status "Load cprep")
|
||||
(load-ss (build-path scheme-dir "s/cprep.ss"))
|
||||
|
||||
(status "Load expander")
|
||||
(load-ss (build-path scheme-dir "s/syntax.ss"))
|
||||
|
||||
(status "Initialize system libraries")
|
||||
(define (init-libraries)
|
||||
(eval '($make-base-modules))
|
||||
(eval '($make-rnrs-libraries))
|
||||
(eval '(library-search-handler (lambda args (values #f #f #f))))
|
||||
(eval '(define-syntax guard
|
||||
(syntax-rules (else)
|
||||
[(_ (var clause ... [else e1 e2 ...]) b1 b2 ...)
|
||||
($guard #f (lambda (var) (cond clause ... [else e1 e2 ...]))
|
||||
(lambda () b1 b2 ...))]
|
||||
[(_ (var clause1 clause2 ...) b1 b2 ...)
|
||||
($guard #t (lambda (var p) (cond clause1 clause2 ... [else (p)]))
|
||||
(lambda () b1 b2 ...))]))))
|
||||
(init-libraries)
|
||||
|
||||
(status "Load nanopass using expander")
|
||||
(load-ss (build-path nano-dir "nanopass/implementation-helpers.chezscheme.sls"))
|
||||
(load-nanopass)
|
||||
|
||||
(status "Load priminfo and primvars")
|
||||
(load-ss (build-path scheme-dir "s/priminfo.ss"))
|
||||
(load-ss (build-path scheme-dir "s/primvars.ss"))
|
||||
|
||||
(status "Load expander using expander")
|
||||
(set-current-expand-set-callback! void)
|
||||
(load-ss (build-path scheme-dir "s/syntax.ss"))
|
||||
|
||||
(status "Initialize system libraries in bootstrapped expander")
|
||||
(init-libraries)
|
||||
|
||||
(status "Declare nanopass in bootstrapped expander")
|
||||
(load-ss (build-path nano-dir "nanopass/implementation-helpers.chezscheme.sls"))
|
||||
(load-nanopass)
|
||||
|
||||
(status "Load some io.ss declarations")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/io.ss")
|
||||
(lambda (e)
|
||||
(define (want-syntax? id)
|
||||
(memq id '(file-options-list eol-style-list error-handling-mode-list)))
|
||||
(define (want-val? id)
|
||||
(memq id '($file-options $make-file-options $eol-style? buffer-mode? $error-handling-mode?)))
|
||||
(let loop ([e e])
|
||||
(match e
|
||||
[`(let () ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(begin ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(define-syntax ,id . ,_)
|
||||
(when (want-syntax? id)
|
||||
(eval e))]
|
||||
[`(set-who! ,id . ,_)
|
||||
(when (want-val? id)
|
||||
(eval e))]
|
||||
[_ (void)]))))
|
||||
|
||||
(status "Load some strip.ss declarations")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/strip.ss")
|
||||
(lambda (e)
|
||||
(let loop ([e e])
|
||||
(match e
|
||||
[`(let () ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(begin ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(set-who! $fasl-strip-options . ,_)
|
||||
(eval e)]
|
||||
[`(set-who! $make-fasl-strip-options . ,_)
|
||||
(eval e)]
|
||||
[_ (void)]))))
|
||||
|
||||
(status "Load some 7.ss declarations")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/7.ss")
|
||||
(lambda (e)
|
||||
(let loop ([e e])
|
||||
(match e
|
||||
[`(let () ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(begin ,es ...)
|
||||
(for-each loop es)]
|
||||
[`(define $format-scheme-version . ,_)
|
||||
(eval e)]
|
||||
[`(define ($compiled-file-header? . ,_) . ,_)
|
||||
(eval e)]
|
||||
[_ (void)]))))
|
||||
|
||||
(status "Load most front.ss declarations")
|
||||
(call-with-expressions
|
||||
(build-path scheme-dir "s/front.ss")
|
||||
(lambda (e)
|
||||
;; Skip `package-stubs`, which would undo "syntax.ss" definitions
|
||||
(let loop ([e e])
|
||||
(match e
|
||||
[`(package-stubs . ,_) (void)]
|
||||
[`(define-who make-parameter . ,_) (void)]
|
||||
[`(begin . ,es) (for-each loop es)]
|
||||
[_ (eval e)]))))
|
||||
((orig-eval 'current-eval) eval)
|
||||
((orig-eval 'current-expand) (current-expand))
|
||||
((orig-eval 'enable-type-recovery) #f)
|
||||
|
||||
(status "Define $filter-foreign-type")
|
||||
(eval `(define $filter-foreign-type
|
||||
(lambda (ty)
|
||||
(filter-foreign-type ty))))
|
||||
|
||||
(make-directory* out-subdir)
|
||||
|
||||
(status "Load mkheader")
|
||||
(load-ss (build-path scheme-dir "s/mkheader.ss"))
|
||||
(status "Generate headers")
|
||||
(eval `(mkscheme.h ,(path->string (build-path out-subdir "scheme.h")) ,target-machine))
|
||||
(eval `(mkequates.h ,(path->string (build-path out-subdir "equates.h"))))
|
||||
(plumber-flush-all (current-plumber))
|
||||
|
||||
(let ([mkgc.ss (build-path scheme-dir "s/mkgc.ss")])
|
||||
(when (file-exists? mkgc.ss)
|
||||
(status "Load mkgc")
|
||||
(load-ss (build-path scheme-dir "s/mkgc.ss"))
|
||||
(status "Generate GC")
|
||||
(eval `(mkgc-ocd.inc ,(path->string (build-path out-subdir "gc-ocd.inc"))))
|
||||
(eval `(mkgc-oce.inc ,(path->string (build-path out-subdir "gc-oce.inc"))))
|
||||
(eval `(mkvfasl.inc ,(path->string (build-path out-subdir "vfasl.inc"))))
|
||||
(plumber-flush-all (current-plumber))))
|
||||
|
||||
(when (getenv "MAKE_BOOT_FOR_CROSS")
|
||||
;; Working bootfiles are not needed for a cross build (only the
|
||||
;; ".h" files are needed), so just make dummy files in that case
|
||||
;; to let `configure` work
|
||||
(define (touch p)
|
||||
(unless (file-exists? p) (call-with-output-file* p void)))
|
||||
(touch (build-path out-subdir "petite.boot"))
|
||||
(touch (build-path out-subdir "scheme.boot"))
|
||||
(exit))
|
||||
|
||||
(for ([s (in-list '("ftype.ss"
|
||||
"fasl.ss"
|
||||
"reloc.ss"
|
||||
"format.ss"
|
||||
"cp0.ss"
|
||||
"cpvalid.ss"
|
||||
"cpcheck.ss"
|
||||
"cpletrec.ss"
|
||||
"cpcommonize.ss"
|
||||
"cpnanopass.ss"
|
||||
"compile.ss"
|
||||
"back.ss"))])
|
||||
(status (format "Load ~a" s))
|
||||
(load-ss (build-path scheme-dir "s" s)))
|
||||
|
||||
((orig-eval 'fasl-compressed) #f)
|
||||
|
||||
(let ([failed? #f])
|
||||
(for ([src (append petite-sources scheme-sources)])
|
||||
(let ([dest (path->string (path->complete-path (build-path out-subdir (path-replace-suffix src #".so"))))])
|
||||
(parameterize ([current-directory (build-path scheme-dir "s")])
|
||||
;; (status (format "Compile ~a" src)) - Chez Scheme prints its own message
|
||||
(with-handlers (#;[exn:fail? (lambda (exn)
|
||||
(eprintf "ERROR: ~s\n" (exn-message exn))
|
||||
(set! failed? #t))])
|
||||
(time ((orig-eval 'compile-file) src dest))))))
|
||||
(when failed?
|
||||
(raise-user-error 'make-boot "compilation failure(s)")))
|
||||
|
||||
(let ([src->so (lambda (src)
|
||||
(path->string (build-path out-subdir (path-replace-suffix src #".so"))))])
|
||||
(status (format "Writing ~a/petite.boot" target-machine))
|
||||
(eval `($make-boot-file ,(path->string (build-path out-subdir "petite.boot"))
|
||||
',(string->symbol target-machine) '()
|
||||
,@(map src->so petite-sources)))
|
||||
(status (format "Writing ~a/scheme.boot" target-machine))
|
||||
(eval `($make-boot-file ,(path->string (build-path out-subdir "scheme.boot"))
|
||||
',(string->symbol target-machine) '("petite")
|
||||
,@(map src->so scheme-sources)))))
|
||||
31
rktboot/nanopass-patch.rkt
Normal file
31
rktboot/nanopass-patch.rkt
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
;; To load the R6RS nanopass framework into Racket, we need to make
|
||||
;; an adjustment to the use of `datum->syntax` in `make-in-context-transformer`.
|
||||
;; This same adjustment appears in the Racket version of nanopass.
|
||||
|
||||
(provide patch:define)
|
||||
|
||||
(define-syntax (patch:define stx)
|
||||
(syntax-case stx (make-in-context-transformer lambda x quote)
|
||||
[(...
|
||||
(_ id
|
||||
(lambda args
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ . pat-rest)
|
||||
(with-syntax ([qq (datum->syntax _ 'quasiquote)])
|
||||
body)])))))
|
||||
(free-identifier=? #'id #'make-in-context-transformer)
|
||||
(begin
|
||||
(printf "Apply nanopass patch\n")
|
||||
#'(...
|
||||
(define id
|
||||
(lambda args
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(me . pat-rest)
|
||||
(with-syntax ([qq (datum->syntax #'me 'quasiquote)])
|
||||
body)]))))))]
|
||||
[(_ . rest) #'(define . rest)]))
|
||||
17
rktboot/parse-makefile.rkt
Normal file
17
rktboot/parse-makefile.rkt
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
#lang racket/base
|
||||
(require racket/string)
|
||||
|
||||
(provide get-sources-from-makefile)
|
||||
|
||||
(define (get-sources-from-makefile scheme-dir)
|
||||
(call-with-input-file*
|
||||
(build-path scheme-dir "s" "Mf-base")
|
||||
#:mode 'text
|
||||
(lambda (i)
|
||||
(define (extract-files m)
|
||||
(string-split (regexp-replace* #rx"\\\\" (bytes->string/utf-8 (cadr m)) "")))
|
||||
(define bases (extract-files (regexp-match #rx"basesrc =((?:[^\\\n]*\\\\\n)*[^\\\n]*)\n" i)))
|
||||
(define compilers (extract-files (regexp-match #rx"compilersrc =((?:[^\\\n]*\\\\\n)*[^\\\n]*)\n" i)))
|
||||
(values bases compilers))))
|
||||
|
||||
|
||||
108
rktboot/primdata.rkt
Normal file
108
rktboot/primdata.rkt
Normal file
|
|
@ -0,0 +1,108 @@
|
|||
#lang racket/base
|
||||
(require racket/match
|
||||
"scheme-struct.rkt"
|
||||
"scheme-readtable.rkt"
|
||||
"symbol.rkt")
|
||||
|
||||
(provide get-primdata
|
||||
(struct-out priminfo))
|
||||
|
||||
(struct priminfo (unprefixed libraries mask signatures arity))
|
||||
|
||||
;; Returns flags->bits for prim flags, `primvec` function, and `get-priminfo` function
|
||||
(define (get-primdata $sputprop scheme-dir)
|
||||
(define flags->bits
|
||||
(cond
|
||||
[scheme-dir
|
||||
(call-with-input-file*
|
||||
(build-path scheme-dir "s/cmacros.ss")
|
||||
(lambda (i)
|
||||
(let loop ()
|
||||
(define l (parameterize ([current-readtable scheme-readtable])
|
||||
(read i)))
|
||||
(match l
|
||||
[`(define-flags prim-mask ,specs ...)
|
||||
(define bits
|
||||
(for/fold ([bits #hasheq()]) ([spec (in-list specs)])
|
||||
(define (get-val v)
|
||||
(if (number? v) v (hash-ref bits v)))
|
||||
(match spec
|
||||
[`(,name (or ,vals ...))
|
||||
(hash-set bits name (apply bitwise-ior (map get-val vals)))]
|
||||
[`(,name ,val)
|
||||
(hash-set bits name (get-val val))])))
|
||||
(lambda (flags)
|
||||
(apply bitwise-ior (for/list ([flag (in-list flags)])
|
||||
(hash-ref bits flag))))]
|
||||
[_ (loop)]))))]
|
||||
[else #hasheq()]))
|
||||
(define primref-variant
|
||||
(call-with-input-file*
|
||||
(build-path scheme-dir "s/primref.ss")
|
||||
(lambda (i)
|
||||
(define decl (parameterize ([current-readtable scheme-readtable])
|
||||
(read i)))
|
||||
(match decl
|
||||
[`(define-record-type primref
|
||||
(nongenerative ,variant)
|
||||
. ,_)
|
||||
variant]
|
||||
[_
|
||||
(error "cannot parse content of s/primref.ss")]))))
|
||||
(define priminfos (make-hasheq))
|
||||
(when scheme-dir
|
||||
(call-with-input-file*
|
||||
(build-path scheme-dir "s/primdata.ss")
|
||||
(lambda (i)
|
||||
(let loop ()
|
||||
(define l (parameterize ([current-readtable #f])
|
||||
(read i)))
|
||||
(unless (eof-object? l)
|
||||
(match l
|
||||
[`(,def-sym-flags
|
||||
([libraries ,libs ...] [flags ,group-flags ...])
|
||||
,clauses ...)
|
||||
(for ([clause (in-list clauses)])
|
||||
(match clause
|
||||
[`(,id ,specs ...)
|
||||
(define-values (flags sigs)
|
||||
(for/fold ([flags group-flags] [sigs null]) ([spec (in-list specs)])
|
||||
(match spec
|
||||
[`[sig ,sigs ...] (values flags sigs )]
|
||||
[`[flags ,flags ...] (values (append flags group-flags) sigs)]
|
||||
[`[feature ,features ...] (values flags sigs)])))
|
||||
(define plain-id (if (pair? id)
|
||||
(string->symbol (format "~a~a"
|
||||
(car id)
|
||||
(cadr id)))
|
||||
id))
|
||||
(define flag-bits (flags->bits flags))
|
||||
(define interface (map sig->interface sigs))
|
||||
(define pr (case primref-variant
|
||||
[(|{primref a0xltlrcpeygsahopkplcn-3}|)
|
||||
(primref3 plain-id flag-bits interface sigs)]
|
||||
[(|{primref a0xltlrcpeygsahopkplcn-2}|)
|
||||
(primref2 plain-id flag-bits interface)]
|
||||
[else (error "unrecognized primref variant in s/primref.ss"
|
||||
primref-variant)]))
|
||||
(register-symbols plain-id)
|
||||
($sputprop plain-id '*prim2* pr)
|
||||
($sputprop plain-id '*prim3* pr)
|
||||
($sputprop plain-id '*flags* flag-bits)
|
||||
(hash-set! priminfos plain-id (priminfo (if (pair? id) (cadr id) id)
|
||||
libs
|
||||
flag-bits
|
||||
sigs
|
||||
(map sig->interface sigs)))]))])
|
||||
(loop))))))
|
||||
(values (lambda () (list->vector (hash-keys priminfos)))
|
||||
(lambda (sym) (hash-ref priminfos sym #f))))
|
||||
|
||||
(define (sig->interface sig)
|
||||
(match sig
|
||||
[`((,args ... ,'...) ,ress ...)
|
||||
(- -1 (length args))]
|
||||
[`((,args ... ,'... ,last-arg) ,ress ...)
|
||||
(- -2 (length args))]
|
||||
[`((,args ...) ,ress ...)
|
||||
(length args)]))
|
||||
813
rktboot/r6rs-lang.rkt
Normal file
813
rktboot/r6rs-lang.rkt
Normal file
|
|
@ -0,0 +1,813 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
(for-template racket/base)
|
||||
racket/fixnum
|
||||
racket/flonum
|
||||
racket/pretty
|
||||
racket/list
|
||||
racket/splicing
|
||||
racket/unsafe/ops
|
||||
"nanopass-patch.rkt"
|
||||
"gensym.rkt"
|
||||
"format.rkt"
|
||||
"syntax-mode.rkt"
|
||||
"constant.rkt"
|
||||
"config.rkt"
|
||||
"rcd.rkt"
|
||||
(only-in "record.rkt"
|
||||
do-$make-record-type
|
||||
register-rtd-name!
|
||||
register-rtd-fields!
|
||||
s:struct-type?
|
||||
record-predicate
|
||||
record-accessor
|
||||
record-mutator)
|
||||
(only-in "immediate.rkt"
|
||||
base-rtd)
|
||||
(only-in "scheme-struct.rkt"
|
||||
syntax-object syntax-object? syntax-object-e syntax-object-ctx
|
||||
rec-cons-desc rec-cons-desc? rec-cons-desc-rtd rec-cons-desc-parent-rcd rec-cons-desc-protocol
|
||||
top-ribcage))
|
||||
|
||||
(provide (except-out (all-from-out racket/base
|
||||
racket/fixnum
|
||||
racket/flonum)
|
||||
define
|
||||
syntax
|
||||
syntax-case
|
||||
syntax-rules
|
||||
with-syntax
|
||||
quasisyntax
|
||||
define-syntax
|
||||
syntax->datum
|
||||
module
|
||||
let-syntax
|
||||
letrec-syntax
|
||||
symbol->string
|
||||
format error
|
||||
if
|
||||
sort
|
||||
fixnum?
|
||||
open-output-file
|
||||
dynamic-wind)
|
||||
library import export
|
||||
(rename-out [patch:define define]
|
||||
[s:syntax syntax]
|
||||
[s:syntax-case syntax-case]
|
||||
[s:syntax-rules syntax-rules]
|
||||
[s:with-syntax with-syntax]
|
||||
[s:quasisyntax quasisyntax]
|
||||
[s:define-syntax define-syntax]
|
||||
[s:syntax->datum syntax->datum]
|
||||
[s:if if]
|
||||
[lambda trace-lambda]
|
||||
[define-syntax trace-define-syntax]
|
||||
[s:splicing-let-syntax let-syntax]
|
||||
[s:splicing-letrec-syntax letrec-syntax]
|
||||
[let trace-let]
|
||||
[define trace-define]
|
||||
[s:dynamic-wind dynamic-wind])
|
||||
guard
|
||||
identifier-syntax
|
||||
(for-syntax datum)
|
||||
assert
|
||||
(rename-out [zero? fxzero?])
|
||||
gensym gensym? gensym->unique-string
|
||||
(rename-out [s:symbol->string symbol->string])
|
||||
pretty-print
|
||||
with-input-from-string with-output-to-string
|
||||
define-record-type
|
||||
record-type-descriptor
|
||||
make-record-type-descriptor
|
||||
make-record-type-descriptor*
|
||||
make-record-constructor-descriptor
|
||||
(rename-out [s:struct-type? record-type-descriptor?])
|
||||
record-constructor-descriptor
|
||||
record-constructor
|
||||
(rename-out [record-constructor r6rs:record-constructor])
|
||||
record-predicate
|
||||
record-accessor
|
||||
record-mutator
|
||||
record-constructor-descriptor?
|
||||
syntax-violation
|
||||
port-position
|
||||
close-port
|
||||
eof-object
|
||||
struct-name struct-ref
|
||||
make-list memp partition fold-left fold-right find remp remv
|
||||
(rename-out [andmap for-all]
|
||||
[ormap exists]
|
||||
[list* cons*]
|
||||
[s:fixnum? fixnum?]
|
||||
[fx= fx=?]
|
||||
[fx< fx<?]
|
||||
[fx> fx>?]
|
||||
[fx<= fx<=?]
|
||||
[fx>= fx>=?]
|
||||
[fxlshift fxarithmetic-shift-left]
|
||||
[fxnot fxlognot]
|
||||
[odd? fxodd?]
|
||||
[even? fxeven?]
|
||||
[div fxdiv]
|
||||
[mod fxmod]
|
||||
[div-and-mod fxdiv-and-mod]
|
||||
[integer-length fxlength]
|
||||
[exact->inexact inexact]
|
||||
[inexact->exact exact]
|
||||
[bitwise-reverse-bit-field fxreverse-bit-field]
|
||||
[bitwise-copy-bit-field fxcopy-bit-field]
|
||||
[bitwise-copy-bit fxcopy-bit]
|
||||
[make-hasheq make-eq-hashtable]
|
||||
[hash-ref/pair hashtable-ref]
|
||||
[hash-set!/pair hashtable-set!]
|
||||
[hash-set!/pair eq-hashtable-set!]
|
||||
[hash-ref-cell hashtable-cell]
|
||||
[equal-hash-code equal-hash]
|
||||
[s:format format]
|
||||
[s:error error])
|
||||
most-positive-fixnum
|
||||
most-negative-fixnum
|
||||
bitwise-copy-bit-field
|
||||
bitwise-copy-bit
|
||||
bitwise-first-bit-set
|
||||
bitwise-if
|
||||
div mod div-and-mod
|
||||
fixnum-width
|
||||
set-car!
|
||||
set-cdr!
|
||||
bytevector-copy!
|
||||
bytevector-ieee-double-native-set!
|
||||
bytevector-ieee-double-native-ref
|
||||
bytevector-u64-native-set!
|
||||
bytevector-u64-native-ref
|
||||
call-with-bytevector-output-port
|
||||
make-compile-time-value
|
||||
optimize-level)
|
||||
|
||||
(module+ ikarus
|
||||
(provide print-gensym
|
||||
annotation? annotation-source
|
||||
source-information-type
|
||||
source-information-position-line
|
||||
source-information-position-column
|
||||
source-information-source-file
|
||||
source-information-byte-offset-start
|
||||
source-information-byte-offset-end
|
||||
source-information-char-offset-start
|
||||
source-information-char-offset-end
|
||||
syntax->source-information
|
||||
(rename-out [s:module module])
|
||||
indirect-export
|
||||
(for-syntax with-implicit)))
|
||||
|
||||
(module+ hash-pair
|
||||
(provide hash-ref/pair
|
||||
hash-set!/pair
|
||||
hash-ref-cell
|
||||
s:fixnum?))
|
||||
|
||||
(begin-for-syntax
|
||||
(define here-path
|
||||
(let ([p (resolved-module-path-name
|
||||
(module-path-index-resolve
|
||||
(variable-reference->module-path-index
|
||||
(#%variable-reference))))])
|
||||
(if (path? p)
|
||||
(path->string p)
|
||||
`(quote ,p)))))
|
||||
|
||||
(define-syntax (library stx)
|
||||
(syntax-case stx (nanopass export import)
|
||||
[(library (nanopass name)
|
||||
(export out ...)
|
||||
(import in ...)
|
||||
body ...)
|
||||
(with-syntax ([here (datum->syntax #'name `(file ,here-path))])
|
||||
#'(module name here
|
||||
(require (for-syntax here)
|
||||
(except-in (for-template here) datum))
|
||||
(export out) ...
|
||||
(import in) ...
|
||||
body ...))]
|
||||
[(library (nanopass) . rest)
|
||||
(syntax-case stx ()
|
||||
[(_ (np) . _)
|
||||
#'(library (np np) . rest)])]))
|
||||
|
||||
(define-syntax-rule (export id)
|
||||
(provide id))
|
||||
|
||||
(define-syntax-rule (indirect-export . _)
|
||||
(begin))
|
||||
|
||||
(define-syntax (import stx)
|
||||
(syntax-case stx (rnrs ikarus nanopass only chezscheme)
|
||||
[(import (rnrs _ ...))
|
||||
#'(begin)]
|
||||
[(import (ikarus))
|
||||
(syntax-case stx ()
|
||||
[(_ (name))
|
||||
(with-syntax ([ref (datum->syntax #'name `(submod (file ,here-path) ikarus))])
|
||||
#`(require ref))])]
|
||||
[(import (nanopass name))
|
||||
(with-syntax ([ref (datum->syntax #'name (list 'quote #'name))])
|
||||
#`(require ref (for-syntax ref) (for-template ref)))]
|
||||
[(import (only (chezscheme) . _))
|
||||
#'(begin)]))
|
||||
|
||||
(define-syntax (s:syntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e)
|
||||
#`(unwrap-a-bit (syntax #,(mark-original #'e)))]))
|
||||
|
||||
(define-syntax (s:syntax-case stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e lits . rest)
|
||||
#'(syntax-case* (strip-outer-struct e) lits s:free-identifier=? . rest)]))
|
||||
|
||||
(define-syntax-rule (s:syntax-rules lits [a ... b] ...)
|
||||
(lambda (stx)
|
||||
(s:syntax-case stx lits
|
||||
[a ... (s:syntax b)]
|
||||
...)))
|
||||
|
||||
(define-syntax (s:with-syntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([pat e] ...) . rest)
|
||||
#'(with-syntax ([pat (strip-outer-struct e)] ...) . rest)]))
|
||||
|
||||
(define-syntax (s:quasisyntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e)
|
||||
(with-syntax ([qs #'quasisyntax])
|
||||
#`(unwrap-a-bit (qs #,(mark-original #`e))))]))
|
||||
|
||||
(define-for-syntax (mark-original e)
|
||||
(cond
|
||||
[(syntax? e)
|
||||
(define v (syntax-e e))
|
||||
(cond
|
||||
[(pair? v)
|
||||
(datum->syntax e
|
||||
(cons (mark-original (car v))
|
||||
(mark-original (cdr v)))
|
||||
e
|
||||
e)]
|
||||
[(vector? v)
|
||||
(for/vector #:length (vector-length v) ([i (in-vector v)])
|
||||
(mark-original i))]
|
||||
[(identifier? e) (syntax-property e 'original-in-syntax #t)]
|
||||
[else e])]
|
||||
[(pair? e)
|
||||
(cons (mark-original (car e))
|
||||
(mark-original (cdr e)))]
|
||||
[else e]))
|
||||
|
||||
(define (unwrap-a-bit e)
|
||||
(cond
|
||||
[fully-unwrap?
|
||||
;; Support use of `syntax-case` in expander implementation
|
||||
;; after the expander itself is expanded.
|
||||
(let loop ([e e])
|
||||
(cond
|
||||
[(syntax? e)
|
||||
(cond
|
||||
[(and (identifier? e)
|
||||
(syntax-property e 'original-in-syntax))
|
||||
(syntax-object (syntax-e e)
|
||||
(cons '(top) (list (top-ribcage '*system* #f))))]
|
||||
[else
|
||||
(define v (loop (syntax-e e)))
|
||||
(define p (syntax-property e 'save-context))
|
||||
(if p
|
||||
(syntax-object v p)
|
||||
v)])]
|
||||
[(pair? e)
|
||||
(cons (loop (car e))
|
||||
(loop (cdr e)))]
|
||||
[(vector? e)
|
||||
(for/vector #:length (vector-length e) ([i (in-vector e)])
|
||||
(loop i))]
|
||||
[else e]))]
|
||||
[else
|
||||
;; Simulate R6RS well enough
|
||||
(or (syntax->list e)
|
||||
e)]))
|
||||
|
||||
;; Also to support use of `syntax-case` in expander implementation
|
||||
;; after the expander itself is expanded:
|
||||
(define strip-outer-struct
|
||||
(let ()
|
||||
(lambda (e)
|
||||
(let loop ([e e] [w empty-wraps])
|
||||
(cond
|
||||
[(syntax-object? e)
|
||||
(define v (syntax-object-e e))
|
||||
(define new-w (join-wraps w (syntax-object-ctx e)))
|
||||
(cond
|
||||
[(pair? v)
|
||||
(cons (loop (car v) new-w)
|
||||
(loop (cdr v) new-w))]
|
||||
[(null? v) v]
|
||||
[else
|
||||
(syntax-property (datum->syntax #f v) 'save-context new-w)])]
|
||||
[(pair? e)
|
||||
(cons (loop (car e) w)
|
||||
(loop (cdr e) w))]
|
||||
[(vector? e)
|
||||
(for/vector #:length (vector-length e) ([i (in-vector e)])
|
||||
(loop i w))]
|
||||
[(box? e)
|
||||
(box (loop (unbox e) w))]
|
||||
[(symbol? e)
|
||||
(if (equal? w empty-wraps)
|
||||
e
|
||||
(syntax-property (datum->syntax #f e) 'save-context w))]
|
||||
[else e])))))
|
||||
|
||||
(define (s:free-identifier=? a b)
|
||||
(if fully-unwrap?
|
||||
(eq? (syntax-e a) (syntax-e b))
|
||||
(free-identifier=? a b)))
|
||||
|
||||
(define empty-wraps '(() . ()))
|
||||
|
||||
(define (join-wraps w1 w2)
|
||||
(define a (join (car w1) (car w2)))
|
||||
(define d (join (cdr w1) (cdr w2)))
|
||||
(cond
|
||||
[(and (eq? a (car w1))
|
||||
(eq? d (cdr w1)))
|
||||
w1]
|
||||
[(and (eq? a (car w2))
|
||||
(eq? d (cdr w2)))
|
||||
w2]
|
||||
[else (cons a d)]))
|
||||
|
||||
(define (join l1 l2)
|
||||
(cond
|
||||
[(null? l1) l2]
|
||||
[(null? l2) l1]
|
||||
[else (append l1 l2)]))
|
||||
|
||||
(define (s:syntax->datum s)
|
||||
(syntax->datum (datum->syntax #f s)))
|
||||
|
||||
(define-syntax-rule (s:define-syntax id rhs)
|
||||
(define-syntax id
|
||||
(wrap-transformer rhs)))
|
||||
|
||||
(define-syntax-rule (s:splicing-let-syntax ([id rhs] ...) body ...)
|
||||
(splicing-let-syntax ([id (wrap-transformer rhs)] ...) body ...))
|
||||
|
||||
(define-syntax-rule (s:splicing-letrec-syntax ([id rhs] ...) body ...)
|
||||
(splicing-letrec-syntax ([id (wrap-transformer rhs)] ...) body ...))
|
||||
|
||||
(define-for-syntax (wrap-transformer proc)
|
||||
(if (procedure? proc)
|
||||
(lambda (stx)
|
||||
(let loop ([result (proc stx)])
|
||||
(if (procedure? result)
|
||||
;; Chez/Ikarus protocol to get syntax-local-value:
|
||||
(loop (result syntax-local-value))
|
||||
(datum->syntax #'here result))))
|
||||
proc))
|
||||
|
||||
(define-syntax s:if
|
||||
(syntax-rules ()
|
||||
[(_ tst thn els) (if tst thn els)]
|
||||
[(_ tst thn) (if tst thn (void))]))
|
||||
|
||||
(define-syntax-rule (guard (id [tst rslt ...] ...) body ...)
|
||||
(with-handlers ([(lambda (id) (else-to-true tst)) (lambda (id) rslt ...)] ...)
|
||||
body ...))
|
||||
|
||||
(define-syntax else-to-true
|
||||
(syntax-rules (else)
|
||||
[(_ else) #t]
|
||||
[(_ e) e]))
|
||||
|
||||
(define s:dynamic-wind
|
||||
(case-lambda
|
||||
[(pre thunk post) (dynamic-wind pre thunk post)]
|
||||
[(critical? pre thunk post) (dynamic-wind pre thunk post)]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-rule (with-implicit (tid id ...) body ...)
|
||||
(with-syntax ([id (datum->syntax (syntax tid) 'id)] ...)
|
||||
body ...)))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-rule (datum e)
|
||||
(syntax->datum (syntax e))))
|
||||
|
||||
(define-syntax (identifier-syntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(identifier? #'id)
|
||||
#'(make-rename-transformer #'id)]
|
||||
[(_ e)
|
||||
#'(lambda (stx)
|
||||
(if (identifier? stx)
|
||||
#'e
|
||||
(syntax-case stx ()
|
||||
[(_ arg (... ...))
|
||||
#'(e arg (... ...))])))]))
|
||||
|
||||
(define-syntax-rule (s:module (id ...) body ...)
|
||||
(begin
|
||||
body ...))
|
||||
|
||||
(define-syntax-rule (assert e)
|
||||
(unless e
|
||||
(error 'assert "failed: ~s" 'e)))
|
||||
|
||||
(define (syntax->source-information stx) #f)
|
||||
(define (source-information-type si) #f)
|
||||
(define (source-information-position-line si) #f)
|
||||
(define (source-information-position-column si) #f)
|
||||
(define (source-information-source-file si) #f)
|
||||
(define (source-information-byte-offset-start si) #f)
|
||||
(define (source-information-byte-offset-end si) #f)
|
||||
(define (source-information-char-offset-start si) #f)
|
||||
(define (source-information-char-offset-end si) #f)
|
||||
|
||||
(define (syntax-violation . args)
|
||||
(apply error args))
|
||||
|
||||
(define (s:symbol->string s)
|
||||
(if (gensym? s)
|
||||
(gensym->pretty-string s)
|
||||
(symbol->string s)))
|
||||
|
||||
(define (with-input-from-string str proc)
|
||||
(parameterize ([current-input-port (open-input-string str)])
|
||||
(proc)))
|
||||
|
||||
(define (with-output-to-string proc)
|
||||
(define o (open-output-string))
|
||||
(parameterize ([current-output-port o])
|
||||
(proc))
|
||||
(get-output-string o))
|
||||
|
||||
(define protocols (make-hasheq))
|
||||
(define (install-protocol! rtd protocol)
|
||||
(hash-set! protocols rtd protocol))
|
||||
(define (lookup-protocol rtd)
|
||||
(hash-ref protocols rtd))
|
||||
|
||||
(define-syntax (define-record-type stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name make-name name?) clause ...)
|
||||
(let loop ([clauses #'(clause ...)] [fs #'()] [p #f] [super #f] [uid #f] [o? #f] [s? #f])
|
||||
(syntax-case clauses (nongenerative sealed fields protocol parent opaque sealed)
|
||||
[((nongenerative uid) clause ...)
|
||||
(loop #'(clause ...) fs p super #'uid o? s?)]
|
||||
[((nongenerative . _) clause ...)
|
||||
(loop #'(clause ...) fs p super uid o? s?)]
|
||||
[((sealed _) clause ...)
|
||||
(loop #'(clause ...) fs p super uid o? s?)]
|
||||
[((fields field ...) clause ...)
|
||||
(loop #'(clause ...) #'(field ...) p super uid o? s?)]
|
||||
[((protocol proc) clause ...)
|
||||
(loop #'(clause ...) fs #'proc super uid o? s?)]
|
||||
[((parent super) clause ...)
|
||||
(loop #'(clause ...) fs p #'super uid o? s?)]
|
||||
[((opaque #t) clause ...)
|
||||
(loop #'(clause ...) fs p super uid #t s?)]
|
||||
[((sealed #t) clause ...)
|
||||
(loop #'(clause ...) fs p super uid o? #t)]
|
||||
[()
|
||||
(let ()
|
||||
(define (format-id ctx fmt . args)
|
||||
(datum->syntax ctx (string->symbol
|
||||
(apply format fmt (map syntax-e args)))))
|
||||
(define (normalize-fields l)
|
||||
(for/list ([f (in-list (syntax->list l))])
|
||||
(syntax-case f (mutable immutable)
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(list #'id (format-id #'id "~a-~a" #'name #'id))]
|
||||
[(mutable id)
|
||||
(list #'id
|
||||
(format-id #'id "~a-~a" #'name #'id)
|
||||
(format-id #'id "~a-~a-set!" #'name #'id))]
|
||||
[(immutable id)
|
||||
(list #'id (format-id #'id "~a-~a" #'name #'id))]
|
||||
[(mutable id ref set)
|
||||
(list #'id #'ref #'set)]
|
||||
[(immutable id ref)
|
||||
(list #'id #'ref)])))
|
||||
(define all-fs (normalize-fields fs))
|
||||
(define fs-ids (for/list ([f (in-list all-fs)])
|
||||
(syntax-case f ()
|
||||
[(id . _) #'id])))
|
||||
(define parent-info (and super (syntax-local-value super)))
|
||||
(with-syntax ([num-fields (length all-fs)]
|
||||
[protocol (or p
|
||||
(if super
|
||||
#`(lambda (parent-maker)
|
||||
(lambda (#,@(list-ref parent-info 3) #,@fs-ids)
|
||||
((parent-maker #,@(list-ref parent-info 3)) #,@fs-ids)))
|
||||
#'(lambda (p) p)))]
|
||||
[maker (if super
|
||||
#`(let ([parent-protocol (lookup-protocol #,(car parent-info))])
|
||||
(lambda args
|
||||
(apply (parent-protocol
|
||||
(lambda #,(list-ref parent-info 3)
|
||||
(lambda #,fs-ids
|
||||
(create-name #,@(list-ref parent-info 3) #,@fs-ids))))
|
||||
args)))
|
||||
#'create-name)]
|
||||
[(getter ...)
|
||||
(for/list ([f (in-list all-fs)]
|
||||
[pos (in-naturals)])
|
||||
(syntax-case f ()
|
||||
[(id ref . _) (list #'ref
|
||||
#`(make-struct-field-accessor name-ref #,pos 'id))]))]
|
||||
[(setter ...)
|
||||
(for/list ([f (in-list all-fs)]
|
||||
[pos (in-naturals)]
|
||||
#:when (syntax-case f ()
|
||||
[(_ _ _) #t]
|
||||
[_ #f]))
|
||||
(syntax-case f ()
|
||||
[(id _ set) (list #'set
|
||||
#`(make-struct-field-mutator name-set! #,pos 'id))]))]
|
||||
[super (if super
|
||||
(car (syntax-local-value super))
|
||||
#'#f)]
|
||||
[struct:name (format-id #'name "struct:~a" #'name)]
|
||||
[uid (or uid #'name)]
|
||||
[maybe-prefab (if uid #''prefab #'#f)]
|
||||
[fields-vec (list->vector (syntax-e fs))])
|
||||
(with-syntax ([(all-getter-id ...)
|
||||
(append (for/list ([getter (in-list (reverse (syntax->list #'(getter ...))))])
|
||||
(syntax-case getter ()
|
||||
[(id . _) #'id]))
|
||||
(if parent-info
|
||||
(list-ref parent-info 3)
|
||||
null))])
|
||||
#`(begin
|
||||
(define-syntax name
|
||||
(list (quote-syntax struct:name)
|
||||
(quote-syntax create-name)
|
||||
(quote-syntax name?)
|
||||
(list (quote-syntax all-getter-id) ...)
|
||||
#f
|
||||
#f))
|
||||
(define-values (struct:name create-name name? name-ref name-set!)
|
||||
(make-struct-type 'uid super num-fields 0 #f null maybe-prefab))
|
||||
(define name-protocol protocol)
|
||||
(install-protocol! struct:name name-protocol)
|
||||
(register-rtd-name! struct:name 'name)
|
||||
(register-rtd-fields! struct:name 'fields-vec)
|
||||
(define make-name (name-protocol maker))
|
||||
(define . getter) ...
|
||||
(define . setter) ...))))]))]
|
||||
[(_ name clause ...)
|
||||
(with-syntax ([make-name (datum->syntax #'name
|
||||
(string->symbol
|
||||
(format "make-~a" (syntax-e #'name)))
|
||||
#'name)]
|
||||
[name? (datum->syntax #'name
|
||||
(string->symbol
|
||||
(format "~a?" (syntax-e #'name)))
|
||||
#'name)])
|
||||
#`(define-record-type (name make-name name?) clause ...))]))
|
||||
|
||||
(define-syntax (record-type-descriptor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(car (syntax-local-value #'id))]))
|
||||
|
||||
(define-syntax (record-constructor-descriptor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
#`(rtd->rcd #,(car (syntax-local-value #'id)))]))
|
||||
|
||||
(define record-constructor-descriptor? rec-cons-desc?)
|
||||
|
||||
(define (rtd->rcd rtd)
|
||||
(rec-cons-desc rtd #f (lookup-protocol rtd)))
|
||||
|
||||
(define (record-constructor rcd)
|
||||
(cond
|
||||
[(s:struct-type? rcd)
|
||||
;; For Chez Scheme's legacy procedure
|
||||
(struct-type-make-constructor rcd)]
|
||||
[(rec-cons-desc? rcd)
|
||||
(rcd->constructor rcd lookup-protocol)]))
|
||||
|
||||
(define (make-record-type-descriptor name parent uid s? o? fields)
|
||||
(do-$make-record-type base-rtd parent name fields s? o? null #:uid uid))
|
||||
|
||||
(define (make-record-type-descriptor* name parent uid s? o? num-fields mutability-mask)
|
||||
(define fields (for ([i (in-range num-fields)])
|
||||
(list (if (bitwise-bit-set? mutability-mask i) 'mutable 'immutable)
|
||||
(string->symbol (format "f~a" i)))))
|
||||
(do-$make-record-type base-rtd parent name fields s? o? null #:uid uid))
|
||||
|
||||
(define (make-record-constructor-descriptor rtd parent-rcd protocol)
|
||||
(rec-cons-desc rtd parent-rcd protocol))
|
||||
|
||||
(define (annotation? a) #f)
|
||||
(define (annotation-source a) #f)
|
||||
|
||||
(define (port-position ip) (file-position ip))
|
||||
|
||||
(define (close-port p)
|
||||
(if (input-port? p)
|
||||
(close-input-port p)
|
||||
(close-output-port p)))
|
||||
|
||||
(define (eof-object)
|
||||
eof)
|
||||
|
||||
(define (struct-name a) (substring (symbol->string (vector-ref (struct->vector a) 0))
|
||||
;; drop "struct:"
|
||||
7))
|
||||
(define (struct-ref s i) (error 'struct-ref "oops"))
|
||||
|
||||
(define (make-list n [v #f])
|
||||
(vector->list (make-vector n v)))
|
||||
|
||||
(define (memp pred l)
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
[(pred (car l)) l]
|
||||
[else (memp pred (cdr l))]))
|
||||
|
||||
(define (remp pred l)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[(pred (car l)) (remp pred (cdr l))]
|
||||
[else (cons (car l) (remp pred (cdr l)))]))
|
||||
|
||||
(define (remv v l)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[(eqv? v (car l)) (remv v (cdr l))]
|
||||
[else (cons (car l) (remv v (cdr l)))]))
|
||||
|
||||
(define (partition proc list)
|
||||
(let loop ((list list) (yes '()) (no '()))
|
||||
(cond ((null? list)
|
||||
(values (reverse yes) (reverse no)))
|
||||
((proc (car list))
|
||||
(loop (cdr list) (cons (car list) yes) no))
|
||||
(else
|
||||
(loop (cdr list) yes (cons (car list) no))))))
|
||||
|
||||
(define (fold-left combine nil the-list . the-lists)
|
||||
(if (null? the-lists)
|
||||
(fold-left1 combine nil the-list)
|
||||
(let loop ((accum nil) (list the-list) (lists the-lists))
|
||||
(if (null? list)
|
||||
accum
|
||||
(loop (apply combine accum (car list) (map car lists))
|
||||
(cdr list)
|
||||
(map cdr lists))))))
|
||||
|
||||
(define (fold-left1 combine nil list)
|
||||
(let loop ((accum nil) (list list))
|
||||
(if (null? list)
|
||||
accum
|
||||
(loop (combine accum (car list))
|
||||
(cdr list)))))
|
||||
|
||||
(define (fold-right combine nil the-list . the-lists)
|
||||
(if (null? the-lists)
|
||||
(fold-right1 combine nil the-list)
|
||||
(let recur ((list the-list) (lists the-lists))
|
||||
(if (null? list)
|
||||
nil
|
||||
(apply combine
|
||||
(car list)
|
||||
(append (map car lists)
|
||||
(cons (recur (cdr list) (map cdr lists))
|
||||
'())))))))
|
||||
|
||||
(define (fold-right1 combine nil list)
|
||||
(let recur ((list list))
|
||||
(if (null? list)
|
||||
nil
|
||||
(combine (car list) (recur (cdr list))))))
|
||||
|
||||
(define (find proc list)
|
||||
(let loop ((list list))
|
||||
(cond
|
||||
((null? list) #f)
|
||||
((proc (car list)) (car list))
|
||||
(else (loop (cdr list))))))
|
||||
|
||||
(define (bitwise-if a b c)
|
||||
(bitwise-ior (bitwise-and a b)
|
||||
(bitwise-and (bitwise-not a) c)))
|
||||
|
||||
(define (bitwise-reverse-bit-field n start end)
|
||||
(let ([field (bitwise-bit-field n start end)]
|
||||
[width (- end start)])
|
||||
(let loop ([old field][new 0][width width])
|
||||
(cond
|
||||
[(zero? width) (bitwise-copy-bit-field n start end new)]
|
||||
[else (loop (arithmetic-shift old -1)
|
||||
(bitwise-ior (arithmetic-shift new 1)
|
||||
(bitwise-and old 1))
|
||||
(sub1 width))]))))
|
||||
|
||||
(define (bitwise-copy-bit-field to start end from)
|
||||
(let* ([mask1 (arithmetic-shift -1 start)]
|
||||
[mask2 (bitwise-not (arithmetic-shift -1 end))]
|
||||
[mask (bitwise-and mask1 mask2)])
|
||||
(bitwise-if mask
|
||||
(arithmetic-shift from start)
|
||||
to)))
|
||||
|
||||
(define (bitwise-first-bit-set b)
|
||||
(if (zero? b)
|
||||
-1
|
||||
(let loop ([b b][pos 0])
|
||||
(if (zero? (bitwise-and b 1))
|
||||
(loop (arithmetic-shift b -1) (add1 pos))
|
||||
pos))))
|
||||
|
||||
(define (bitwise-copy-bit b n bit)
|
||||
(if (eq? bit 1)
|
||||
(bitwise-ior b (arithmetic-shift 1 n))
|
||||
(bitwise-and b (bitwise-not (arithmetic-shift 1 n)))))
|
||||
|
||||
(define (div x y)
|
||||
(quotient x y))
|
||||
|
||||
(define (mod x y)
|
||||
(modulo x y))
|
||||
|
||||
(define (div-and-mod x y)
|
||||
(values (div x y) (mod x y)))
|
||||
|
||||
(define (hash-ref/pair ht key def-v)
|
||||
(cdr (hash-ref ht key (cons #f def-v))))
|
||||
|
||||
(define (hash-set!/pair ht key val)
|
||||
(hash-set! ht key (cons (and (not (hash-weak? ht)) key) val)))
|
||||
|
||||
(define (hash-ref-cell ht key def-v)
|
||||
(or (hash-ref ht key #f)
|
||||
(begin
|
||||
(hash-set!/pair ht key def-v)
|
||||
(hash-ref-cell ht key def-v))))
|
||||
|
||||
;; HACK!
|
||||
(define-syntax (define-mutable-pair-hacks stx)
|
||||
(syntax-case stx ()
|
||||
[(_ set-car! set-cdr!)
|
||||
(cond
|
||||
[(eq? 'chez-scheme (system-type 'vm))
|
||||
#'(begin
|
||||
(require racket/linklet)
|
||||
(define chez-eval (instantiate-linklet
|
||||
(compile-linklet '(linklet () () eval))
|
||||
null
|
||||
(make-instance 'scheme)))
|
||||
(define set-car! (chez-eval 'set-car!))
|
||||
(define set-cdr! (chez-eval 'set-cdr!)))]
|
||||
[else
|
||||
#'(begin
|
||||
(define (set-car! p v) (unsafe-set-mcar! p v))
|
||||
(define (set-cdr! p v) (unsafe-set-mcdr! p v)))])]))
|
||||
(define-mutable-pair-hacks set-car! set-cdr!)
|
||||
|
||||
(define (bytevector-copy! src src-start dst dst-start n)
|
||||
(bytes-copy! dst dst-start src src-start (+ src-start n)))
|
||||
|
||||
(define (bytevector-ieee-double-native-set! bv pos val)
|
||||
(real->floating-point-bytes val 8 (system-big-endian?) bv pos))
|
||||
(define (bytevector-ieee-double-native-ref bv pos)
|
||||
(floating-point-bytes->real bv (system-big-endian?) pos (+ pos 8)))
|
||||
|
||||
(define (bytevector-u64-native-set! bv pos val)
|
||||
(integer->integer-bytes val 8 #f (system-big-endian?) bv pos))
|
||||
(define (bytevector-u64-native-ref bv pos)
|
||||
(integer-bytes->integer bv #f (system-big-endian?) pos (+ pos 8)))
|
||||
|
||||
(define (call-with-bytevector-output-port proc)
|
||||
(define o (open-output-bytes))
|
||||
(proc o)
|
||||
(get-output-bytes o))
|
||||
|
||||
(define (fixnum-width) (or fixnum-bits 63))
|
||||
|
||||
(define low-fixnum (- (expt 2 (sub1 (fixnum-width)))))
|
||||
(define high-fixnum (sub1 (expt 2 (sub1 (fixnum-width)))))
|
||||
|
||||
(define (most-positive-fixnum) high-fixnum)
|
||||
(define (most-negative-fixnum) low-fixnum)
|
||||
|
||||
(define (s:fixnum? x)
|
||||
(and (fixnum? x)
|
||||
(<= low-fixnum x high-fixnum)))
|
||||
|
||||
(define (make-compile-time-value v) v)
|
||||
|
||||
(define optimize-level (make-parameter optimize-level-init))
|
||||
13
rktboot/r6rs-readtable.rkt
Normal file
13
rktboot/r6rs-readtable.rkt
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
#lang racket/base
|
||||
(require "gensym.rkt")
|
||||
|
||||
(provide r6rs-readtable)
|
||||
|
||||
(define (hash-bang c in src line col pos)
|
||||
(make-special-comment (read-syntax/recursive src in)))
|
||||
|
||||
(define r6rs-readtable
|
||||
(make-readtable
|
||||
#f
|
||||
#\! 'dispatch-macro hash-bang
|
||||
#\{ 'dispatch-macro hash-curly))
|
||||
68
rktboot/rcd.rkt
Normal file
68
rktboot/rcd.rkt
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
#lang racket/base
|
||||
(require "scheme-struct.rkt"
|
||||
(for-template racket/base))
|
||||
|
||||
(provide rcd->constructor
|
||||
(struct-out rcd-info)
|
||||
rcd->rcdi)
|
||||
|
||||
(define (rcd->constructor rcd lookup-protocol)
|
||||
(define rtd (rec-cons-desc-rtd rcd))
|
||||
(define ctr (struct-type-make-constructor rtd))
|
||||
((record-constructor-generator rcd lookup-protocol) ctr))
|
||||
|
||||
(define (record-constructor-generator rcd lookup-protocol)
|
||||
(define rtd (rec-cons-desc-rtd rcd))
|
||||
(define p (rec-cons-desc-protocol rcd))
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(cond
|
||||
[(not p) (lambda (ctr) ctr)]
|
||||
[(rec-cons-desc-parent-rcd rcd)
|
||||
=> (lambda (p-rcd)
|
||||
(define p-gen (record-constructor-generator p-rcd lookup-protocol))
|
||||
(and p-gen
|
||||
(lambda (ctr)
|
||||
(p (p-gen
|
||||
(lambda args1
|
||||
(lambda args2
|
||||
(apply ctr (append args1 args2)))))))))]
|
||||
[(and super (not lookup-protocol)) #f]
|
||||
[super
|
||||
(define parent-p (lookup-protocol super))
|
||||
(lambda (ctr)
|
||||
(p (parent-p
|
||||
(lambda args1
|
||||
(lambda args2
|
||||
(apply ctr (append args1 args2)))))))]
|
||||
[else p]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(struct rcd-info (rtd proto-expr base-rcdi init-cnt)
|
||||
#:transparent)
|
||||
|
||||
(define (rcd->rcdi rcd)
|
||||
(cond
|
||||
[(rec-cons-desc-parent-rcd rcd)
|
||||
=> (lambda (p-rcd)
|
||||
(define p-rcdi (rcd->rcdi p-rcd))
|
||||
(and p-rcdi
|
||||
(let ()
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info (rec-cons-desc-rtd rcd)))
|
||||
(define proto (rec-cons-desc-protocol rcd))
|
||||
(rcd-info (rec-cons-desc-rtd rcd)
|
||||
proto
|
||||
p-rcdi
|
||||
(+ init-cnt
|
||||
(rcd-info-init-cnt p-rcdi))))))]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info (rec-cons-desc-rtd rcd)))
|
||||
(define proto (rec-cons-desc-protocol rcd))
|
||||
(and (not super)
|
||||
(rcd-info (rec-cons-desc-rtd rcd)
|
||||
proto
|
||||
#f
|
||||
init-cnt))]))
|
||||
583
rktboot/record.rkt
Normal file
583
rktboot/record.rkt
Normal file
|
|
@ -0,0 +1,583 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/unsafe/ops
|
||||
racket/vector
|
||||
racket/list
|
||||
"immediate.rkt"
|
||||
"symbol.rkt"
|
||||
"gensym.rkt"
|
||||
"constant.rkt")
|
||||
|
||||
(provide do-$make-record-type
|
||||
register-rtd-name!
|
||||
register-rtd-fields!
|
||||
s:struct-type?
|
||||
|
||||
$make-record-type
|
||||
$make-record-type-descriptor
|
||||
$record
|
||||
make-record-type
|
||||
type-descriptor
|
||||
record-predicate
|
||||
record-accessor
|
||||
record-mutator
|
||||
compile-time-record-predicate
|
||||
compile-time-record-accessor
|
||||
compile-time-record-mutator
|
||||
csv7:record-field-accessor
|
||||
csv7:record-field-mutator
|
||||
csv7:record-field-mutable?
|
||||
record-rtd
|
||||
record?
|
||||
$record?
|
||||
record-type-uid
|
||||
record-type-name
|
||||
record-type-sealed?
|
||||
record-type-opaque?
|
||||
record-type-parent
|
||||
record-type-field-names
|
||||
record-type-field-indices
|
||||
csv7:record-type-field-names
|
||||
csv7:record-type-field-indices
|
||||
csv7:record-type-field-decls
|
||||
record-writer
|
||||
$object-ref)
|
||||
|
||||
(define (s:struct-type? v)
|
||||
(or (struct-type? v)
|
||||
(base-rtd? v)))
|
||||
|
||||
;; For rtds based on subtypes of #!base-rtd, the subtype instance
|
||||
;; that effectively extends the struct type with more fields:
|
||||
(define rtd-extensions (make-weak-hasheq))
|
||||
|
||||
;; For structure types that extend #!base-rtd:
|
||||
(struct base-rtd-subtype () #:prefab)
|
||||
|
||||
(define (subtype-of-base-rtd? rtd)
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(and super
|
||||
(or (eq? struct:base-rtd-subtype super)
|
||||
(and (subtype-of-base-rtd? super)))))
|
||||
|
||||
|
||||
(define (do-$make-record-type in-base-rtd in-super in-name fields sealed? opaque? more
|
||||
#:uid [in-uid #f])
|
||||
(define name (cond
|
||||
[(string? in-name) (string->symbol in-name)]
|
||||
[(gensym? in-name) (string->symbol (gensym->pretty-string in-name))]
|
||||
[else in-name]))
|
||||
(define uid (or in-uid
|
||||
(cond
|
||||
[(gensym? in-name) in-name]
|
||||
[else #f])))
|
||||
(define super
|
||||
(cond
|
||||
[(base-rtd? in-super) struct:base-rtd-subtype]
|
||||
[else in-super]))
|
||||
(define num-fields (if (vector? fields) (vector-length fields) (length fields)))
|
||||
(define-values (struct:name make-name name? name-ref name-values)
|
||||
(make-struct-type (or uid name) super num-fields 0 #f null (and uid 'prefab)))
|
||||
(unless (base-rtd? in-base-rtd)
|
||||
(hash-set! rtd-extensions struct:name (apply (struct-type-make-constructor in-base-rtd) more)))
|
||||
(register-rtd-name! struct:name name)
|
||||
(register-rtd-fields! struct:name fields)
|
||||
(when sealed? (hash-set! rtd-sealed?s struct:name #t))
|
||||
(when (or opaque?
|
||||
(and super (hash-ref rtd-opaque?s super #f)))
|
||||
(hash-set! rtd-opaque?s struct:name #t))
|
||||
struct:name)
|
||||
|
||||
(define ($make-record-type in-base-rtd super in-name fields sealed? opaque? . more)
|
||||
(do-$make-record-type in-base-rtd super in-name fields sealed? opaque? more))
|
||||
|
||||
(define ($make-record-type-descriptor base-rtd name parent uid sealed? opaque? fields who . extras)
|
||||
(do-$make-record-type base-rtd parent name (vector->list fields) sealed? opaque? extras #:uid uid))
|
||||
|
||||
(define ($record rtd . args)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(error "here")]
|
||||
[(subtype-of-base-rtd? rtd)
|
||||
(error "here, too" rtd args)]
|
||||
[else
|
||||
(apply (struct-type-make-constructor rtd) args)]))
|
||||
|
||||
(define make-record-type
|
||||
(case-lambda
|
||||
[(parent in-name fields)
|
||||
($make-record-type base-rtd parent in-name fields #f #f)]
|
||||
[(name fields)
|
||||
(make-record-type #f name fields)]))
|
||||
|
||||
|
||||
(define rtd-names (make-weak-hasheq))
|
||||
|
||||
(define (register-rtd-name! struct:name name)
|
||||
(hash-set! rtd-names struct:name name))
|
||||
|
||||
|
||||
(define rtd-fields (make-weak-hasheq))
|
||||
|
||||
;; Must match "cmacro.ss"
|
||||
(define (fld-name fld) (vector-ref fld 1))
|
||||
(define (fld-mutable? fld) (vector-ref fld 2))
|
||||
(define (fld-type fld) (vector-ref fld 3))
|
||||
(define (fld-byte fld) (vector-ref fld 4))
|
||||
(define (set-fld-byte! fld v) (vector-set! fld 4 v))
|
||||
(define fld-byte-value 0) ; doesn't matter; gets replaced in field vectors
|
||||
|
||||
(define (register-rtd-fields! struct:name fields)
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info struct:name))
|
||||
(hash-set! rtd-fields struct:name (append
|
||||
(cond
|
||||
[(not super) null]
|
||||
[(or (base-rtd? super)
|
||||
(eq? super struct:base-rtd-subtype))
|
||||
;; fields added in `csv7:record-field-accessor`
|
||||
null]
|
||||
[else (hash-ref rtd-fields super)])
|
||||
(normalize-fields
|
||||
(if (vector? fields)
|
||||
(for/list ([e (in-vector fields)])
|
||||
(cond
|
||||
[(symbol? e) (list 'immutable e)]
|
||||
[(pair? (cdr e)) (list (car e) (cadr e))]
|
||||
[else e]))
|
||||
fields)))))
|
||||
|
||||
(define (normalize-fields fields)
|
||||
(unless (list? fields)
|
||||
(error 'normalize-fields "not a list: ~s" fields))
|
||||
(define (check-type t)
|
||||
(case t
|
||||
[(scheme-object uptr ptr double) t]
|
||||
[else
|
||||
(error 'make-struct-type "unsupported type ~s" t)]))
|
||||
(define (is-mut? m)
|
||||
(case m
|
||||
[(mutable) #t]
|
||||
[(immutable) #f]
|
||||
[else (error 'make-struct-type "unrecognized mutability ~s" m)]))
|
||||
(for/list ([field (in-list fields)])
|
||||
(cond
|
||||
[(and (vector? field)
|
||||
(= 3 (vector-length field)))
|
||||
(vector 'fld (vector-ref field 2) (is-mut? (vector-ref field 1)) (check-type (vector-ref field 0)) fld-byte-value)]
|
||||
[(and (list? field)
|
||||
(= 3 (length field)))
|
||||
(vector 'fld (list-ref field 2) (is-mut? (list-ref field 0)) (check-type (list-ref field 1)) fld-byte-value)]
|
||||
[(symbol? field)
|
||||
(vector 'fld field #t 'scheme-object fld-byte-value)]
|
||||
[(and (list? field)
|
||||
(= 2 (length field)))
|
||||
(vector 'fld (cadr field) (is-mut? (car field)) 'scheme-object fld-byte-value)]
|
||||
[else
|
||||
(error 'normalize-fields "unrecognized field format: ~s" field)])))
|
||||
|
||||
(define-syntax (type-descriptor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(car (syntax-local-value #'id))]))
|
||||
|
||||
(define (record-predicate rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(lambda (v)
|
||||
(or (base-rtd? v)
|
||||
(base-rtd-subtype? v)))]
|
||||
[else
|
||||
(define pred (struct-type-make-predicate rtd))
|
||||
(lambda (v)
|
||||
(if (struct-type? v)
|
||||
(pred (hash-ref rtd-extensions v #f))
|
||||
(pred v)))]))
|
||||
|
||||
(define (compile-time-record-predicate rtd)
|
||||
(and (not (base-rtd-subtype-rtd? rtd))
|
||||
(struct-type-make-predicate rtd)))
|
||||
|
||||
(define (base-rtd-subtype-rtd? rtd)
|
||||
(or (eq? struct:base-rtd-subtype rtd)
|
||||
(let ()
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(if super
|
||||
(base-rtd-subtype-rtd? super)
|
||||
#f))))
|
||||
|
||||
;; `i` does not count parent fields
|
||||
(define (record-accessor rtd i [name #f])
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(error 'record-accessor "#!base-rtd not directly supported")]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(define acc (make-struct-field-accessor ref i (or name (string->symbol (number->string i)))))
|
||||
(if (subtype-of-base-rtd? rtd)
|
||||
(lambda (rtd/ext)
|
||||
(acc (if (struct-type? rtd/ext)
|
||||
(hash-ref rtd-extensions rtd/ext)
|
||||
rtd/ext)))
|
||||
acc)]))
|
||||
|
||||
(define (compile-time-record-accessor rtd i)
|
||||
(and (not (base-rtd-subtype-rtd? rtd))
|
||||
(let ()
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(make-struct-field-accessor ref i))))
|
||||
|
||||
;; `i` does not count parent fields
|
||||
(define (record-mutator rtd i [name #f])
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(make-struct-field-mutator set i name))
|
||||
|
||||
(define (compile-time-record-mutator rtd i)
|
||||
(and (not (base-rtd-subtype-rtd? rtd))
|
||||
(let ()
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(make-struct-field-mutator set i))))
|
||||
|
||||
(define base-rtd-fields
|
||||
(map vector-copy
|
||||
'(#(fld parent #f scheme-object 9)
|
||||
#(fld size #f scheme-object 17)
|
||||
#(fld pm #f scheme-object 25)
|
||||
#(fld mpm #f scheme-object 33)
|
||||
#(fld name #f scheme-object 41)
|
||||
#(fld flds #f scheme-object 49)
|
||||
#(fld flags #f scheme-object 57)
|
||||
#(fld uid #f scheme-object 65)
|
||||
#(fld counts #f scheme-object 73))))
|
||||
|
||||
;; If `sym/i` is an integer, it *does* count parent fields
|
||||
(define (csv7:record-field-accessor/mutator rtd sym/i mut?)
|
||||
(define (lookup-field-by-name rtd sym)
|
||||
(define fields (hash-ref rtd-fields rtd))
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(or (for/or ([field (in-list fields)]
|
||||
[i (in-naturals)])
|
||||
(define name (fld-name field))
|
||||
(and (eq? sym name)
|
||||
(lookup-field-by-pos rtd i name)))
|
||||
(error 'csv7:record-field-accessor
|
||||
"cannot find ~a ~s in ~s"
|
||||
(if mut? "mutator" "accessor")
|
||||
sym
|
||||
fields)))
|
||||
;; returns either a procedure or a number for a count of fields (less than `i`)
|
||||
(define (lookup-field-by-pos rtd i [name #f] #:must-proc? [must-proc? #f])
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(cond
|
||||
[(not super)
|
||||
(if (i . >= . init-cnt)
|
||||
(if must-proc?
|
||||
(error 'csv7:record-field-accessor/mutator "field count too large: ~a" i)
|
||||
init-cnt)
|
||||
(if mut?
|
||||
(make-struct-field-mutator set i name)
|
||||
(make-struct-field-accessor ref i name)))]
|
||||
[else
|
||||
(define s-proc (lookup-field-by-pos super i name))
|
||||
(cond
|
||||
[(integer? s-proc)
|
||||
(if (i . >= . (+ s-proc init-cnt))
|
||||
(if must-proc?
|
||||
(error 'csv7:record-field-accessor/mutator "field count too large: ~a" i)
|
||||
(+ s-proc init-cnt))
|
||||
(if mut?
|
||||
(make-struct-field-mutator set (- i s-proc) name)
|
||||
(make-struct-field-accessor ref (- i s-proc) name)))]
|
||||
[else s-proc])]))
|
||||
(define (ptr-type? t)
|
||||
(case t
|
||||
[(scheme-object ptr) #t]
|
||||
[(uptr double) #f]
|
||||
[else (error "unrecognized type")]))
|
||||
(define (assert-accessor)
|
||||
(when mut? (error 'csv7:record-field-mutator "immutable base-rtd field")))
|
||||
(cond
|
||||
[(or (base-rtd? rtd)
|
||||
(subtype-of-base-rtd? rtd))
|
||||
(case sym/i
|
||||
[(flds)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(fix-offsets
|
||||
(append
|
||||
(if (or (base-rtd? rtd)
|
||||
(subtype-of-base-rtd? rtd))
|
||||
base-rtd-fields
|
||||
null)
|
||||
(if (base-rtd? rtd)
|
||||
null
|
||||
(hash-ref rtd-fields rtd)))))]
|
||||
[(parent)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd) #f]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(if (eq? super struct:base-rtd-subtype)
|
||||
base-rtd
|
||||
super)]))]
|
||||
[(size)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(let loop ([flds ((csv7:record-field-accessor base-rtd 'flds) rtd)] [x ptr-bytes])
|
||||
(cond
|
||||
[(null? flds) x]
|
||||
[(eq? (fld-type (car flds)) 'double)
|
||||
(let ([x (if (zero? (modulo x max-float-alignment))
|
||||
x
|
||||
(+ x (- 8 (modulo x max-float-alignment))))])
|
||||
(loop (cdr flds) (+ x 8)))]
|
||||
[else (loop (cdr flds) (+ x ptr-bytes))])))]
|
||||
[(pm)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(define flds ((csv7:record-field-accessor base-rtd 'flds) rtd))
|
||||
(cond
|
||||
[(for/and ([fld (in-list flds)])
|
||||
(ptr-type? (fld-type fld)))
|
||||
-1]
|
||||
[else
|
||||
(for/fold ([m 1]) ([fld (in-list flds)]
|
||||
[i (in-naturals 1)]) ; start after base rtd
|
||||
(if (ptr-type? (fld-type fld))
|
||||
(bitwise-ior m (arithmetic-shift 1 i))
|
||||
m))]))]
|
||||
[(mpm)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(for/fold ([m 0]) ([fld (in-list ((csv7:record-field-accessor base-rtd 'flds) rtd))]
|
||||
[i (in-naturals 1)]) ; start after base rtd
|
||||
(if (and (fld-mutable? fld)
|
||||
(ptr-type? (fld-type fld)))
|
||||
(bitwise-ior m (arithmetic-shift 1 i))
|
||||
m)))]
|
||||
[(name)
|
||||
(assert-accessor)
|
||||
record-type-name]
|
||||
[(uid)
|
||||
(assert-accessor)
|
||||
record-type-uid]
|
||||
[(flags)
|
||||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(bitwise-ior
|
||||
(if (hash-ref rtd-opaque?s rtd #f)
|
||||
(lookup-constant 'rtd-opaque)
|
||||
0)
|
||||
(if (hash-ref rtd-sealed?s rtd #f)
|
||||
(lookup-constant 'rtd-sealed)
|
||||
0)))]
|
||||
[(counts)
|
||||
(assert-accessor)
|
||||
(lambda (rtd) #f)]
|
||||
[else
|
||||
(cond
|
||||
[(and (integer? sym/i)
|
||||
(base-rtd? rtd))
|
||||
(assert-accessor)
|
||||
(csv7:record-field-accessor rtd (fld-name (list-ref base-rtd-fields sym/i)))]
|
||||
[(not (base-rtd? rtd))
|
||||
(define proc (if (integer? sym/i)
|
||||
(lookup-field-by-pos rtd (- sym/i (length base-rtd-fields)) #:must-proc? #t)
|
||||
(lookup-field-by-name rtd sym/i)))
|
||||
(if mut?
|
||||
(lambda (rtd/ext v)
|
||||
(proc (if (struct-type? rtd/ext)
|
||||
(hash-ref rtd-extensions rtd/ext)
|
||||
rtd/ext)
|
||||
v))
|
||||
(lambda (rtd/ext)
|
||||
(proc (if (struct-type? rtd/ext)
|
||||
(hash-ref rtd-extensions rtd/ext)
|
||||
rtd/ext))))]
|
||||
[else
|
||||
(error "unknown base-rtd field:" sym/i)])])]
|
||||
[(integer? sym/i)
|
||||
(lookup-field-by-pos rtd sym/i #:must-proc? #t)]
|
||||
[else
|
||||
(lookup-field-by-name rtd sym/i)]))
|
||||
|
||||
;; If `sym/i` is an integer, it *does* count parent fields
|
||||
(define (csv7:record-field-accessor rtd sym/i)
|
||||
(csv7:record-field-accessor/mutator rtd sym/i #f))
|
||||
|
||||
;; If `sym/i` is an integer, it *does* count parent fields
|
||||
(define (csv7:record-field-mutator rtd sym/i)
|
||||
(csv7:record-field-accessor/mutator rtd sym/i #t))
|
||||
|
||||
;; `i` *does* count parent fields
|
||||
(define (csv7:record-field-mutable? rtd i)
|
||||
(cond
|
||||
[(or (base-rtd? rtd)
|
||||
(subtype-of-base-rtd? rtd))
|
||||
(error 'csv7:record-field-mutable? "not yet supported")]
|
||||
[else
|
||||
(define fields (hash-ref rtd-fields rtd))
|
||||
(define f (list-ref fields i))
|
||||
(fld-mutable? f)]))
|
||||
|
||||
(define (record-rtd v)
|
||||
(cond
|
||||
[(base-rtd? v) base-rtd]
|
||||
[(struct? v)
|
||||
(define-values (s skipped?) (struct-info v))
|
||||
s]
|
||||
[(hash-ref rtd-extensions v #f)
|
||||
=> (lambda (ext)
|
||||
(define-values (rtd skipped?) (struct-info ext))
|
||||
rtd)]
|
||||
[(struct-type? v) base-rtd]
|
||||
[else (error 'record-rtd "not a record: ~s" v)]))
|
||||
|
||||
(define record?
|
||||
(case-lambda
|
||||
[(v)
|
||||
(and (not (bwp? v))
|
||||
(not (black-hole? v))
|
||||
(not ($unbound-object? v))
|
||||
(or (struct? v)
|
||||
(struct-type? v)
|
||||
(base-rtd? v)))]
|
||||
[(v rtd)
|
||||
(and (or (struct? v)
|
||||
(struct-type? v)
|
||||
(base-rtd? v))
|
||||
((record-predicate rtd) v))]))
|
||||
|
||||
(define ($record? v)
|
||||
(record? v))
|
||||
|
||||
(define (record-type-uid rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd) '$base-rtd]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
r-name]))
|
||||
|
||||
(define (record-type-name rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
'$base-rtd]
|
||||
[else
|
||||
(hash-ref rtd-names rtd)]))
|
||||
|
||||
(define (record-type-parent rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd) #f]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
super]))
|
||||
|
||||
;; all fields, including from parent
|
||||
(define (csv7:record-type-field-names rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(map fld-name base-rtd-fields)]
|
||||
[else
|
||||
(map fld-name (hash-ref rtd-fields rtd))]))
|
||||
|
||||
;; all fields, including from parent
|
||||
(define (csv7:record-type-field-indices rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(for/list ([f (in-list base-rtd-fields)]
|
||||
[i (in-naturals)])
|
||||
i)]
|
||||
[else
|
||||
(for/list ([f (in-list (hash-ref rtd-fields rtd))]
|
||||
[i (in-naturals)])
|
||||
i)]))
|
||||
|
||||
;; does not include parent fields
|
||||
(define (record-type-field-names rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(list->vector (csv7:record-type-field-names rtd))]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(define all-fields (hash-ref rtd-fields rtd))
|
||||
(define fields (reverse (take (reverse all-fields) init-cnt)))
|
||||
(list->vector (map fld-name fields))]))
|
||||
|
||||
;; does not include parent fields
|
||||
(define (record-type-field-indices rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd)
|
||||
(list->vector (csv7:record-type-field-indices rtd))]
|
||||
[else
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
(struct-type-info rtd))
|
||||
(for/vector ([i (in-range init-cnt)])
|
||||
i)]))
|
||||
|
||||
(define (csv7:record-type-field-decls rtd)
|
||||
(map (lambda (v) (list (if (fld-mutable? v) 'mutable 'immutable) (fld-type v) (fld-name v)))
|
||||
(hash-ref rtd-fields rtd)))
|
||||
|
||||
(define rtd-sealed?s (make-weak-hasheq))
|
||||
(define (record-type-sealed? rtd)
|
||||
(hash-ref rtd-sealed?s rtd #f))
|
||||
|
||||
(define rtd-opaque?s (make-weak-hasheq))
|
||||
(define (record-type-opaque? rtd)
|
||||
(hash-ref rtd-opaque?s rtd #f))
|
||||
|
||||
(define (record-writer . args)
|
||||
(void))
|
||||
|
||||
(define (fix-offsets flds)
|
||||
(let loop ([flds flds] [offset ptr-bytes])
|
||||
(unless (null? flds)
|
||||
(cond
|
||||
[(eq? (fld-type (car flds)) 'double)
|
||||
(let ([offset (if (zero? (modulo offset max-float-alignment))
|
||||
offset
|
||||
(+ offset (- 8 (modulo offset max-float-alignment))))])
|
||||
(set-fld-byte! (car flds) (+ record-ptr-offset offset))
|
||||
(loop (cdr flds) (+ offset 8)))]
|
||||
[else
|
||||
(set-fld-byte! (car flds) (+ record-ptr-offset offset))
|
||||
(loop (cdr flds) (+ offset ptr-bytes))])))
|
||||
flds)
|
||||
|
||||
;; assumes that `v` has only pointer-sized fields
|
||||
(define ($object-ref type v offset)
|
||||
(cond
|
||||
[(flonum? v)
|
||||
(case type
|
||||
[(unsigned-64)
|
||||
(integer-bytes->integer (real->floating-point-bytes v 8) #f)]
|
||||
[else (error "unrecognized floating-point access" type offset)])]
|
||||
[else
|
||||
(unless (or (eq? type 'scheme-object)
|
||||
(eq? type 'ptr))
|
||||
(error '$object-ref "unrecognized type: ~e" type))
|
||||
(define i (quotient (- offset (+ record-ptr-offset ptr-bytes)) ptr-bytes))
|
||||
(cond
|
||||
[(struct-type? v)
|
||||
(cond
|
||||
[(i . < . (length base-rtd-fields))
|
||||
((csv7:record-field-accessor/mutator base-rtd i #f) v)]
|
||||
[else
|
||||
(error '$object-ref "not yet supported for base-rtd subtypes")])]
|
||||
[(base-rtd? v)
|
||||
((csv7:record-field-accessor/mutator base-rtd i #f) v)]
|
||||
[else (unsafe-struct-ref v i)])]))
|
||||
1260
rktboot/scheme-lang.rkt
Normal file
1260
rktboot/scheme-lang.rkt
Normal file
File diff suppressed because it is too large
Load Diff
168
rktboot/scheme-readtable.rkt
Normal file
168
rktboot/scheme-readtable.rkt
Normal file
|
|
@ -0,0 +1,168 @@
|
|||
#lang racket/base
|
||||
(require racket/fixnum
|
||||
racket/port
|
||||
"immediate.rkt"
|
||||
"gensym.rkt")
|
||||
|
||||
(provide scheme-readtable)
|
||||
|
||||
(define (hash-three c in src line col pos)
|
||||
(define got-c (peek-char in))
|
||||
(cond
|
||||
[(eqv? #\% got-c)
|
||||
(read-char in)
|
||||
`($primitive 3 ,(read/recursive in))]
|
||||
[else
|
||||
(hash-graph #\3 in src line col pos)]))
|
||||
|
||||
(define (hash-two c in src line col pos)
|
||||
(define got-c (peek-char in))
|
||||
(cond
|
||||
[(eqv? #\% got-c)
|
||||
(read-char in)
|
||||
`($primitive 2 ,(read/recursive in))]
|
||||
[else
|
||||
(hash-graph #\2 in src line col pos)]))
|
||||
|
||||
(define (hash-one c in src line col pos)
|
||||
(define got-c (peek-char in))
|
||||
(cond
|
||||
[(eqv? #\# got-c)
|
||||
;; "read.ss" has a `#1#` reference before the
|
||||
;; `#1=...` definition; it's going to turn out
|
||||
;; to be `black-hole`
|
||||
(define name (object-name in))
|
||||
(cond
|
||||
[(and (or (string? name) (path? name))
|
||||
(regexp-match? #rx"read[.]ss$" name))
|
||||
(read-char in)
|
||||
black-hole]
|
||||
[else
|
||||
(hash-graph #\1 in src line col pos)])]
|
||||
[else
|
||||
(hash-graph #\1 in src line col pos)]))
|
||||
|
||||
(define (hash-graph c in src line col pos)
|
||||
(cond
|
||||
[(and (eqv? (peek-char in) #\=)
|
||||
(eqv? (peek-char in 1) #\#)
|
||||
(eqv? (peek-char in 2) c)
|
||||
(eqv? (peek-char in 3) #\#))
|
||||
(read-string 4 in)
|
||||
black-hole]
|
||||
[else
|
||||
(define new-in (input-port-append #f (open-input-string (string #\# c)) in))
|
||||
(read/recursive new-in #f #f #t)]))
|
||||
|
||||
(define (hash-percent c in src line col pos)
|
||||
`($primitive ,(read/recursive in)))
|
||||
|
||||
(define (hash-bang c in src line col pos)
|
||||
(define sym (read/recursive in))
|
||||
(case sym
|
||||
[(eof) eof]
|
||||
[(base-rtd) base-rtd]
|
||||
[(bwp) bwp]
|
||||
[(chezscheme) (make-special-comment 'chezscheme)]
|
||||
[else (error 'hash-bang "unrecognized ~s" sym)]))
|
||||
|
||||
(define ((paren closer) c in src line col pos)
|
||||
;; parse a list, but allow an eof element as produced by #!eof
|
||||
(let loop ()
|
||||
(define c (peek-char in))
|
||||
(cond
|
||||
[(eqv? closer c)
|
||||
(read-char in)
|
||||
null]
|
||||
[(char-whitespace? c)
|
||||
(read-char in)
|
||||
(loop)]
|
||||
[(and (eqv? #\. c)
|
||||
(char-whitespace? (peek-char in 1)))
|
||||
(read-char in)
|
||||
(begin0
|
||||
(read/recursive in)
|
||||
(let loop ()
|
||||
(define c (read-char in))
|
||||
(cond
|
||||
[(char-whitespace? c) (loop)]
|
||||
[(eqv? c closer) (void)]
|
||||
[else (error 'parens "unexpected: ~s" c)])))]
|
||||
[else
|
||||
(define v (read/recursive in))
|
||||
(if (special-comment? v)
|
||||
(loop)
|
||||
(cons v (loop)))])))
|
||||
|
||||
(define (hash-backslash c in src line col pos)
|
||||
(define next-c (peek-char in))
|
||||
(cond
|
||||
[(or (char-alphabetic? next-c)
|
||||
(char-numeric? next-c))
|
||||
(define sym (read/recursive in))
|
||||
(case sym
|
||||
[(newline) #\newline]
|
||||
[(return) #\return]
|
||||
[(nel) #\u85]
|
||||
[(ls) #\u2028]
|
||||
[(space) #\space]
|
||||
[(nul) #\nul]
|
||||
[(tab) #\tab]
|
||||
[(vtab vt) #\vtab]
|
||||
[(page) #\page]
|
||||
[(alarm bel) #\u7]
|
||||
[(backspace) #\backspace]
|
||||
[(esc) #\u1b]
|
||||
[(delete) #\u7F]
|
||||
[(rubout) #\rubout]
|
||||
[(linefeed) #\linefeed]
|
||||
[(0 1 2 3 4 5 6 7 8 9)
|
||||
(integer->char (+ sym (char->integer #\0)))]
|
||||
[else
|
||||
(define str (symbol->string sym))
|
||||
(cond
|
||||
[(= 1 (string-length str))
|
||||
(string-ref str 0)]
|
||||
[(eqv? #\x (string-ref str 0))
|
||||
(integer->char (string->number (substring str 1) 16))]
|
||||
[else
|
||||
(error 'hash-backslash "unrecognized ~s" str)])])]
|
||||
[else (read-char in)]))
|
||||
|
||||
(define (hash-vee c in src line col pos)
|
||||
(case (read-char in)
|
||||
[(#\u)
|
||||
(unless (eqv? #\8 (read-char in)) (error 'hash-vee "not 8"))
|
||||
(define l (read/recursive in))
|
||||
(list->bytes l)]
|
||||
[(#\f)
|
||||
(unless (eqv? #\x (read-char in)) (error 'hash-vee "not 8"))
|
||||
(define l (read/recursive in))
|
||||
(apply fxvector l)]
|
||||
[else (error 'hash-vee "unexpected")]))
|
||||
|
||||
(define (as-symbol c in src line col pos)
|
||||
(string->symbol (string c)))
|
||||
|
||||
(define scheme-readtable
|
||||
(make-readtable
|
||||
#f
|
||||
#\0 'dispatch-macro hash-graph
|
||||
#\1 'dispatch-macro hash-one
|
||||
#\2 'dispatch-macro hash-two
|
||||
#\3 'dispatch-macro hash-three
|
||||
#\4 'dispatch-macro hash-graph
|
||||
#\5 'dispatch-macro hash-graph
|
||||
#\6 'dispatch-macro hash-graph
|
||||
#\7 'dispatch-macro hash-graph
|
||||
#\8 'dispatch-macro hash-graph
|
||||
#\9 'dispatch-macro hash-graph
|
||||
#\% 'dispatch-macro hash-percent
|
||||
#\! 'dispatch-macro hash-bang
|
||||
#\{ 'dispatch-macro hash-curly
|
||||
#\{ 'terminating-macro as-symbol
|
||||
#\} 'terminating-macro as-symbol
|
||||
#\[ 'terminating-macro (paren #\])
|
||||
#\( 'terminating-macro (paren #\))
|
||||
#\\ 'dispatch-macro hash-backslash
|
||||
#\v 'dispatch-macro hash-vee))
|
||||
26
rktboot/scheme-struct.rkt
Normal file
26
rktboot/scheme-struct.rkt
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(struct syntax-object (e ctx) #:prefab #:mutable
|
||||
#:reflection-name '|{syntax-object bdehkef6almh6ypb-a}|)
|
||||
|
||||
(struct top-ribcage (x y) #:prefab #:mutable
|
||||
#:reflection-name '|{top-ribcage fxdfzth2q3h88vd-a}|)
|
||||
|
||||
(struct fixed-ribcage (x y z) #:prefab #:mutable
|
||||
#:reflection-name '|{fixed-ribcage cqxefau3fa3vz4m0-0}|)
|
||||
|
||||
(struct extensible-ribcage (chunks) #:prefab #:mutable
|
||||
#:reflection-name '|{extensible-ribcage cqxefau3fa3vz4m0-1}|)
|
||||
|
||||
(struct local-label (binding level) #:prefab #:mutable)
|
||||
|
||||
(struct rec-cons-desc (rtd parent-rcd protocol) #:prefab #:mutable
|
||||
#:reflection-name '|{rcd qh0yzh5qyrxmz2l-a}|)
|
||||
|
||||
(struct primref2 (name flags arity) #:prefab #:mutable
|
||||
#:reflection-name '|{primref a0xltlrcpeygsahopkplcn-2}|)
|
||||
|
||||
(struct primref3 (name flags arity signatures) #:prefab #:mutable
|
||||
#:reflection-name '|{primref a0xltlrcpeygsahopkplcn-3}|)
|
||||
30
rktboot/strip.rkt
Normal file
30
rktboot/strip.rkt
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide strip-$primitive
|
||||
strip-$app)
|
||||
|
||||
(define (strip-$primitive e)
|
||||
(cond
|
||||
[(and (pair? e)
|
||||
(eq? (car e) 'quote))
|
||||
e]
|
||||
[(and (pair? e)
|
||||
(eq? (car e) '$primitive))
|
||||
(if (pair? (cddr e))
|
||||
(caddr e)
|
||||
(cadr e))]
|
||||
[(list? e)
|
||||
(map strip-$primitive e)]
|
||||
[else e]))
|
||||
|
||||
(define (strip-$app e)
|
||||
(cond
|
||||
[(and (pair? e)
|
||||
(eq? (car e) 'quote))
|
||||
e]
|
||||
[(and (pair? e)
|
||||
(eq? (car e) '$app))
|
||||
(strip-$app (cdr e))]
|
||||
[(list? e)
|
||||
(map strip-$app e)]
|
||||
[else e]))
|
||||
52
rktboot/symbol.rkt
Normal file
52
rktboot/symbol.rkt
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide oblist
|
||||
s:string->symbol
|
||||
register-symbols
|
||||
|
||||
putprop getprop remprop
|
||||
$sputprop $sgetprop $sremprop
|
||||
|
||||
lookup-constant)
|
||||
|
||||
(define syms (make-hasheq))
|
||||
|
||||
(define (oblist)
|
||||
(hash-keys syms))
|
||||
|
||||
(define (s:string->symbol str)
|
||||
(define s (string->symbol str))
|
||||
(hash-set! syms s #t)
|
||||
s)
|
||||
|
||||
(define (register-symbols v)
|
||||
(cond
|
||||
[(symbol? v) (hash-set! syms v #t)]
|
||||
[(pair? v)
|
||||
(register-symbols (car v))
|
||||
(register-symbols (cdr v))]
|
||||
[(box? v)
|
||||
(register-symbols (unbox v))]
|
||||
[(vector? v)
|
||||
(for ([i (in-vector v)])
|
||||
(register-symbols v))]))
|
||||
|
||||
|
||||
(define (make-put-get ht)
|
||||
(values
|
||||
(lambda (sym key val)
|
||||
(hash-set! syms sym #t)
|
||||
(hash-update! ht sym (lambda (ht) (hash-set ht key val)) #hasheq()))
|
||||
(lambda (sym key [def-val #f])
|
||||
(hash-ref (hash-ref ht sym #hasheq()) key def-val))
|
||||
(lambda (sym key)
|
||||
(hash-update! ht sym (lambda (ht) (hash-remove ht key)) #hasheq()))))
|
||||
|
||||
(define-values (putprop getprop remprop) (make-put-get (make-hasheq)))
|
||||
(define-values ($sputprop $sgetprop $sremprop) (make-put-get (make-hasheq)))
|
||||
|
||||
(define (lookup-constant key [fail #f])
|
||||
(or (getprop key '*constant* #f)
|
||||
(if fail
|
||||
(fail)
|
||||
(error key "cannot find value"))))
|
||||
7
rktboot/syntax-mode.rkt
Normal file
7
rktboot/syntax-mode.rkt
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide fully-unwrap?
|
||||
start-fully-unwrapping-syntax!)
|
||||
|
||||
(define fully-unwrap? #f)
|
||||
(define (start-fully-unwrapping-syntax!) (set! fully-unwrap? #t))
|
||||
Loading…
Reference in New Issue
Block a user