diff --git a/.gitignore b/.gitignore index 9d2e67a7cc..b88dfc9f39 100644 --- a/.gitignore +++ b/.gitignore @@ -48,3 +48,4 @@ /release_notes/*.htoc /release_notes/*.log /release_notes/release_notes.pdf +/rktboot/compiled/ diff --git a/BUILDING b/BUILDING index ed7f8ef14a..87d2dc333f 100644 --- a/BUILDING +++ b/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 + +The output will either suggest using Racket as + + racket rktboot/main.rkt --machine + +or using the pb boot files with + + ./configure --pb + make .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 ' 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 ` +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 - , use + Runs the build Chez Scheme without installing. - make from-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=/boot/ \ + /bin//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.: + /bin//scheme \ + -b /path/to//boot//petite.boot \ + -b /path/to//boot//scheme.boot - $W/bin/$M/scheme -b $W/boot/$M/petite.boot -b $W/boot/$M/scheme.boot + Note that and 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 "/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 "/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 .boot` or `make .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 .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 - with: + * `make distclean` + + Removes "nanopass", "Makefile", and all workareas. - make boot XM= -Copy the generated boot/ directory to the target machine, -adding to or replacing the boot directory with pre-built boot files -there, and then build as on Linux. +WINDOWS VIA COMMAND PROMPT -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. +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 OpenBSD, Chez Scheme must be built and installed on a filesystem -that is mounted with wxallowed. + c\vs.bat amd64 -On NetBSD, note that the makefiles run "paxctl +m" to enable WX pages -(i.e., pages that have both write and execute enabled). +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): -WINDOWS + c\build.bat ta6nt + +The resulting executable in "\bin\" relies +on bootfiles in "..\boot\" 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 +"\bin\", and each relies on bootfiles in +"..\boot\" 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 \bin\ relies on -bootfiles in ..\boot\ 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- while supplying cross=t and o=o, -possibly like this: +Then, make with "c/Mf-" 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 /bin/, and it should be -installed with bootfiles in ../boot// relative to the -executable. +The executable is written to /bin/, and it +should be installed with bootfiles in ../boot// relative +to the executable. diff --git a/README.md b/README.md index 5327243034..2163f6ecaf 100644 --- a/README.md +++ b/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 [Revised6 Report on the Algorithmic Language Scheme](http://www.r6rs.org) diff --git a/configure b/configure index 793064d9f0..fda2ad11be 100755 --- a/configure +++ b/configure @@ -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=" + if [ "$m" = "" ] ; then + maybem="" + 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=" + 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 .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 diff --git a/makefiles/Makefile-workarea.in b/makefiles/Makefile-workarea.in index 48a1f8cda6..a0bb61e33c 100644 --- a/makefiles/Makefile-workarea.in +++ b/makefiles/Makefile-workarea.in @@ -22,7 +22,7 @@ build: (cd s && $(MAKE) bootstrap) .PHONY: install -install: build +install: $(MAKE) -f Mf-install .PHONY: uninstall diff --git a/rktboot/README.txt b/rktboot/README.txt new file mode 100644 index 0000000000..a79e252da4 --- /dev/null +++ b/rktboot/README.txt @@ -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 "/boot/" 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. diff --git a/rktboot/config.rkt b/rktboot/config.rkt new file mode 100644 index 0000000000..7a969017ed --- /dev/null +++ b/rktboot/config.rkt @@ -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) diff --git a/rktboot/constant.rkt b/rktboot/constant.rkt new file mode 100644 index 0000000000..6d3edcc4af --- /dev/null +++ b/rktboot/constant.rkt @@ -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) diff --git a/rktboot/define-datatype.rkt b/rktboot/define-datatype.rkt new file mode 100644 index 0000000000..bbb090f617 --- /dev/null +++ b/rktboot/define-datatype.rkt @@ -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))))) diff --git a/rktboot/format.rkt b/rktboot/format.rkt new file mode 100644 index 0000000000..9ce0cb9d2d --- /dev/null +++ b/rktboot/format.rkt @@ -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)]))])) diff --git a/rktboot/gensym.rkt b/rktboot/gensym.rkt new file mode 100644 index 0000000000..e7310ff20d --- /dev/null +++ b/rktboot/gensym.rkt @@ -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))))) + diff --git a/rktboot/hand-coded.rkt b/rktboot/hand-coded.rkt new file mode 100644 index 0000000000..f4e65a9d77 --- /dev/null +++ b/rktboot/hand-coded.rkt @@ -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)) diff --git a/rktboot/immediate.rkt b/rktboot/immediate.rkt new file mode 100644 index 0000000000..ac38615cc2 --- /dev/null +++ b/rktboot/immediate.rkt @@ -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?) diff --git a/rktboot/info.rkt b/rktboot/info.rkt new file mode 100644 index 0000000000..716bade2e6 --- /dev/null +++ b/rktboot/info.rkt @@ -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)) diff --git a/rktboot/main.rkt b/rktboot/main.rkt new file mode 100644 index 0000000000..3dd96f6e9c --- /dev/null +++ b/rktboot/main.rkt @@ -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) diff --git a/rktboot/make-boot.rkt b/rktboot/make-boot.rkt new file mode 100644 index 0000000000..299d46ac8a --- /dev/null +++ b/rktboot/make-boot.rkt @@ -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))))) diff --git a/rktboot/nanopass-patch.rkt b/rktboot/nanopass-patch.rkt new file mode 100644 index 0000000000..4a4074d6e0 --- /dev/null +++ b/rktboot/nanopass-patch.rkt @@ -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)])) diff --git a/rktboot/parse-makefile.rkt b/rktboot/parse-makefile.rkt new file mode 100644 index 0000000000..92793fc474 --- /dev/null +++ b/rktboot/parse-makefile.rkt @@ -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)))) + + diff --git a/rktboot/primdata.rkt b/rktboot/primdata.rkt new file mode 100644 index 0000000000..1b3f773a29 --- /dev/null +++ b/rktboot/primdata.rkt @@ -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)])) diff --git a/rktboot/r6rs-lang.rkt b/rktboot/r6rs-lang.rkt new file mode 100644 index 0000000000..fbe8025931 --- /dev/null +++ b/rktboot/r6rs-lang.rkt @@ -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>=?] + [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)) diff --git a/rktboot/r6rs-readtable.rkt b/rktboot/r6rs-readtable.rkt new file mode 100644 index 0000000000..461a8d82f5 --- /dev/null +++ b/rktboot/r6rs-readtable.rkt @@ -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)) diff --git a/rktboot/rcd.rkt b/rktboot/rcd.rkt new file mode 100644 index 0000000000..6f450fc7e1 --- /dev/null +++ b/rktboot/rcd.rkt @@ -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))])) diff --git a/rktboot/record.rkt b/rktboot/record.rkt new file mode 100644 index 0000000000..c88ed47556 --- /dev/null +++ b/rktboot/record.rkt @@ -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)])])) diff --git a/rktboot/scheme-lang.rkt b/rktboot/scheme-lang.rkt new file mode 100644 index 0000000000..932ff97c75 --- /dev/null +++ b/rktboot/scheme-lang.rkt @@ -0,0 +1,1260 @@ +#lang racket/base +(require (for-syntax racket/base + racket/match) + (prefix-in r: racket/include) + racket/fixnum + racket/flonum + racket/vector + racket/splicing + racket/pretty + racket/dict + "config.rkt" + (for-syntax "config.rkt") + (for-syntax "constant.rkt") + "immediate.rkt" + "define-datatype.rkt" + "primdata.rkt" + "gensym.rkt" + "format.rkt" + "hand-coded.rkt" + "scheme-struct.rkt" + "symbol.rkt" + "record.rkt" + (for-syntax "record.rkt") + "constant.rkt" + (only-in "r6rs-lang.rkt" + make-record-constructor-descriptor + set-car! + set-cdr!) + (submod "r6rs-lang.rkt" hash-pair) + (for-syntax "scheme-struct.rkt" + "rcd.rkt")) + +(provide (rename-out [s:define define] + [s:define define-threaded] + [s:define define-who] + [gen-let-values let-values] + [s:module module] + [s:parameterize parameterize]) + set-who! + import + include + when-feature + fluid-let + letrec* + putprop getprop remprop + $sputprop $sgetprop $sremprop + define-flags + $primitive + $tc $tc-field $thread-tc + enumerate + $make-record-type + $make-record-type-descriptor + $make-record-type-descriptor* + $make-record-constructor-descriptor + $record + $record? + $primitive + $unbound-object? + $app + (rename-out [get-$unbound-object $unbound-object]) + meta-cond + constant + $target-machine + $sfd + $current-mso + $block-counter + define-datatype + datum + rec + with-tc-mutex + with-values + make-record-type + type-descriptor + csv7:record-field-accessor + csv7:record-field-mutator + csv7:record-field-mutable? + record-writer + record-rtd + 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 + (rename-out [record-rtd $record-type-descriptor]) + record? + record-type-uid + $object-ref + stencil-vector? + (rename-out [s:vector-sort vector-sort] + [s:vector-sort! vector-sort!]) + vector-for-each + vector-map + primvec + get-priminfo + $top-level-value + $set-top-level-value! + $profile-source-data? + $compile-profile + compile-profile + $optimize-closures + $profile-block-data? + run-cp0 + generate-interrupt-trap + $track-dynamic-closure-counts + $suppress-primitive-inlining + uninterned-symbol? string->uninterned-symbol + debug-level + scheme-version-number + scheme-fork-version-number + (rename-out [make-parameter $make-thread-parameter] + [make-parameter make-thread-parameter] + [cons make-binding] + [car binding-type] + [cdr binding-value] + [set-car! set-binding-type!] + [set-cdr! set-binding-value!] + [mpair? binding?] + [fx+ r6rs:fx+] + [fx- r6rs:fx-] + [add1 fx1+] + [sub1 fx1-] + [add1 1+] + [sub1 1-] + [fxand fxlogand] + [fxior fxlogor] + [fxior fxlogior] + [fxxor fxlogxor] + [fxlshift fxsll] + [bitwise-bit-count fxbit-count] + [arithmetic-shift ash] + [arithmetic-shift bitwise-arithmetic-shift-left] + [arithmetic-shift bitwise-arithmetic-shift] + [fxrshift fxsra] + [bitwise-not lognot] + [bitwise-ior logor] + [bitwise-xor logxor] + [bitwise-ior logior] + [bitwise-and logand] + [bitwise-bit-set? fxbit-set?] + [integer-length bitwise-length] + [->fl fixnum->flonum] + [+ cfl+] + [- cfl-] + [* cfl*] + [/ cfl/] + [= cfl=] + [/ fx/] + [real-part cfl-real-part] + [imag-part cfl-imag-part] + [real-part $exactnum-real-part] + [imag-part $exactnum-imag-part] + [numerator $ratio-numerator] + [denominator $ratio-denominator] + [= r6rs:=] + [char=? r6rs:char=?] + [s:error $oops] + [error $undefined-violation] + [error errorf] + [error warningf] + [make-bytes make-bytevector] + [bytes bytevector] + [bytes-length bytevector-length] + [bytes? bytevector?] + [bytes-set! bytevector-u8-set!] + [bytes-ref bytevector-u8-ref] + [bwp? bwp-object?] + [number->string r6rs:number->string] + [s:printf printf] + [s:fprintf fprintf] + [file-position port-position] + [file-position set-port-position!] + [write-string display-string] + [call/ec call/1cc] + [s:string->symbol string->symbol]) + logbit? logbit1 logbit0 logtest + (rename-out [logbit? fxlogbit?] + [logbit1 fxlogbit1] + [logbit0 fxlogbit0] + [logtest fxlogtest]) + $fxu< + fxsrl + fxbit-field + fxpopcount + fxpopcount32 + fxpopcount16 + bitwise-bit-count + bitwise-arithmetic-shift-right + bytevector-u16-native-ref + bytevector-s16-native-ref + bytevector-u32-native-ref + bytevector-s32-native-ref + bytevector-u64-native-ref + bytevector-s64-native-ref + bytevector-s16-ref + bytevector-u16-ref + bytevector-s32-ref + bytevector-u32-ref + bytevector-s64-ref + bytevector-u64-ref + $integer-64? + $integer-32? + $flonum->digits + $flonum-sign + syntax-error + $source-warning + all-set? + any-set? + iota + list-head + subst substq substv + (rename-out [subst subst!] + [substv substv!] + [substq substq!]) + nonnegative? + nonpositive? + (rename-out [nonnegative? fxnonnegative?] + [nonpositive? fxnonpositive?]) + last-pair + oblist + make-hashtable + make-weak-eq-hashtable + symbol-hash + hashtable-keys + hashtable-entries + eq-hashtable? + eq-hashtable-weak? + eq-hashtable-ephemeron? + symbol-hashtable? + hashtable-equivalence-function + hashtable-mutable? + $ht-minlen + $ht-veclen + (rename-out [hash? hashtable?] + [hash-ref/pair/dict hashtable-ref] + [hash-ref/pair/dict eq-hashtable-ref] + [hash-ref-cell eq-hashtable-cell] + [hash-set!/pair/dict hashtable-set!] + [hash-remove! eq-hashtable-delete!] + [equal-hash-code string-hash] + [hash-set!/pair/dict symbol-hashtable-set!] + [hash-has-key? symbol-hashtable-contains?] + [hash-has-key? eq-hashtable-contains?] + [hash-ref/pair/dict symbol-hashtable-ref] + [hash-ref-cell symbol-hashtable-cell]) + bignum? + ratnum? + $inexactnum? + $exactnum? + $rtd-counts? + (rename-out [symbol->string $symbol-name]) + self-evaluating? + list-sort + (rename-out [list-sort sort]) + path-absolute? + subset-mode + weak-pair? + ephemeron-pair? + immutable-string? + immutable-vector? + immutable-bytevector? + immutable-fxvector? + immutable-box? + require-nongenerative-clause + generate-inspector-information + generate-procedure-source-information + enable-cross-library-optimization + enable-arithmetic-left-associative + enable-type-recovery + fasl-compressed + current-expand + current-generate-id + internal-defines-as-letrec* + eval-syntax-expanders-when + prelex-assigned set-prelex-assigned! + prelex-referenced set-prelex-referenced! + prelex-seen set-prelex-seen! + prelex-multiply-referenced set-prelex-multiply-referenced! + safe-assert + print-gensym $intern3 + print-level + print-depth + print-length + (rename-out [s:pretty-format pretty-format]) + interpret + who + with-source-path + $make-source-oops + $guard + $reset-protect + $map + $open-file-input-port + $open-file-output-port + (rename-out [s:open-output-file open-output-file]) + $open-bytevector-list-output-port + open-bytevector-output-port + native-transcoder + port-file-compressed! + file-buffer-size + $source-file-descriptor + transcoded-port + current-transcoder + textual-port? + binary-port? + put-bytevector + put-u8 + get-bytevector-n! + (rename-out [read-byte get-u8] + [peek-byte lookahead-u8] + [s:write write]) + console-output-port + path-root + path-last + $make-read + libspec? + $hand-coded + on-reset + disable-interrupts enable-interrupts + mutex-acquire mutex-release $tc-mutex $thread-list + $pass-time + priminfo-unprefixed + priminfo-libraries + $c-bufsiz + $foreign-procedure + make-guardian) + +(module+ callback + (provide set-current-expand-set-callback!)) + +(define-syntax-rule (import . _) + (void)) + +(define-syntax include + (lambda (stx) + (syntax-case stx () + [(form "machine.def") #`(form ,(string-append target-machine ".def"))] + [(form p) #'(r:include-at/relative-to form form p)]))) + +;; If we have to avoid `read-syntax`: +#; +(define-syntax include + (lambda (stx) + (syntax-case stx () + [(form "machine.def") #`(form #,(string-append target-machine ".def"))] + [(form p) + (let ([r (call-with-input-file* + (syntax->datum #'p) + (lambda (i) + (let loop () + (define e (read i)) + (if (eof-object? e) + null + (cons e (loop))))))]) + (datum->syntax #'form `(begin ,@r)))]))) + +(define-syntax when-feature + (syntax-rules () + [(_ pthreads . _) (begin)])) + +(define-syntax (fluid-let stx) + (syntax-case stx () + [(_ ([id rhs] ...) body ...) + (with-syntax ([(tmp-id ...) (generate-temporaries #'(id ...))]) + #'(let ([tmp-id rhs] + ...) + (define (swap) + (let ([v tmp-id]) (set! tmp-id id) (set! id v)) ...) + (dynamic-wind + swap + (lambda () body ...) + swap)))])) + +;; Help the Racket compiler by lifting immediate record operations out +;; of a `letrec`. Otherwise, the Racket compiler cannot figure out that +;; they won't capture continuations, etc., and will make access slow. +;; We may even be able to substitute a literal procedure, since all record +;; types are prefab structs. +(define-syntax (letrec* stx) + (syntax-case stx () + [(_ (clause ...) . body) + (let loop ([clauses (syntax->list #'(clause ...))] [lets '()] [letrecs '()] [macros '()] [rcds #hasheq()]) + (cond + [(null? clauses) + #`(let #,(reverse lets) + (letrec-syntaxes+values #,(for/list ([s (in-list macros)]) + (syntax-case s () + [[id rhs] + #'[(id) (lambda (stx) (quote-syntax rhs))]])) + #,(for/list ([s (in-list (reverse letrecs))]) + (syntax-case s () + [[id rhs] + #'[(id) rhs]])) + . body))] + [else + (define (id-eq? a b) (eq? (syntax-e a) (syntax-e b))) + (syntax-case* (car clauses) ($primitive record-accessor record-predicate + $make-record-constructor-descriptor + make-record-constructor-descriptor + r6rs:record-constructor + quote) id-eq? + [[id (($primitive _ record-accessor) 'rtd n)] + (and (struct-type? (syntax-e #'rtd)) + (integer? (syntax-e #'n))) + (let ([a (compile-time-record-accessor (syntax-e #'rtd) (syntax-e #'n))]) + (loop (cdr clauses) (cons (if a + #`[id '#,a] + (car clauses)) + lets) + letrecs + macros + rcds))] + [[id (($primitive _ record-mutator) 'rtd n)] + (and (struct-type? (syntax-e #'rtd)) + (integer? (syntax-e #'n))) + (let ([m (compile-time-record-mutator (syntax-e #'rtd) (syntax-e #'n))]) + (loop (cdr clauses) (cons (if m + #`[id '#,m] + (car clauses)) + lets) + letrecs + macros + rcds))] + [[id (($primitive _ record-predicate) 'rtd)] + (struct-type? (syntax-e #'rtd)) + (let ([p (compile-time-record-predicate (syntax-e #'rtd))]) + (loop (cdr clauses) (cons (if p + #`[id '#,p] + (car clauses)) + lets) + letrecs + macros + rcds))] + [[id (($primitive _ r6rs:record-constructor) 'rcd)] + (rec-cons-desc? (syntax-e #'rcd)) + (let ([c (rcd->constructor (syntax-e #'rcd) #f)]) + (cond + [c (loop (cdr clauses) (cons #`[id #,c] + lets) + letrecs + macros + rcds)] + [else + (and (log-warning "couldn't inline ~s" (car clauses)) #f) + (loop (cdr clauses) lets (cons (car clauses) letrecs) macros rcds)]))] + [[id (($primitive _ mrcd) + 'rtd + base + proc + . maybe-name)] + (and (or (eq? '$make-record-constructor-descriptor (syntax-e #'mrcd)) + (eq? 'make-record-constructor-descriptor (syntax-e #'mrcd))) + (struct-type? (syntax-e #'rtd)) + (or (not (syntax-e #'base)) + (hash-ref rcds (syntax-e #'base) #f)) + (immediate-procedure-expression? #'proc)) + (let ([rtd (syntax-e #'rtd)] + [base-rcdi (and (syntax-e #'base) + (hash-ref rcds (syntax-e #'base) #f))]) + (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?) + (struct-type-info rtd)) + (when (and (not base-rcdi) + super) + (error "can't handle an rcd without a base rcd and with a parent record type")) + (define rdci (rcd-info rtd #'proc base-rcdi (+ init-cnt (if base-rcdi + (rcd-info-init-cnt base-rcdi) + 0)))) + (loop (cdr clauses) + lets + (cons #`[id (mrcd + '#,rtd + base + proc + . maybe-name)] + letrecs) + macros + (hash-set rcds (syntax-e #'id) rdci)))] + [[id (($primitive _ mrcd) + 'rtd + 'base-rcd + proc + . maybe-name)] + (and (or (eq? '$make-record-constructor-descriptor (syntax-e #'mrcd)) + (eq? 'make-record-constructor-descriptor (syntax-e #'mrcd))) + (struct-type? (syntax-e #'rtd)) + (rec-cons-desc? (syntax-e #'base-rcd)) + (immediate-procedure-expression? #'proc)) + (let ([rtd (syntax-e #'rtd)] + [base-rcdi (rcd->rcdi (syntax-e #'base-rcd))]) + (unless base-rcdi + (error "can't handle this literal rcd: ~e" (syntax-e #'base-rcd))) + (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?) + (struct-type-info rtd)) + (define rdci (rcd-info rtd #'proc base-rcdi (+ init-cnt (rcd-info-init-cnt base-rcdi)))) + (loop (cdr clauses) + lets + (cons #`[id (mrcd + '#,rtd + 'base-rcd + proc + . maybe-name)] + letrecs) + macros + (hash-set rcds (syntax-e #'id) rdci)))] + [[id (($primitive _ r6rs:record-constructor) rcd-id)] + (and (identifier? #'rcd-id) + (hash-ref rcds (syntax-e #'rcd-id) #f)) + (let ([rcdi (hash-ref rcds (syntax-e #'rcd-id))]) + (define (rcdi->generator rcdi) + (define base-rcdi (rcd-info-base-rcdi rcdi)) + (cond + [(not (rcd-info-proto-expr rcdi)) + #`(lambda (ctr) ctr)] + [(not base-rcdi) + (rcd-info-proto-expr rcdi)] + [else + (with-syntax ([ctr (gensym 'ctr)] + [(p-arg ...) (for/list ([i (in-range (rcd-info-init-cnt base-rcdi))]) + (gensym))] + [(c-arg ...) (for/list ([i (in-range (- (rcd-info-init-cnt rcdi) + (rcd-info-init-cnt base-rcdi)))]) + (gensym))]) + #`(lambda (ctr) + (#,(rcd-info-proto-expr rcdi) + (#,(rcdi->generator base-rcdi) + (lambda (p-arg ...) + (lambda (c-arg ...) + (ctr p-arg ... c-arg ...)))))))])) + (define c (struct-type-make-constructor (rcd-info-rtd rcdi))) + (loop (cdr clauses) + lets + (cons #`[id (#,(rcdi->generator rcdi) #,c)] + letrecs) + macros + rcds))] + [[id (($primitive _ r6rs:record-constructor) _)] + (and (log-warning "couldn't simplify ~s" (car clauses)) + #f) + (void)] + + [[id (($primitive _ mrcd) . _)] + (and (or (eq? '$make-record-constructor-descriptor (syntax-e #'mrcd)) + (eq? 'make-record-constructor-descriptor (syntax-e #'mrcd))) + (log-warning "couldn't recognize ~s" (car clauses)) + #f) + (void)] + [else + (loop (cdr clauses) lets (cons (car clauses) letrecs) macros rcds)])]))])) + +(define-for-syntax (immediate-procedure-expression? s) + (syntax-case s () + [(id . _) + (and (identifier? #'id) + (or (eq? (syntax-e #'id) 'lambda) + (eq? (syntax-e #'id) 'case-lambda)))] + [_ #f])) + +(define-syntax (with-inline-cache stx) + (syntax-case stx () + [(_ expr) + #`(let ([b #,(mcons #f #f)]) + (or (mcar b) + (let ([r expr]) + (set-mcar! b r) + r)))])) + +(define-syntax (s:parameterize stx) + (syntax-case stx () + [(_ ([id rhs] ...) body ...) + (with-syntax ([(tmp-id ...) (generate-temporaries #'(id ...))]) + #'(let ([tmp-id rhs] + ...) + (define (swap) + (let ([v tmp-id]) (set! tmp-id (id)) (id v)) ...) + (dynamic-wind + swap + (lambda () body ...) + swap)))])) + +(define-syntax s:define + (syntax-rules () + [(_ id) (define id (void))] + [(_ . rest) (define . rest)])) + +(define-syntax (gen-let-values stx) + (syntax-case stx () + [(_ ([lhs rhs] ...) body ...) + (with-syntax ([([lhs rhs] ...) + (for/list ([lhs (in-list (syntax->list #'(lhs ...)))] + [rhs (in-list (syntax->list #'(rhs ...)))]) + (syntax-case lhs () + [(id ...) (list lhs rhs)] + [_ (with-syntax ([flat-lhs (let loop ([lhs lhs]) + (syntax-case lhs () + [(id . rest) + (cons #'id (loop #'rest))] + [_ (list lhs)]))]) + #'[flat-lhs (call-with-values (lambda () rhs) + (lambda lhs (values . flat-lhs)))])]))]) + #'(let-values ([lhs rhs] ...) body ...))])) + +(define-values (primvec get-priminfo) + (get-primdata $sputprop scheme-dir)) + +(begin-for-syntax + (define (make-flags->bits 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)))))) + +(define-syntax (define-flags stx) + (syntax-case stx () + [(_ name spec ...) + #'(define-syntax name + (let ([flags->bits (make-flags->bits '(spec ...))]) + (lambda (stx) + (syntax-case stx (or) + [(_ . flags) + (flags->bits 'flags)]))))])) + +(define-syntax $primitive + (syntax-rules () + [(_ name) name] + [(_ opt name) name])) + +(define ($app proc . args) + (apply proc args)) + +(define tc (make-hasheq)) +(define ($tc) tc) +(define ($thread-tc tc) tc) + +(define $tc-field + (case-lambda + [(sym tc) (hash-ref tc sym (case sym + [(parameters) (vector)] + [else 0]))] + [(sym tc v) (hash-set! tc sym v)])) + +(define ($thread-list) (list tc)) + +(define (enumerate ls) + (for/list ([v (in-list ls)] + [i (in-naturals)]) + i)) + +(define ($make-record-constructor-descriptor rtd prcd protocol who) + (make-record-constructor-descriptor rtd prcd protocol)) + +(define ($make-record-type-descriptor* base-rtd name parent uid sealed? opaque? num-fields mutability-mask who . extras) + (define fields (for ([i (in-range num-fields)]) + (list (if (bitwise-bit-set? mutability-mask i) 'mutable 'immutable) + (string->symbol (format "f~a" i))))) + (apply $make-record-type-descriptor base-rtd name parent uid sealed? opaque? fields who extras)) + +(define-syntax-rule (s:module (id ...) body ...) + (begin + body ...)) + +(define-syntax-rule (meta-cond [q r ...] ...) + (splicing-let-syntax ([go + (lambda (stx) + (cond + [q #'(begin r ...)] + ...))]) + (go))) + +(define-syntax set-who! + (syntax-rules () + [(_ #(space id) rhs) (void)] + [(_ id rhs) (set! id rhs)])) + +(define-syntax (constant stx) + (syntax-case stx () + [(_ id) + #`#,(case (syntax-e #'id) + [(fixnum-bits) fixnum-bits] + [(most-negative-fixnum) (- (expt 2 (sub1 fixnum-bits)))] + [(most-positive-fixnum) (sub1 (expt 2 (sub1 fixnum-bits)))] + [(annotation-debug) annotation-debug] + [(annotation-profile) annotation-profile] + [(visit-tag) visit-tag] + [(revisit-tag) revisit-tag] + [(prelex-is-flags-offset) prelex-is-flags-offset] + [(prelex-was-flags-offset) prelex-was-flags-offset] + [(prelex-sticky-mask) prelex-sticky-mask] + [(prelex-is-mask) prelex-is-mask] + [else (error 'constant "unknown: ~s" #'id)])])) + +(define $target-machine (make-parameter (string->symbol target-machine))) +(define $sfd (make-parameter #f)) +(define $current-mso (make-parameter #f)) +(define $block-counter (make-parameter 0)) + +(define (any-set? mask x) + (not (fx= (fxand mask x) 0))) + +(define (all-set? mask x) + (let ((m mask)) (fx= (fxand m x) m))) + +(define (iota n) + (for/list ([i (in-range n)]) + i)) + +(define (list-head l n) + (if (zero? n) + null + (cons (car l) + (list-head (cdr l) (sub1 n))))) + +(define ((make-subst eql?) new old v) + (let loop ([v v]) + (cond + [(eql? v old) new] + [(pair? v) (cons (loop (car v)) + (loop (cdr v)))] + [else v]))) + +(define subst (make-subst equal?)) +(define substv (make-subst eqv?)) +(define substq (make-subst eq?)) + +(define-syntax-rule (datum e) + (syntax->datum (syntax e))) + +(define-syntax-rule (rec id rhs) + (letrec ([id rhs]) + id)) + +(define (nonnegative? v) + (and (real? v) + (v . >= . 0))) + +(define (nonpositive? v) + (and (real? v) + (v . <= . 0))) + +(define (last-pair p) + (if (and (pair? p) + (pair? (cdr p))) + (last-pair (cdr p)) + p)) + +(define-syntax-rule (with-tc-mutex body ...) + (let () body ...)) + +(define-syntax-rule (with-values prod con) + (call-with-values (lambda () prod) con)) + +(define (s:vector-sort proc vec) + (vector-sort vec proc)) + +(define (s:vector-sort! proc vec) + (vector-sort! vec proc)) + +(define vector-for-each + (case-lambda + [(proc vec) + (for ([e (in-vector vec)]) + (proc e))] + [(proc vec1 vec2) + (for ([e1 (in-vector vec1)] + [e2 (in-vector vec2)]) + (proc e1 e2))] + [(proc . vecs) + (apply for-each proc (map vector->list vecs))])) + +(define vector-map + (case-lambda + [(proc vec) + (for/vector #:length (vector-length vec) ([e (in-vector vec)]) + (proc e))] + [(proc . vecs) + (list->vector (apply map proc (map vector->list vecs)))])) + +(define (stencil-vector? v) #f) + +(define (fxpopcount32 x) + (let* ([x (- x (bitwise-and (arithmetic-shift x -1) #x55555555))] + [x (+ (bitwise-and x #x33333333) (bitwise-and (arithmetic-shift x -2) #x33333333))] + [x (bitwise-and (+ x (arithmetic-shift x -4)) #x0f0f0f0f)] + [x (+ x (arithmetic-shift x -8) (arithmetic-shift x -16) (arithmetic-shift x -24))]) + (bitwise-and x #x3f))) + +(define (fxpopcount x) + (fx+ (fxpopcount32 (bitwise-and x #xffffffff)) + (fxpopcount32 (arithmetic-shift x -32)))) + +(define (fxpopcount16 x) + (fxpopcount32 (bitwise-and x #xffff))) + +(define (logbit? m n) + (bitwise-bit-set? n m)) +(define (logbit1 i n) + (bitwise-ior (arithmetic-shift 1 i) n)) +(define (logbit0 i n) + (bitwise-and (bitwise-not (arithmetic-shift 1 i)) n)) +(define (logtest a b) + (not (eqv? 0 (bitwise-and a b)))) + +(define ($fxu< a b) + (if (< a 0) + #f + (< a b))) + +(define (fxsrl v amt) + (if (and (v . fx< . 0) + (amt . fx> . 0)) + (bitwise-and (fxrshift v amt) + (- (fxlshift 1 (- fixnum-bits amt)) 1)) + (fxrshift v amt))) + +(define (fxbit-field fx1 fx2 fx3) + (fxrshift (fxand fx1 (fxnot (fxlshift -1 fx3))) fx2)) + +(define (bitwise-bit-count fx) + (cond + [(eqv? fx 0) 0] + [(eqv? 0 (bitwise-and fx 1)) + (bitwise-bit-count (arithmetic-shift fx -1))] + [else + (add1 (bitwise-bit-count (arithmetic-shift fx -1)))])) + +(define (bitwise-arithmetic-shift-right v s) + (arithmetic-shift v (- s))) + +(define (bytevector-u16-native-ref bv i) + (integer-bytes->integer bv #f (system-big-endian?) i (+ i 2))) + +(define (bytevector-s16-native-ref bv i) + (integer-bytes->integer bv #t (system-big-endian?) i (+ i 2))) + +(define (bytevector-u32-native-ref bv i) + (integer-bytes->integer bv #t (system-big-endian?) i (+ i 4))) + +(define (bytevector-s32-native-ref bv i) + (integer-bytes->integer bv #t (system-big-endian?) i (+ i 4))) + +(define (bytevector-u64-native-ref bv i) + (integer-bytes->integer bv #t (system-big-endian?) i (+ i 8))) + +(define (bytevector-s64-native-ref bv i) + (integer-bytes->integer bv #t (system-big-endian?) i (+ i 8))) + +(define (bytevector-s16-ref bv i endness) + (integer-bytes->integer bv #t (eq? endness 'big) i (+ i 2))) + +(define (bytevector-u16-ref bv i endness) + (integer-bytes->integer bv #f (eq? endness 'big) i (+ i 2))) + +(define (bytevector-s32-ref bv i endness) + (integer-bytes->integer bv #t (eq? endness 'big) i (+ i 4))) + +(define (bytevector-u32-ref bv i endness) + (integer-bytes->integer bv #f (eq? endness 'big) i (+ i 4))) + +(define (bytevector-s64-ref bv i endness) + (integer-bytes->integer bv #t (eq? endness 'big) i (+ i 8))) + +(define (bytevector-u64-ref bv i endness) + (integer-bytes->integer bv #f (eq? endness 'big) i (+ i 8))) + +(define ($integer-64? x) + (<= (- (expt 2 63)) (sub1 (expt 2 64)))) + +(define ($integer-32? x) + (<= (- (expt 2 31)) (sub1 (expt 2 32)))) + +(define ($flonum->digits . args) + (error '$flonum->digits "not ready")) + +(define ($flonum-sign fl) + (if (or (eqv? fl -0.0) + (negative? fl)) + 1 + 0)) + +(define ($top-level-value name) + (case name + [(apply) apply] + [($capture-fasl-target) + (namespace-variable-value name #t (lambda () $unbound-object))] + [else + (namespace-variable-value name)])) + +(define ($set-top-level-value! name val) + (namespace-set-variable-value! name val)) + +(define (get-$unbound-object) + $unbound-object) + +(define ($profile-source-data?) + #f) + +(define $compile-profile (make-parameter #f)) +(define compile-profile $compile-profile) +(define $optimize-closures (make-parameter #t)) +(define $profile-block-data? (make-parameter #f)) +(define run-cp0 (make-parameter error)) +(define generate-interrupt-trap (make-parameter #t)) +(define $track-dynamic-closure-counts (make-parameter #f)) +(define $suppress-primitive-inlining (make-parameter #f)) +(define debug-level (make-parameter 0)) + +(define (scheme-version-number) + (define v (lookup-constant 'scheme-version)) + (if (zero? (arithmetic-shift v -24)) + (values (arithmetic-shift v -16) + (bitwise-and 255 (arithmetic-shift v -8)) + (bitwise-and 255 v)) + (values (arithmetic-shift v -24) + (bitwise-and 255 (arithmetic-shift v -16)) + (bitwise-and 255 (arithmetic-shift v -8))))) + +(define (scheme-fork-version-number) + (define v (lookup-constant 'scheme-version)) + (define-values (maj min sub) (scheme-version-number)) + (if (zero? (arithmetic-shift v -24)) + (values maj min sub 0) + (values maj min sub (bitwise-and 255 v)))) + +(define (make-hashtable hash eql?) + (cond + [(eq? hash symbol-hash) + (define ht (make-hasheq)) + (hash-set! symbol-hts ht eql?) + ht] + [(and (eq? hash equal-hash-code) + (or (eq? eql? equal?) + (eq? eql? string=?))) + (make-hash)] + [(and (eq? hash values) + (eq? eql? =)) + (make-hash)] + [else + (make-custom-hash eql? hash (lambda (a) 1))])) + +(define (make-weak-eq-hashtable) + (make-weak-hasheq)) + +(define (hash-ref/pair/dict ht key def-v) + (if (hash? ht) + (hash-ref/pair ht key def-v) + (dict-ref ht key def-v))) + +(define (hash-set!/pair/dict ht key v) + (if (hash? ht) + (hash-set!/pair ht key v) + (dict-set! ht key v))) + +(define (hashtable-keys ht) + (list->vector (if (hash? ht) + (hash-keys ht) + (dict-keys ht)))) + +(define (hashtable-entries ht) + (define ps (hash-values ht)) + (values (list->vector (map car ps)) + (list->vector (map cdr ps)))) + +(define (eq-hashtable? v) + (and (hash? v) (hash-eq? v) (not (symbol-hashtable? v)))) + +(define (eq-hashtable-weak? v) + (hash-weak? v)) +(define (eq-hashtable-ephemeron? v) + #f) + +(define symbol-hts (make-weak-hasheq)) + +(define (symbol-hash x) (eq-hash-code x)) + +(define (symbol-hashtable? v) + (and (hash-ref symbol-hts v #f) #t)) + +(define (hashtable-equivalence-function v) + (or (hash-ref symbol-hts v #f) + (error 'hashtable-equivalence-function "only implemented for symbol hashtables"))) + +(define (hashtable-mutable? ht) #t) + +(define ($ht-minlen ht) + (lookup-constant 'hashtable-default-size)) + +(define ($ht-veclen ht) + (arithmetic-shift 1 (integer-length (hash-count ht)))) + +(define (bignum? x) + (and (integer? x) + (exact? x) + (not (s:fixnum? x)))) + +(define (ratnum? x) + (and (real? x) + (exact? x) + (not (integer? x)))) + +(define ($inexactnum? x) + (and (complex? x) + (not (real? x)) + (inexact? x))) + +(define ($exactnum? x) + (and (complex? x) + (not (real? x)) + (exact? x))) + +(define ($rtd-counts? x) + #f) + +(define (self-evaluating? v) + (or (boolean? v) + (number? v) + (string? v) + (bytes? v) + (char? v) + (base-rtd? v) + (bwp? v))) + +(define (weak-pair? v) + #f) +(define (ephemeron-pair? v) + #f) + +;; The Chez Scheme compiler does not itself create +;; any immutable values, but Racket's `eval` coerces +;; to immutable. For fasl purposes, claim all as mutable. +(define any-immutable? #f) + +(define (immutable-string? s) + (and any-immutable? + (string? s) + (immutable? s))) + +(define (immutable-vector? s) + (and any-immutable? + (vector? s) + (immutable? s))) + +(define (immutable-bytevector? s) + (and any-immutable? + (bytes? s) + (immutable? s))) + +(define (immutable-fxvector? s) + #f) + +(define (immutable-box? s) + (and any-immutable? + (box? s) + (immutable? s))) + +(define (list-sort pred l) + (sort l pred)) + +(define (path-absolute? p) + (absolute-path? p)) + +(define current-expand-set-callback void) +(define (set-current-expand-set-callback! cb) + (set! current-expand-set-callback cb)) + +(define current-expand + (let ([v expand]) + (case-lambda + [() v] + [(new-v) + (set! v new-v) + (current-expand-set-callback)]))) + +(define subset-mode (make-parameter 'system)) +(define internal-defines-as-letrec* (make-parameter #t)) +(define (eval-syntax-expanders-when) '(compile eval load)) +(define require-nongenerative-clause (make-parameter #f)) +(define generate-inspector-information (make-parameter #f)) +(define generate-procedure-source-information (make-parameter #f)) +(define enable-cross-library-optimization (make-parameter #t)) +(define enable-arithmetic-left-associative (make-parameter #f)) +(define enable-type-recovery (make-parameter #t)) +(define fasl-compressed (make-parameter #f)) + +(define current-generate-id (make-parameter gensym)) + +(define (strip-syntax stx) + (cond + [(syntax-object? stx) (strip-syntax (syntax-object-e stx))] + [(pair? stx) (cons (strip-syntax (car stx)) + (strip-syntax (cdr stx)))] + [else stx])) + +(define (syntax-error stx . strs) + (error 'syntax-error "~s ~a" + (strip-syntax stx) + (apply string-append strs))) + +(define ($source-warning . args) + (void) + #; + (printf "WARNING ~s\n" args)) + +(define-syntax (define-flag-op stx) + (syntax-case stx () + [(_ get-id set-id k) + #`(begin + (define-syntax (get-id stx) + (with-syntax ([prelex-flags (datum->syntax stx 'prelex-flags)]) + (syntax-case stx () + [(_ e) #`(positive? (bitwise-and (prelex-flags e) k))]))) + (define-syntax (set-id stx) + (with-syntax ([prelex-flags-set! (datum->syntax stx 'prelex-flags-set!)] + [prelex-flags (datum->syntax stx 'prelex-flags)]) + (syntax-case stx () + [(_ e on?) #`(let ([v e]) + (prelex-flags-set! v (if on? + (bitwise-ior (prelex-flags v) k) + (bitwise-and (prelex-flags v) (bitwise-not k)))))]))))])) +(define-flag-op prelex-assigned set-prelex-assigned! #b0000000100000000) +(define-flag-op prelex-referenced set-prelex-referenced! #b0000001000000000) +(define-flag-op prelex-seen set-prelex-seen! #b0000010000000000) +(define-flag-op prelex-multiply-referenced set-prelex-multiply-referenced! #b0000100000000000) + +(define-syntax-rule (safe-assert . _) (void)) + +(define who 'some-who) + +(define (with-source-path who name procedure) + (cond + [(equal? name "machine.def") + (procedure (string-append target-machine ".def"))] + [else + (procedure name)])) + +(define ($make-source-oops . args) #f) + +(define ($guard else? handlers body) + (with-handlers ([(lambda (x) #t) (if else? + (lambda (v) (handlers v void)) + handlers)]) + (body))) +(define ($reset-protect body out) (body)) + +(define ($map who . args) (apply map args)) + +(define print-level (make-parameter #f)) +(define print-depth (make-parameter #f)) +(define print-length (make-parameter #f)) +(define (s:pretty-format sym [fmt #f]) (void)) + +(define (interpret e) (eval e)) + +(define ($open-file-input-port who filename [options #f]) + (open-input-file filename)) + +(define ($open-file-output-port who filename options) + (open-output-file filename #:exists (if (eval `(enum-set-subset? (file-options replace) ',options)) + 'replace + 'error))) + +(define (s:open-output-file filename [exists 'error]) + (open-output-file filename #:exists exists)) + +(define ($open-bytevector-list-output-port) + (define p (open-output-bytes)) + (values p + (lambda () + (define bv (get-output-bytes p)) + (values (list bv) (bytes-length bv))))) + +(define (open-bytevector-output-port [transcoder #f]) + (define p (open-output-bytes)) + (values p + (lambda () (get-output-bytes p)))) + +(define (native-transcoder) + #f) + +(define (port-file-compressed! p) + (void)) + +(define (file-buffer-size) + 4096) + +(define ($source-file-descriptor . args) + #f) + +(define (transcoded-port binary-port transcoder) + binary-port) + +(define current-transcoder (make-parameter #f)) +(define (textual-port? p) #t) +(define (binary-port? p) #t) + +(define (put-bytevector p bv [start 0] [end (bytes-length bv)]) + (write-bytes bv p start end)) + +(define (put-u8 p b) + (if (b . < . 0) + (write-byte (+ 256 b) p) + (write-byte b p))) + +(define (get-bytevector-n! p buf start end) + (read-bytes! buf p start end)) + +(define (s:write v [o (current-output-port)]) + (if (and (gensym? v) + (not (print-gensym))) + (write-string (gensym->pretty-string v) o) + (write v o))) + +(define (console-output-port) (current-output-port)) + +(define (path-root p) + (path->string (path-replace-suffix p #""))) + +(define (path-last p) + (define-values (base name dir?) (split-path p)) + (path->string name)) + +(define ($make-read p . args) + (cond + [(not (current-readtable)) + (lambda () (read p))] + [else + (lambda () (read p))])) + +;; replaced when "cmacros.ss" is loaded: +(define (libspec? x) (vector? x)) + +(define-syntax-rule (on-reset oops e1 e2 ...) + (let () e1 e2 ...)) + +(define ($pass-time name thunk) (thunk)) + +(define (disable-interrupts) (void)) +(define (enable-interrupts) (void)) +(define $tc-mutex 'tc-mutex) +(define (mutex-acquire m) (void)) +(define (mutex-release m) (void)) + +(define $c-bufsiz 4096) + +(define-syntax ($foreign-procedure stx) + (syntax-case stx () + [(_ _ name . _) #'name])) + +(define (make-guardian) + (case-lambda + [() #f] + [(v) (void)] + [(v rep) (void)])) diff --git a/rktboot/scheme-readtable.rkt b/rktboot/scheme-readtable.rkt new file mode 100644 index 0000000000..476cbb9144 --- /dev/null +++ b/rktboot/scheme-readtable.rkt @@ -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)) diff --git a/rktboot/scheme-struct.rkt b/rktboot/scheme-struct.rkt new file mode 100644 index 0000000000..094d2ba3b9 --- /dev/null +++ b/rktboot/scheme-struct.rkt @@ -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}|) diff --git a/rktboot/strip.rkt b/rktboot/strip.rkt new file mode 100644 index 0000000000..22dd35cee2 --- /dev/null +++ b/rktboot/strip.rkt @@ -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])) diff --git a/rktboot/symbol.rkt b/rktboot/symbol.rkt new file mode 100644 index 0000000000..3e5480862d --- /dev/null +++ b/rktboot/symbol.rkt @@ -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")))) diff --git a/rktboot/syntax-mode.rkt b/rktboot/syntax-mode.rkt new file mode 100644 index 0000000000..070b26396f --- /dev/null +++ b/rktboot/syntax-mode.rkt @@ -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))