├── .gitattributes ├── .github └── workflows │ ├── build.sh │ ├── ci.yml │ ├── release.sh │ ├── summary │ ├── summarytest-one │ ├── summarytest-some-fast │ └── test.sh ├── .gitignore ├── .gitmodules ├── BUILDING ├── CHARTER.md ├── CONTRIBUTING.md ├── IMPLEMENTATION.md ├── LICENSE ├── LOG ├── NOTICE ├── README.md ├── build.bat ├── build.zuo ├── c ├── a6nt-jump.asm ├── alloc.c ├── arm64nt-jump.S ├── arm64nt-jump.asm ├── atomic.h ├── build.zuo ├── clearcache.c ├── compress-io.c ├── compress-io.h ├── cs.ico ├── expeditor.c ├── externs.h ├── fasl.c ├── ffi.c ├── flushcache.c ├── foreign.c ├── gc-011.c ├── gc-ocd.c ├── gc-oce.c ├── gc-par.c ├── gc.c ├── gcwrapper.c ├── globals.h ├── i3le.c ├── intern.c ├── io.c ├── itest.c ├── lib.zuo ├── main.c ├── new-io.c ├── nocurses.h ├── number.c ├── pb.c ├── pb.h ├── popcount.h ├── ppc32.c ├── prim.c ├── prim5.c ├── print.c ├── random.c ├── scheme.c ├── scheme.exe.manifest ├── scheme.rc ├── schlib.c ├── schsig.c ├── segment.c ├── segment.h ├── sort.h ├── statics.c ├── stats.c ├── symbol.c ├── system.h ├── thread.c ├── thread.h ├── types.h ├── version.h ├── vfasl.c ├── vs.bat ├── windows.c └── winlib.zuo ├── checkin ├── configure ├── configure.orig ├── csug ├── bibliography.stex ├── binding.stex ├── canned │ ├── about.html │ ├── cisco-logo-large.png │ ├── cisco-logo-orig.png │ ├── cisco-logo.png │ ├── copyright.html │ ├── csug.css │ ├── fatfibhtml-orig.png │ ├── fatfibhtml.png │ ├── profilehtml-orig.png │ ├── profilehtml.png │ └── profview.png ├── compat.stex ├── contents.stex ├── control.stex ├── copyright.stex ├── csug.bib ├── csug.css ├── csug.stex ├── csug8.cls ├── csug8.hcls ├── csug810.clo ├── debug.stex ├── docond.ss ├── expeditor.stex ├── foreign.stex ├── intro.stex ├── io.stex ├── libraries.stex ├── myfile.ss ├── numeric.stex ├── objects.stex ├── oop.stex ├── preface.stex ├── priminfo.ss ├── scheme.hsty ├── scheme.sty ├── setup.ss ├── smgmt.stex ├── summary.ss ├── summary.stex ├── syntax.stex ├── system.stex ├── threads.stex ├── title.stex ├── tspl.bst ├── tspl4-prep.stex ├── tspl4 │ ├── answers.aux │ ├── bibliography.aux │ ├── binding.aux │ ├── contents.aux │ ├── control.aux │ ├── copyright.aux │ ├── examples.aux │ ├── exceptions.aux │ ├── further.aux │ ├── grammar.aux │ ├── intro.aux │ ├── io.aux │ ├── libraries.aux │ ├── objects.aux │ ├── out.hidx │ ├── preface.aux │ ├── records.aux │ ├── start.aux │ ├── summary.aux │ ├── syntax.aux │ ├── title.aux │ ├── to-hyperref.ss │ ├── tspl.aux │ ├── tspl.haux │ ├── tspl.idx │ └── tspl.rfm └── use.stex ├── examples ├── Makefile ├── build.zuo ├── compat.ss ├── crepl.c ├── csocket.c ├── def.ss ├── edit.ss ├── ez-grammar-test.ss ├── ez-grammar.ss ├── fact.ss ├── fatfib.ss ├── fft.ss ├── fib.ss ├── foreign.ss ├── freq.ss ├── interpret.ss ├── m4.ss ├── macro.ss ├── matrix.ss ├── object.ss ├── power.ss ├── queue.ss ├── rabbit.ss ├── rsa.ss ├── scons.ss ├── setof.ss ├── socket.ss ├── template.ss └── unify.ss ├── makefiles ├── Makefile-csug.in ├── Makefile-release_notes.in ├── Makefile.in ├── Makefile.nt ├── bintar.zuo ├── boot.zuo ├── buildmain.zuo ├── install.zuo ├── installsh ├── lib.zuo ├── libpath.zuo ├── version.zuo └── workmain.zuo ├── mats ├── 3.ms ├── 4.ms ├── 5_1.ms ├── 5_2.ms ├── 5_3.ms ├── 5_4.ms ├── 5_5.ms ├── 5_6.ms ├── 5_7.ms ├── 5_8.ms ├── 6.ms ├── 7.ms ├── 8.ms ├── build.zuo ├── bytevector.ms ├── cat_flush.c ├── cfl.ms ├── cp0.ms ├── cptypes.ms ├── date.ms ├── enum.ms ├── examples.ms ├── exceptions.ms ├── fl.ms ├── foreign.ms ├── foreign1.c ├── foreign2.c ├── foreign3.c ├── foreign4.c ├── format.ms ├── freq.in ├── freq.out ├── ftype.h ├── ftype.ms ├── fx.ms ├── hash.ms ├── ht.ss ├── ieee.ms ├── io.ms ├── m4test.in ├── m4test.out ├── mat.ss ├── misc.ms ├── oop.ms ├── oop.ss ├── patch-compile-0-f-f-t ├── patch-compile-0-f-t-f ├── patch-compile-0-f-t-t ├── patch-compile-0-t-f-f ├── patch-compile-0-t-f-t ├── patch-compile-0-t-t-f ├── patch-compile-0-t-t-t ├── patch-compile-3-f-f-t ├── patch-compile-3-f-t-f ├── patch-compile-3-f-t-t ├── patch-compile-3-t-f-f ├── patch-compile-3-t-f-t ├── patch-compile-3-t-t-f ├── patch-compile-3-t-t-t ├── patch-interpret-0-f-f-f ├── patch-interpret-0-f-t-f ├── patch-interpret-0-t-f-f ├── patch-interpret-0-t-t-f ├── patch-interpret-3-f-f-f ├── patch-interpret-3-f-t-f ├── patch-interpret-3-t-f-f ├── patch-interpret-3-t-t-f ├── primvars.ms ├── profile.ms ├── record.ms ├── root-experr-compile-0-f-f-f ├── root-experr-compile-3-f-f-f ├── thread-check.ss ├── thread.ms ├── unix.ms └── windows.ms ├── newrelease ├── pkg ├── Makefile └── rmpkg ├── release_notes ├── macros.stex ├── release_notes.stex ├── releasenotes.cls ├── releasenotes.css ├── releasenotes.hcls └── scheme.sty ├── rpm └── Makefile ├── s ├── .gitattributes ├── 4.ss ├── 5_1.ss ├── 5_2.ss ├── 5_3.ss ├── 5_4.ss ├── 5_6.ss ├── 5_7.ss ├── 6.ss ├── 7.ss ├── a6.def ├── a6nt.def ├── arm32.def ├── arm32.ss ├── arm64.def ├── arm64.ss ├── arm64nt.def ├── back.ss ├── base-lang.ss ├── boot.bat ├── bootpbchunk.ss ├── build.zuo ├── bytevector.ss ├── cafe.ss ├── cback.ss ├── cmacros.ss ├── compile.ss ├── costctr.ss ├── cp0.ss ├── cpcheck.ss ├── cpcommonize.ss ├── cpletrec.ss ├── cpnanopass.ss ├── cpprim.ss ├── cprep.ss ├── cptypes-lattice.ss ├── cptypes.ss ├── cpvalid.ss ├── date.ss ├── debug.ss ├── default.def ├── engine.ss ├── enum.ss ├── env.ss ├── event.ss ├── exceptions.ss ├── expand-lang.ss ├── expeditor.ss ├── fasl-helpers.ss ├── fasl.ss ├── ffi-help.ss ├── foreign.ss ├── format.ss ├── front.ss ├── ftype.ss ├── fxmap.ss ├── hashtable-types.ss ├── i3.def ├── i3nt.def ├── i3qnx.def ├── inspect.ss ├── interpret.ss ├── io-types.ss ├── io.ss ├── layout.ss ├── library.ss ├── machine.zuo ├── mathprims.ss ├── mkgc.ss ├── mkheader.ss ├── newhash.ss ├── np-help.ss ├── np-info.ss ├── np-languages.ss ├── np-register.ss ├── nt.def ├── patch.ss ├── pb.def ├── pb.ss ├── pbarch.def ├── pbchunk.ss ├── pbcommon.def ├── pbcommon32.def ├── pbcommon64.def ├── pdhtml.ss ├── ppc32.def ├── ppc32.ss ├── ppc32osx.def ├── pretty.ss ├── primdata.ss ├── priminfo.ss ├── primref.ss ├── prims.ss ├── primvars.ss ├── print.ss ├── read.ss ├── reboot-record-wrap.ss ├── reboot-record.ss ├── reboot.ss ├── reboot.zuo ├── record.ss ├── reloc.ss ├── riscv64.ss ├── rv64.def ├── setup.ss ├── strip-types.ss ├── strip.ss ├── strnum.ss ├── syntax.ss ├── ta6nt.def ├── target-fixnum.ss ├── tarm64nt.def ├── ti3nt.def ├── tpb.def ├── tpbarch.def ├── tppc32osx.def ├── trace.ss ├── tunix.def ├── types.ss ├── ubify.ss ├── unix.def ├── update-revision ├── vfasl.ss ├── x86.ss └── x86_64.ss ├── scheme.1.in ├── unicode ├── Makefile ├── ReadMe ├── UNIDATA │ ├── CaseFolding.txt │ ├── CompositionExclusions.txt │ ├── DerivedCoreProperties.txt │ ├── GraphemeBreakProperty.txt │ ├── NormalizationTest.txt │ ├── PropList.txt │ ├── SpecialCasing.txt │ ├── UnicodeData.txt │ ├── WordBreakProperty.txt │ └── emoji-data.txt ├── extract-char-cases.ss ├── extract-common.ss ├── extract-info.ss ├── unicode-char-cases.ss ├── unicode-charinfo.ss └── unicode-data.ss └── wininstall ├── .gitignore ├── Makefile ├── a6nt.wxs ├── bundle.wxs ├── candle.bat ├── cs.png ├── examples.wxs ├── i3nt.wxs ├── license.rtf ├── light.bat ├── locate-vcredist.bat ├── product.wxs ├── ta6nt.wxs ├── ti3nt.wxs └── ui.wxs /.gitattributes: -------------------------------------------------------------------------------- 1 | *.h linguist-language=C 2 | *.ms linguist-language=Scheme 3 | -------------------------------------------------------------------------------- /.github/workflows/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e -o pipefail 3 | export ZUO_JOBS="$(getconf _NPROCESSORS_ONLN)" 4 | if test "$TOOLCHAIN" = vs ; then 5 | # cmd.exe /c "build.bat $TARGET_MACHINE" 6 | echo assuming built previously 7 | else 8 | if test -n "$CONFIGURE_ARGS" ; then 9 | ./configure $CONFIGURE_ARGS 10 | else 11 | ./configure -m="$TARGET_MACHINE" 12 | fi 13 | make 14 | fi 15 | case "$TARGET_MACHINE" in 16 | *a6nt) 17 | curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x64.dll > "$TARGET_MACHINE"/bin/"$TARGET_MACHINE"/iconv.dll 18 | ;; 19 | *i3nt) 20 | curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x86.dll > "$TARGET_MACHINE"/bin/"$TARGET_MACHINE"/iconv.dll 21 | ;; 22 | esac 23 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: CI 3 | on: [push, pull_request] 4 | jobs: 5 | ci: 6 | strategy: 7 | fail-fast: false 8 | matrix: 9 | config: 10 | - machine: tpb 11 | os: ubuntu-22.04 12 | configure: --pb --threads --enable-libffi 13 | test: test-some-fast 14 | - machine: a6osx 15 | os: macos-12 16 | - machine: ta6osx 17 | os: macos-12 18 | - machine: i3le 19 | os: ubuntu-22.04 20 | - machine: ti3le 21 | os: ubuntu-22.04 22 | - machine: a6le 23 | os: ubuntu-22.04 24 | - machine: ta6le 25 | os: ubuntu-22.04 26 | - machine: i3nt 27 | os: windows-2022 28 | toolchain: vs 29 | - machine: ti3nt 30 | os: windows-2022 31 | toolchain: vs 32 | - machine: a6nt 33 | os: windows-2022 34 | toolchain: vs 35 | - machine: ta6nt 36 | os: windows-2022 37 | toolchain: vs 38 | - machine: ta6nt 39 | os: windows-2022 40 | toolchain: gcc 41 | runs-on: ${{ matrix.config.os }} 42 | env: 43 | TARGET_MACHINE: ${{ matrix.config.machine }} 44 | TOOLCHAIN: ${{ matrix.config.toolchain }} 45 | CONFIGURE_ARGS: ${{ matrix.config.configure }} 46 | TEST_TARGET: ${{ matrix.config.test }} 47 | defaults: 48 | run: 49 | shell: bash 50 | working-directory: ${{ github.workspace }} 51 | steps: 52 | - name: Configure git on Windows 53 | if: ${{ runner.os == 'Windows' }} 54 | run: git config --global core.autocrlf false 55 | - name: Checkout 56 | uses: actions/checkout@v3 57 | with: 58 | submodules: 'recursive' 59 | - name: Setup 32-bit Linux 60 | if: ${{ endsWith(matrix.config.machine, 'i3le') }} 61 | run: | 62 | sudo dpkg --add-architecture i386 63 | sudo apt-get update 64 | sudo apt-get install gcc-multilib lib32ncurses5-dev 65 | - name: Build Chez Scheme with Visual Studio 66 | if: ${{ matrix.config.toolchain == 'vs' }} 67 | shell: cmd 68 | run: build.bat ${{ matrix.config.machine }} 69 | - name: Build Chez Scheme 70 | run: .github/workflows/build.sh 71 | - name: Run tests 72 | if: ${{ matrix.config.toolchain != 'vs' }} 73 | timeout-minutes: 60 74 | run: .github/workflows/test.sh 75 | - name: Run tests with Visual Studio 76 | if: ${{ matrix.config.toolchain == 'vs' }} 77 | timeout-minutes: 60 78 | shell: cmd 79 | run: build.bat ${{ matrix.config.machine }} /test-some 80 | - name: Archive workspace 81 | if: always() 82 | run: tar -c -h -z -f $TARGET_MACHINE$TOOLCHAIN.tgz $TARGET_MACHINE 83 | - name: Upload archive 84 | if: always() 85 | uses: actions/upload-artifact@v3 86 | with: 87 | name: ${{ matrix.config.machine }}${{ matrix.config.toolchain }} 88 | path: ${{ matrix.config.machine }}${{ matrix.config.toolchain }}.tgz 89 | - name: Check test results 90 | run: | 91 | cat $TARGET_MACHINE/mats/summary 92 | diff -q .github/workflows/summary${{ matrix.config.test }} $TARGET_MACHINE/mats/summary 93 | -------------------------------------------------------------------------------- /.github/workflows/release.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e -o pipefail 3 | 4 | # This script is meant to be called in a directory where 5 | # "chez-scheme-$tag" and "chez-scheme-$tag.tgz" can be 6 | # created 7 | 8 | repo=$1 9 | if test "$repo" = "" ; then 10 | echo "need to supply a repo" 11 | exit 1 12 | fi 13 | 14 | tag=$2 15 | if test "$tag" = "" ; then 16 | echo "need to supply a tag" 17 | exit 1 18 | fi 19 | 20 | name=chez-scheme-"$tag" 21 | 22 | git clone -b "$tag" --single-branch "$repo" "$name" 23 | (cd "$name" && git submodule update --init --depth 1) 24 | rm -rf "$name"/.git* 25 | tar zcf "$name".tar.gz "$name" 26 | 27 | gh release create \ 28 | --repo https://github.com/racket/ChezScheme \ 29 | --title "$tag" \ 30 | --notes "The archive $name.tar.gz includes submodules." \ 31 | "$tag" "$name".tar.gz 32 | -------------------------------------------------------------------------------- /.github/workflows/summary: -------------------------------------------------------------------------------- 1 | -------- o=0 eoc=f simple -------- 2 | -------- o=3 eoc=f simple -------- 3 | -------- o=3 cp0=t cp0 -------- 4 | -------- o=3 cp0=t eval=interpret rmg=2 rmg2 -------- 5 | -------------------------------------------------------------------------------- /.github/workflows/summarytest-one: -------------------------------------------------------------------------------- 1 | -------- o=3 eoc=f simple -------- 2 | -------------------------------------------------------------------------------- /.github/workflows/summarytest-some-fast: -------------------------------------------------------------------------------- 1 | -------- o=0 eoc=f simple -------- 2 | -------- o=3 eoc=f simple -------- 3 | -------- o=3 cp0=t cp0 -------- 4 | -------------------------------------------------------------------------------- /.github/workflows/test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | export ZUO_JOBS="$(getconf _NPROCESSORS_ONLN)" 3 | if test "$TEST_TARGET" = ""; then 4 | TEST_TARGET=test-some 5 | fi 6 | if test "$TOOLCHAIN" = vs ; then 7 | cmd.exe /c "build.bat $TARGET_MACHINE /$TEST_TARGET" 8 | else 9 | make $TEST_TARGET 10 | fi 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .*.sw? 3 | .sw? 4 | .DS_Store 5 | /Makefile 6 | /main.zuo 7 | /TAGS 8 | /bin/ 9 | /boot/ 10 | /pb*/ 11 | /tpb*/ 12 | /a6*/ 13 | /i3*/ 14 | /ta6*/ 15 | /ti3*/ 16 | /arm*/ 17 | /tarm*/ 18 | /ppc*/ 19 | /tppc*/ 20 | /xc-*/ 21 | /em-*/ 22 | *.*run 23 | /csug/math/ 24 | /csug/gifs/ 25 | /csug/Makefile 26 | /csug/*.aux 27 | /csug/*.html 28 | /csug/*.tex 29 | /csug/csug.ans 30 | /csug/csug.bbl 31 | /csug/csug.blg 32 | /csug/*.haux 33 | /csug/csug.htoc 34 | /csug/*.idx 35 | /csug/csug.ilg 36 | /csug/csug.ind 37 | /csug/csug.pdf 38 | /csug/*.rfm 39 | /csug/csug.sfm 40 | /csug/csug.toc 41 | /csug/csug.out 42 | /csug/*.hidx 43 | /csug/libslisted* 44 | /csug/libsrecorded* 45 | /csug/*.log 46 | /csug/primdata.ss 47 | /release_notes/math/ 48 | /release_notes/gifs/ 49 | /release_notes/Makefile 50 | /release_notes/*.tex 51 | /release_notes/*.aux 52 | /release_notes/*.haux 53 | /release_notes/*.html 54 | /release_notes/*.htoc 55 | /release_notes/*.htoc 56 | /release_notes/*.log 57 | /release_notes/release_notes.pdf 58 | /rktboot/compiled/ 59 | /expr.md 60 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "zlib"] 2 | path = zlib 3 | url = https://github.com/madler/zlib.git 4 | [submodule "nanopass"] 5 | path = nanopass 6 | url = https://github.com/nanopass/nanopass-framework-scheme.git 7 | [submodule "stex"] 8 | path = stex 9 | url = https://github.com/dybvig/stex 10 | [submodule "lz4"] 11 | path = lz4 12 | url = https://github.com/lz4/lz4.git 13 | [submodule "boot/pb"] 14 | path = boot/pb 15 | url = https://github.com/racket/pb 16 | branch = circa-7.9.0.5-1 17 | [submodule "zuo"] 18 | path = zuo 19 | url = https://github.com/racket/zuo 20 | -------------------------------------------------------------------------------- /CHARTER.md: -------------------------------------------------------------------------------- 1 | # Chez Scheme Project Charter (the “Charter”) 2 | 3 | This Charter sets forth the responsibilities and procedures for 4 | technical contribution to, and oversight of, the Chez Scheme Project 5 | (the “Project”). Participation in the Project is open to all in a 6 | fair, reasonable, and non-discriminatory manner. Contributors to 7 | the Project must comply with the terms of this Charter. 8 | 9 | 1. Governance 10 | * The Project will involve Contributors and Committers. 11 | Contributors include anyone in the technical community who 12 | contributes code, documentation, or other technical artifacts 13 | to the Project. Committers are Contributors who have the 14 | ability to commit code directly to the Project’s main branch 15 | or repository. 16 | * The Committers shall be responsible for technical oversight 17 | and other decision making of the Project. The Committers will 18 | seek to make decisions by consensus. Except where otherwise 19 | specified below, if a consensus cannot be reached, Project 20 | decisions shall be made by a two-thirds vote of the Committers. 21 | * A unanimous vote of the Committers shall be required for any 22 | change or amendment to this Charter. 23 | 24 | 2. Technical Policy 25 | * Any Committer may review a pull request and accept, reject, 26 | or solicit modifications to the request, at the Committer’s 27 | sole discretion. For changes that might be highly impactful 28 | or controversial, Committers are encouraged, but not required, 29 | to seek consensus from the other Committers before proceeding. 30 | Committers are not required to respond to every pull request, 31 | but shall make reasonable efforts to do so. 32 | * Any existing Committer may nominate a Contributor with the 33 | demonstrated experience, knowledge, and commitment to the 34 | Project to become a new Committer. A nominee can become a 35 | Committer only by a unanimous vote of the existing Committers. 36 | * Any Committer may resign at any time by giving notice to the 37 | other Committers. Any Committer may also be removed at any 38 | time by a unanimous vote of the other Committers. 39 | 40 | 3. Intellectual Property Policy 41 | * All new inbound code contributions to the Project shall be 42 | made under the [Apache 2.0 license] 43 | (http://www.apache.org/licenses/LICENSE-2.0). 44 | * By submitting a contribution, a Contributor certifies that 45 | the Contributor is the sole creator of the contribution and/or 46 | has the right under all applicable intellectual property laws 47 | to provide the contribution to the Project under the terms of 48 | the Apache 2.0 license. 49 | * If a Contributor wishes to contribute existing source code 50 | covered by an open-source license other than Apache 2.0, the 51 | Contributor must seek an exception from the Committers. 52 | Exceptions shall be approved only by a unanimous vote of the 53 | Committers and duly recorded in the file NOTICE. 54 | * All outbound code will be made available under the Apache 2.0 55 | license. 56 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | Chez Scheme Version 9.9.9 2 | Copyright 1984-2023 Cisco Systems, Inc. 3 | 4 | This product includes code developed by Cisco Systems, Inc. 5 | 6 | This product also includes separately copyrighted: 7 | 8 | * Unicode data files from the Unicode Consortium 9 | 10 | * Unicode data-file processing code developed by Abdulaziz Ghuloum and 11 | R. Kent Dybvig 12 | 13 | * sorting code developed by Olin Shivers 14 | 15 | * example programs, an html formatting module, and documentation 16 | support files developed by R. Kent Dybvig 17 | 18 | * test code and other code used for testing developed by 19 | William D Clinger, by Dirk Lutzebaeck, and by Oscar Waddell and 20 | R. Kent Dybvig. 21 | 22 | * code derived from C. David Boyer's command-line editor 23 | 24 | Builds of this product incorporate separately copyrighted code from: 25 | 26 | * the Nanopass Infrastructure, developed by Dipanwita Sarkar, 27 | Andrew W. Keep, R. Kent Dybvig, and Oscar Waddell 28 | 29 | * the Zlib compression library, developed by Jean-loup Gailly and 30 | Mark Adler 31 | 32 | * the LZ4 compression library, developed by Yann Collet and 33 | contributors. 34 | -------------------------------------------------------------------------------- /build.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | setlocal 3 | 4 | set M=%1 5 | set WORKAREA=%M% 6 | set LINKAS=dll 7 | set RUNTIMEAS=dll 8 | set SRCDIR=%~dp0 9 | set MAKETARGET=all-dlls 10 | set SKIPVS=no 11 | 12 | if "%WORKAREA%"=="" goto needargument 13 | 14 | :argloop 15 | shift 16 | set ARG=%1 17 | if defined ARG ( 18 | if "%ARG%"=="/dll" set LINKAS=dll && goto argloop 19 | if "%ARG%"=="/exe" set LINKAS=exe && goto argloop 20 | if "%ARG%"=="/MD" set RUNTIMEAS=dll && goto argloop 21 | if "%ARG%"=="/MT" set RUNTIMEAS=static && goto argloop 22 | if "%ARG%"=="/only" set MAKETARGET=build && goto argloop 23 | if "%ARG%"=="/kernel" set MAKETARGET=kernel && goto argloop 24 | if "%ARG%"=="/none" set MAKETARGET=none && goto argloop 25 | if "%ARG%"=="/config" set MAKETARGET=none && goto argloop 26 | if "%ARG%"=="/test-one" set MAKETARGET=test-one && goto argloop 27 | if "%ARG%"=="/test-some-fast" set MAKETARGET=test-some-fast && goto argloop 28 | if "%ARG%"=="/test-some" set MAKETARGET=test-some && goto argloop 29 | if "%ARG%"=="/test" set MAKETARGET=test && goto argloop 30 | if "%ARG%"=="/test-more" set MAKETARGET=test-more && goto argloop 31 | if "%ARG%"=="/keepvs" set SKIPVS=yes && goto argloop 32 | echo Unrecognized argument %ARG% 33 | exit /B 1 34 | ) 35 | 36 | if "%M%"=="pb" set VSCONFIG=x86 37 | if "%M%"=="i3nt" set VSCONFIG=x86 38 | if "%M%"=="ti3nt" set VSCONFIG=x86 39 | if "%M%"=="a6nt" set VSCONFIG=x86_amd64 40 | if "%M%"=="ta6nt" set VSCONFIG=x86_amd64 41 | if "%M%"=="arm64nt" set VSCONFIG=x64_arm64 42 | if "%M%"=="tarm64nt" set VSCONFIG=x64_arm64 43 | if "%VSCONFIG%"=="" ( 44 | echo Unrecognized machine type %M% 45 | exit /B 1 46 | ) 47 | 48 | if not exist %WORKAREA% mkdir %WORKAREA% 49 | 50 | echo srcdir=%SRCDIR% > %WORKAREA%\Mf-config 51 | echo m=%M% >> %WORKAREA%\Mf-config 52 | echo linkAs=%LINKAS% >> %WORKAREA%\Mf-config 53 | echo runtimeAs=%RUNTIMEAS% >> %WORKAREA%\Mf-config 54 | echo enableFrompb=yes >> %WORKAREA%\Mf-config 55 | 56 | echo workarea=%WORKAREA% > Makefile 57 | echo !include %WORKAREA%\Mf-config >> Makefile 58 | type "%SRCDIR%\makefiles\Makefile.nt" >> Makefile 59 | 60 | copy /y "%SRCDIR%\makefiles\buildmain.zuo" main.zuo > NUL 61 | copy /y "%SRCDIR%\makefiles\workmain.zuo" %WORKAREA%\main.zuo > NUL 62 | 63 | echo Configured for %M% 64 | 65 | if %MAKETARGET%==none goto donebuilding 66 | 67 | if %SKIPVS%==yes goto donevs 68 | echo Configuring VS for %VSCONFIG% 69 | call "%SRCDIR%/c/vs.bat" %VSCONFIG% 70 | :donevs 71 | 72 | nmake /nologo %MAKETARGET% 73 | 74 | goto donebuilding 75 | 76 | :needargument 77 | 78 | echo Please supply the machine name as an argument 79 | exit /B 1 80 | 81 | :donebuilding 82 | -------------------------------------------------------------------------------- /c/a6nt-jump.asm: -------------------------------------------------------------------------------- 1 | ; We do not use Microsoft's implementation because its longjmp unwinds 2 | ; the stack to support C++ destructors, and the stack frames generated 3 | ; by Chez Scheme do not have the required information for this to work 4 | ; properly. 5 | ; See https://docs.microsoft.com/en-us/cpp/build/x64-calling-convention 6 | 7 | .code 8 | 9 | S_setjmp proc 10 | ; store nonvolatile registers & control words 11 | mov [rcx], rbx 12 | mov [rcx+08h], rbp 13 | mov [rcx+10h], rdi 14 | mov [rcx+18h], rsi 15 | mov [rcx+20h], rsp 16 | mov [rcx+28h], r12 17 | mov [rcx+30h], r13 18 | mov [rcx+38h], r14 19 | mov [rcx+40h], r15 20 | stmxcsr [rcx+48h] 21 | fnstcw [rcx+4ch] 22 | movdqu [rcx+50h], xmm6 23 | movdqu [rcx+60h], xmm7 24 | movdqu [rcx+70h], xmm8 25 | movdqu [rcx+80h], xmm9 26 | movdqu [rcx+90h], xmm10 27 | movdqu [rcx+0a0h], xmm11 28 | movdqu [rcx+0b0h], xmm12 29 | movdqu [rcx+0c0h], xmm13 30 | movdqu [rcx+0d0h], xmm14 31 | movdqu [rcx+0e0h], xmm15 32 | ; store return address 33 | mov rax, [rsp] 34 | mov [rcx+0f0h], rax 35 | xor eax, eax 36 | ret 37 | S_setjmp endp 38 | 39 | S_longjmp proc 40 | ; restore nonvolatile registers & control words 41 | mov rbx, [rcx] 42 | mov rbp, [rcx+08h] 43 | mov rdi, [rcx+10h] 44 | mov rsi, [rcx+18h] 45 | mov rsp, [rcx+20h] 46 | mov r12, [rcx+28h] 47 | mov r13, [rcx+30h] 48 | mov r14, [rcx+38h] 49 | mov r15, [rcx+40h] 50 | ldmxcsr [rcx+48h] 51 | fldcw [rcx+4ch] 52 | movdqu xmm6, [rcx+50h] 53 | movdqu xmm7, [rcx+60h] 54 | movdqu xmm8, [rcx+70h] 55 | movdqu xmm9, [rcx+80h] 56 | movdqu xmm10, [rcx+90h] 57 | movdqu xmm11, [rcx+0a0h] 58 | movdqu xmm12, [rcx+0b0h] 59 | movdqu xmm13, [rcx+0c0h] 60 | movdqu xmm14, [rcx+0d0h] 61 | movdqu xmm15, [rcx+0e0h] 62 | ; restore return address 63 | mov rax, [rcx+0f0h] 64 | mov [rsp], rax 65 | mov rax, rdx 66 | ret 67 | S_longjmp endp 68 | 69 | end 70 | -------------------------------------------------------------------------------- /c/arm64nt-jump.S: -------------------------------------------------------------------------------- 1 | 2 | .text 3 | .align 4 4 | .globl S_setjmp 5 | .globl S_longjmp 6 | 7 | S_setjmp: 8 | str x18, [x0, #0] 9 | str x19, [x0, #8] 10 | str x20, [x0, #16] 11 | str x21, [x0, #24] 12 | str x22, [x0, #32] 13 | str x23, [x0, #40] 14 | str x24, [x0, #48] 15 | str x25, [x0, #56] 16 | str x26, [x0, #64] 17 | str x27, [x0, #72] 18 | str x28, [x0, #80] 19 | str x29, [x0, #88] 20 | str x30, [x0, #96] 21 | mov x2, sp 22 | str x2, [x0, #104] 23 | str d8, [x0, #112] 24 | str d9, [x0, #120] 25 | str d10, [x0, #128] 26 | str d11, [x0, #136] 27 | str d12, [x0, #144] 28 | str d13, [x0, #152] 29 | str d14, [x0, #160] 30 | str d15, [x0, #168] 31 | mov x0, 0 32 | ret 33 | 34 | S_longjmp: 35 | ldr x18, [x0, #0] 36 | ldr x19, [x0, #8] 37 | ldr x20, [x0, #16] 38 | ldr x21, [x0, #24] 39 | ldr x22, [x0, #32] 40 | ldr x23, [x0, #40] 41 | ldr x24, [x0, #48] 42 | ldr x25, [x0, #56] 43 | ldr x26, [x0, #64] 44 | ldr x27, [x0, #72] 45 | ldr x28, [x0, #80] 46 | ldr x29, [x0, #88] 47 | ldr x30, [x0, #96] 48 | ldr x2, [x0, #104] 49 | mov sp, x2 50 | ldr d8, [x0, #112] 51 | ldr d9, [x0, #120] 52 | ldr d10, [x0, #128] 53 | ldr d11, [x0, #136] 54 | ldr d12, [x0, #144] 55 | ldr d13, [x0, #152] 56 | ldr d14, [x0, #160] 57 | ldr d15, [x0, #168] 58 | mov x0, x1 59 | ret 60 | -------------------------------------------------------------------------------- /c/arm64nt-jump.asm: -------------------------------------------------------------------------------- 1 | ; See "a6nt-jump.asm" for an explanation of why this implementation exists 2 | 3 | AREA .text, CODE, READONLY 4 | EXPORT S_setjmp 5 | EXPORT S_longjmp 6 | 7 | S_setjmp 8 | str x18, [x0, #0] 9 | str x19, [x0, #8] 10 | str x20, [x0, #16] 11 | str x21, [x0, #24] 12 | str x22, [x0, #32] 13 | str x23, [x0, #40] 14 | str x24, [x0, #48] 15 | str x25, [x0, #56] 16 | str x26, [x0, #64] 17 | str x27, [x0, #72] 18 | str x28, [x0, #80] 19 | str x29, [x0, #88] 20 | str x30, [x0, #96] 21 | mov x2, sp 22 | str x2, [x0, #104] 23 | str d8, [x0, #112] 24 | str d9, [x0, #120] 25 | str d10, [x0, #128] 26 | str d11, [x0, #136] 27 | str d12, [x0, #144] 28 | str d13, [x0, #152] 29 | str d14, [x0, #160] 30 | str d15, [x0, #168] 31 | mov x0, 0 32 | ret 33 | 34 | S_longjmp 35 | ldr x18, [x0, #0] 36 | ldr x19, [x0, #8] 37 | ldr x20, [x0, #16] 38 | ldr x21, [x0, #24] 39 | ldr x22, [x0, #32] 40 | ldr x23, [x0, #40] 41 | ldr x24, [x0, #48] 42 | ldr x25, [x0, #56] 43 | ldr x26, [x0, #64] 44 | ldr x27, [x0, #72] 45 | ldr x28, [x0, #80] 46 | ldr x29, [x0, #88] 47 | ldr x30, [x0, #96] 48 | ldr x2, [x0, #104] 49 | mov sp, x2 50 | ldr d8, [x0, #112] 51 | ldr d9, [x0, #120] 52 | ldr d10, [x0, #128] 53 | ldr d11, [x0, #136] 54 | ldr d12, [x0, #144] 55 | ldr d13, [x0, #152] 56 | ldr d14, [x0, #160] 57 | ldr d15, [x0, #168] 58 | mov x0, x1 59 | ret 60 | 61 | END 62 | -------------------------------------------------------------------------------- /c/clearcache.c: -------------------------------------------------------------------------------- 1 | /* clearcache.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | /* Implements cache flushing for typical architectures using mostly 18 | __clear_cache() and Linux facilities (when available). */ 19 | 20 | #include "system.h" 21 | 22 | #include 23 | #include 24 | 25 | #ifdef TARGET_OS_IPHONE 26 | # include 27 | #endif 28 | 29 | /* we don't count on having the right value for correctness, 30 | * but the right value will give maximum efficiency */ 31 | #define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32 32 | 33 | static int l1_max_cache_line_size; 34 | 35 | /* flushcache_max_gap is the maximum gap between unmerged chunks of memory to be flushed */ 36 | INT S_flushcache_max_gap(void) { 37 | return l1_max_cache_line_size; 38 | } 39 | 40 | void S_doflush(uptr start, uptr end) { 41 | #ifdef DEBUG 42 | printf(" doflush(%x, %x)\n", start, end); fflush(stdout); 43 | #endif 44 | 45 | #ifdef TARGET_OS_IPHONE 46 | sys_icache_invalidate((void *)start, (char *)end-(char *)start); 47 | #else 48 | __clear_cache((char *)start, (char *)end); 49 | # if defined(__clang__) && defined(__aarch64__) && !defined(__APPLE__) 50 | /* Seem to need an extra combination of barriers here to make up for 51 | something in Clang's __clear_cache() */ 52 | asm volatile ("dsb ish\n\t" 53 | "isb" 54 | : : : "memory"); 55 | # endif 56 | #endif 57 | } 58 | 59 | void S_machine_init(void) { 60 | int l1_dcache_line_size, l1_icache_line_size; 61 | 62 | #if defined(__linux__) && defined(_SC_LEVEL1_DCACHE_LINESIZE) 63 | if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0) { 64 | l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; 65 | } 66 | if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0) { 67 | l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; 68 | } 69 | #else 70 | l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; 71 | l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; 72 | #endif 73 | 74 | l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size; 75 | } 76 | -------------------------------------------------------------------------------- /c/compress-io.h: -------------------------------------------------------------------------------- 1 | /* compress-io.h 2 | * Copyright 1984-2019 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | typedef struct glzFile_r { 18 | INT fd; 19 | IBOOL inputp; 20 | INT format; 21 | union { 22 | struct gzFile_s *gz; 23 | struct lz4File_in_r *lz4_in; 24 | struct lz4File_out_r *lz4_out; 25 | }; 26 | } *glzFile; 27 | -------------------------------------------------------------------------------- /c/cs.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/c/cs.ico -------------------------------------------------------------------------------- /c/flushcache.c: -------------------------------------------------------------------------------- 1 | /* flushcache.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #include "system.h" 18 | 19 | #ifdef FLUSHCACHE 20 | typedef struct { 21 | uptr start; 22 | uptr end; 23 | } mod_range; 24 | 25 | #define mod_range_start(x) (((mod_range *)&BVIT(x,0))->start) 26 | #define mod_range_end(x) (((mod_range *)&BVIT(x,0))->end) 27 | 28 | static uptr max_gap; 29 | 30 | static ptr make_mod_range(ptr tc, uptr start, uptr end); 31 | 32 | static ptr make_mod_range(ptr tc, uptr start, uptr end) { 33 | ptr bv = S_bytevector2(tc, sizeof(mod_range), space_new); 34 | mod_range_start(bv) = start; 35 | mod_range_end(bv) = end; 36 | return bv; 37 | } 38 | 39 | /* we record info per thread so flush in one prematurely for another doesn't prevent 40 | the other from doing its own flush...and also since it's not clear that flushing in one 41 | actually syncs caches across cores & processors */ 42 | 43 | void S_record_code_mod(ptr tc, uptr addr, uptr bytes) { 44 | uptr end = addr + bytes; 45 | ptr ls = CODERANGESTOFLUSH(tc); 46 | 47 | if (ls != Snil) { 48 | ptr last_mod = Scar(ls); 49 | uptr last_end = mod_range_end(last_mod); 50 | if (addr > last_end && addr - last_end < max_gap) { 51 | #ifdef DEBUG 52 | printf(" record_code_mod merging %x %x and %x %x\n", mod_range_start(last_mod), last_end, addr, end); fflush(stdout); 53 | #endif 54 | mod_range_end(last_mod) = end; 55 | return; 56 | } 57 | } 58 | 59 | #ifdef DEBUG 60 | printf(" record_code_mod new range %x to %x\n", addr, end); fflush(stdout); 61 | #endif 62 | CODERANGESTOFLUSH(tc) = S_cons_in(tc, space_new, 0, make_mod_range(tc, addr, end), ls); 63 | return; 64 | } 65 | 66 | extern void S_flush_instruction_cache(ptr tc) { 67 | ptr ls; 68 | 69 | for (ls = CODERANGESTOFLUSH(tc); ls != Snil; ls = Scdr(ls)) { 70 | S_doflush(mod_range_start(Scar(ls)), mod_range_end(Scar(ls))); 71 | } 72 | CODERANGESTOFLUSH(tc) = Snil; 73 | } 74 | 75 | extern void S_flushcache_init(void) { 76 | if (S_boot_time) { 77 | max_gap = S_flushcache_max_gap(); 78 | if (max_gap < (uptr)(code_data_disp + byte_alignment)) { 79 | max_gap = (uptr)(code_data_disp + byte_alignment); 80 | } 81 | } 82 | } 83 | #else /* FLUSHCACHE */ 84 | 85 | extern void S_record_code_mod(UNUSED ptr tc, UNUSED uptr addr, UNUSED uptr bytes) {} 86 | extern void S_flush_instruction_cache(UNUSED ptr tc) {} 87 | extern void S_flushcache_init(void) { return; } 88 | 89 | #endif /* FLUSHCACHE */ 90 | -------------------------------------------------------------------------------- /c/gc-011.c: -------------------------------------------------------------------------------- 1 | /* gc-011.c 2 | * Copyright 1984-2020 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #define GCENTRY S_gc_011_entry 18 | #define MAX_CG 0 19 | #define MIN_TG 1 20 | #define MAX_TG 1 21 | #define NO_NEWSPACE_MARKS 22 | #include "gc.c" 23 | 24 | void S_gc_011(ptr tc) { 25 | (void)S_gc_011_entry(tc, Sfalse); 26 | } 27 | -------------------------------------------------------------------------------- /c/gc-ocd.c: -------------------------------------------------------------------------------- 1 | /* gc-ocd.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #define GCENTRY S_gc_ocd_entry 18 | #include "gc.c" 19 | 20 | ptr S_gc_ocd(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) { 21 | MAX_CG = max_cg; 22 | MIN_TG = min_tg; 23 | MAX_TG = max_tg; 24 | 25 | return S_gc_ocd_entry(tc, count_roots); 26 | } 27 | -------------------------------------------------------------------------------- /c/gc-oce.c: -------------------------------------------------------------------------------- 1 | /* gc-oce.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #define GCENTRY S_gc_oce_entry 18 | #define ENABLE_OBJECT_COUNTS 19 | #define ENABLE_BACKREFERENCE 20 | #define ENABLE_MEASURE 21 | /* #define ENABLE_PARALLEL - could enable to preserve owenrship/creator information */ 22 | #include "gc.c" 23 | 24 | ptr S_gc_oce(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) { 25 | MAX_CG = max_cg; 26 | MIN_TG = min_tg; 27 | MAX_TG = max_tg; 28 | 29 | return S_gc_oce_entry(tc, count_roots); 30 | } 31 | -------------------------------------------------------------------------------- /c/gc-par.c: -------------------------------------------------------------------------------- 1 | /* gc-par.c 2 | */ 3 | 4 | #define GCENTRY S_gc_par_entry 5 | #define ENABLE_PARALLEL 6 | #include "gc.c" 7 | 8 | ptr S_gc_par(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) { 9 | MAX_CG = max_cg; 10 | MIN_TG = min_tg; 11 | MAX_TG = max_tg; 12 | 13 | return S_gc_par_entry(tc, count_roots); 14 | } 15 | -------------------------------------------------------------------------------- /c/i3le.c: -------------------------------------------------------------------------------- 1 | /* i3le.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #include "system.h" 18 | 19 | #include 20 | #include 21 | 22 | #ifdef FLUSHCACHE 23 | oops, no S_flushcache_max_gap or S_doflush 24 | #endif /* FLUSHCACHE */ 25 | 26 | void S_machine_init(void) {} 27 | -------------------------------------------------------------------------------- /c/lib.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (provide replace 4 | glob-split) 5 | 6 | (define (replace a alist) 7 | (define old-a (assoc (car a) alist)) 8 | (cons a (if old-a (remove old-a alist) alist))) 9 | 10 | (define (glob-split glob str) 11 | (define match? (glob->matcher glob)) 12 | (let loop ([i 0]) 13 | (cond 14 | [(= i (string-length str)) #f] 15 | [(match? (substring str i)) (cons (substring str 0 i) (substring str i))] 16 | [else (loop (+ i 1))]))) 17 | -------------------------------------------------------------------------------- /c/nocurses.h: -------------------------------------------------------------------------------- 1 | #ifndef ERR 2 | # define ERR -1 3 | #endif 4 | 5 | #define setupterm(a, b, e) (*(e) = 0, ERR) 6 | #define tputs(c, x, f) (f(c)) 7 | 8 | #define lines 0 9 | #define columns 0 10 | 11 | #define cursor_left 0 12 | #define cursor_right 0 13 | #define cursor_up 0 14 | #define cursor_down 0 15 | #define enter_am_mode 0 16 | #define exit_am_mode 0 17 | #define clr_eos 0 18 | #define clr_eol 0 19 | #define clear_screen 0 20 | #define carriage_return 0 21 | #define bell 0 22 | #define scroll_reverse 0 23 | #define auto_right_margin 0 24 | #define eat_newline_glitch 0 25 | -------------------------------------------------------------------------------- /c/popcount.h: -------------------------------------------------------------------------------- 1 | 2 | #if __GNUC__ >= 5 3 | static int Spopcount_32(U32 x) 4 | { 5 | return __builtin_popcount(x); 6 | } 7 | #else 8 | static int Spopcount_32(U32 x) 9 | { 10 | /* http://bits.stephan-brumme.com/countBits.html */ 11 | /* count bits of each 2-bit chunk */ 12 | x = x - ((x >> 1) & 0x55555555); 13 | /* count bits of each 4-bit chunk */ 14 | x = (x & 0x33333333) + ((x >> 2) & 0x33333333); 15 | /* count bits of each 8-bit chunk */ 16 | x = x + (x >> 4); 17 | /* mask out junk */ 18 | x &= 0xF0F0F0F; 19 | /* add all four 8-bit chunks */ 20 | return (x * 0x01010101) >> 24; 21 | } 22 | #endif 23 | 24 | #if ptr_bits == 32 25 | static int Spopcount(uptr x) 26 | { 27 | return Spopcount_32((U32)x); 28 | } 29 | #elif ptr_bits == 64 30 | static int Spopcount(uptr x) 31 | { 32 | return Spopcount_32((U32)(x & 0xFFFFFFFF)) + Spopcount_32((U32)(x >> 32)); 33 | } 34 | #endif 35 | 36 | -------------------------------------------------------------------------------- /c/ppc32.c: -------------------------------------------------------------------------------- 1 | /* ppc32.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #include "system.h" 18 | 19 | #include 20 | #include 21 | 22 | /* NB: when sysconf isn't helpful, hardcoding data max cache line size from PowerMac G4. 23 | * NB: this may cause illegal instruction error on machines with smaller cache line sizes. Also, it 24 | * NB: will make invalidating the caches slower on machines with larger cache line sizes. */ 25 | #define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32 26 | 27 | static int l1_dcache_line_size, l1_icache_line_size, l1_max_cache_line_size; 28 | 29 | /* flushcache_max_gap is the maximum gap between unmerged chunks of memory to be flushed */ 30 | INT S_flushcache_max_gap(void) { 31 | return l1_max_cache_line_size; 32 | } 33 | 34 | void S_doflush(uptr start, uptr end) { 35 | uptr i; 36 | 37 | #ifdef DEBUG 38 | printf(" doflush(%x, %x)\n", start, end); fflush(stdout); 39 | #endif 40 | 41 | start &= ~(l1_max_cache_line_size - 1); 42 | end = (end + l1_max_cache_line_size - 1) & ~(l1_max_cache_line_size - 1); 43 | 44 | for(i = start; i < end; i += l1_dcache_line_size) { 45 | __asm__ __volatile__ ("dcbst 0, %0" :: "r" (i)); 46 | } 47 | __asm__ __volatile__ ("sync"); 48 | 49 | for(i = start; i < end; i += l1_icache_line_size) { 50 | __asm__ __volatile__ ("icbi 0, %0" :: "r" (i)); 51 | } 52 | __asm__ __volatile__ ("sync ; isync"); 53 | } 54 | 55 | void S_machine_init(void) { 56 | #if defined(__linux__) 57 | if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0) { 58 | l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; 59 | } 60 | if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0) { 61 | l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; 62 | } 63 | #else 64 | l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; 65 | l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; 66 | #endif 67 | l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size; 68 | } 69 | -------------------------------------------------------------------------------- /c/scheme.exe.manifest: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /c/scheme.rc: -------------------------------------------------------------------------------- 1 | #include "winver.h" 2 | 3 | VS_VERSION_INFO VERSIONINFO 4 | FILEVERSION 9,9,9,0 5 | PRODUCTVERSION 9,9,9,0 6 | FILEFLAGSMASK 0x3fL 7 | FILEFLAGS 0x0L 8 | FILEOS VOS__WINDOWS32 9 | FILETYPE VFT_APP 10 | FILESUBTYPE VFT2_UNKNOWN 11 | { 12 | BLOCK "StringFileInfo" { 13 | BLOCK "04090000" { 14 | VALUE "CompanyName", "Cisco Systems, Inc." 15 | VALUE "FileDescription", "Chez Scheme Version 9.9.9" 16 | VALUE "FileVersion", "9.9.9" 17 | VALUE "InternalName", "scheme.exe" 18 | VALUE "LegalCopyright", "Copyright 1984-2023 Cisco Systems, Inc. Licensed under the Apache License, Version 2.0." 19 | VALUE "OriginalFilename", "scheme.exe" 20 | VALUE "ProductName", "Chez Scheme" 21 | VALUE "ProductVersion", "9.9.9" 22 | } 23 | } 24 | BLOCK "VarFileInfo" { 25 | VALUE "Translation", 0x409, 0 26 | } 27 | } 28 | 29 | scheme ICON "cs.ico" 30 | -------------------------------------------------------------------------------- /c/sort.h: -------------------------------------------------------------------------------- 1 | /* sort.h 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #define mkmergesort(sort, merge, type, nil, lt, cdr)\ 18 | type sort(type ls, uptr len) {\ 19 | if (len == 1) {\ 20 | cdr(ls) = nil;\ 21 | return ls;\ 22 | } else {\ 23 | uptr head_len, i; type tail;\ 24 | head_len = len >> 1;\ 25 | for (tail = ls, i = head_len; i != 0; i -= 1) tail = cdr(tail);\ 26 | return merge(sort(ls, head_len), sort(tail, len - head_len));\ 27 | }\ 28 | }\ 29 | type merge(type ls1, type ls2) {\ 30 | type p; type *pp = &p;\ 31 | for (;;) {\ 32 | if (ls1 == nil) { *pp = ls2; break; }\ 33 | if (ls2 == nil) { *pp = ls1; break; }\ 34 | if (lt(ls2, ls1))\ 35 | { *pp = ls2; pp = &cdr(ls2); ls2 = cdr(ls2); }\ 36 | else\ 37 | { *pp = ls1; pp = &cdr(ls1); ls1 = cdr(ls1); }\ 38 | }\ 39 | return p;\ 40 | } 41 | -------------------------------------------------------------------------------- /c/statics.c: -------------------------------------------------------------------------------- 1 | /* statics.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #define EXTERN 18 | #include "system.h" 19 | 20 | /* The C linker may require a reference to a function to pull in all 21 | the common declarations. */ 22 | #include "externs.h" 23 | void scheme_statics(void) { } 24 | -------------------------------------------------------------------------------- /c/symbol.c: -------------------------------------------------------------------------------- 1 | /* symbol.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #include "system.h" 18 | 19 | ptr S_symbol_value(ptr sym) { 20 | if (SYMVAL(sym) == sunbound) 21 | S_error1("","~s is not bound", sym); 22 | return SYMVAL(sym); 23 | } 24 | 25 | ptr S_symbol_racy_value(ptr sym) NO_THREAD_SANITIZE { 26 | return SYMVAL(sym); 27 | } 28 | 29 | void S_set_symbol_value(ptr sym, ptr val) { 30 | SETSYMVAL(sym, val); 31 | SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : S_G.nonprocedure_code); 32 | } 33 | -------------------------------------------------------------------------------- /c/system.h: -------------------------------------------------------------------------------- 1 | /* system.h 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #include "scheme.h" 18 | #include "equates.h" 19 | #ifdef FEATURE_WINDOWS 20 | #ifdef __MINGW32__ 21 | # undef WINVER 22 | # undef _WIN32_WINNT 23 | #endif 24 | #define WINVER 0x0601 // Windows 7 25 | #define _WIN32_WINNT WINVER 26 | #include 27 | #endif 28 | 29 | #include "version.h" 30 | #include 31 | #include 32 | 33 | #include "thread.h" 34 | 35 | #include "types.h" 36 | 37 | #include "compress-io.h" 38 | 39 | #ifndef EXTERN 40 | #define EXTERN extern 41 | #endif 42 | #include "globals.h" 43 | 44 | #include "externs.h" 45 | 46 | #include "segment.h" 47 | 48 | #include "atomic.h" 49 | -------------------------------------------------------------------------------- /c/vs.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | set Applications=%ProgramFiles(x86)% 3 | if not "%Applications%" == "" goto win64 4 | set Applications=%ProgramFiles% 5 | :win64 6 | 7 | :: Set up Visual Studio command line environment variables given a 8 | :: machine type, e.g., amd64 or x86. 9 | 10 | :: Visual Studio 2022 Enterprise 11 | set BATDIR=%ProgramW6432%\Microsoft Visual Studio\2022\Enterprise\VC\Auxiliary\Build 12 | if exist "%BATDIR%\vcvarsall.bat" goto found 13 | 14 | :: Visual Studio 2022 Professional 15 | set BATDIR=%ProgramW6432%\Microsoft Visual Studio\2022\Professional\VC\Auxiliary\Build 16 | if exist "%BATDIR%\vcvarsall.bat" goto found 17 | 18 | :: Visual Studio 2022 Community 19 | set BATDIR=%ProgramW6432%\Microsoft Visual Studio\2022\Community\VC\Auxiliary\Build 20 | if exist "%BATDIR%\vcvarsall.bat" goto found 21 | 22 | :: Visual Studio 2019 Enterprise 23 | set BATDIR=%Applications%\Microsoft Visual Studio\2019\Enterprise\VC\Auxiliary\Build 24 | if exist "%BATDIR%\vcvarsall.bat" goto found 25 | 26 | :: Visual Studio 2019 Professional 27 | set BATDIR=%Applications%\Microsoft Visual Studio\2019\Professional\VC\Auxiliary\Build 28 | if exist "%BATDIR%\vcvarsall.bat" goto found 29 | 30 | :: Visual Studio 2019 Community 31 | set BATDIR=%Applications%\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build 32 | if exist "%BATDIR%\vcvarsall.bat" goto found 33 | 34 | :: Visual Studio 2019 BuildTools 35 | set BATDIR=%Applications%\Microsoft Visual Studio\2019\BuildTools\VC\Auxiliary\Build 36 | if exist "%BATDIR%\vcvarsall.bat" goto found 37 | 38 | :: Visual Studio 2017 Enterprise 39 | set BATDIR=%Applications%\Microsoft Visual Studio\2017\Enterprise\VC\Auxiliary\Build 40 | if exist "%BATDIR%\vcvarsall.bat" goto found 41 | 42 | :: Visual Studio 2017 Professional 43 | set BATDIR=%Applications%\Microsoft Visual Studio\2017\Professional\VC\Auxiliary\Build 44 | if exist "%BATDIR%\vcvarsall.bat" goto found 45 | 46 | :: Visual Studio 2017 Community 47 | set BATDIR=%Applications%\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build 48 | if exist "%BATDIR%\vcvarsall.bat" goto found 49 | 50 | :: Visual Studio 2017 BuildTools 51 | set BATDIR=%Applications%\Microsoft Visual Studio\2017\BuildTools\VC\Auxiliary\Build 52 | if exist "%BATDIR%\vcvarsall.bat" goto found 53 | 54 | :: Visual Studio 2015 55 | set BATDIR=%VS140COMNTOOLS%..\..\VC 56 | if exist "%BATDIR%\vcvarsall.bat" goto found 57 | 58 | echo Visual Studio 2022, 2019, 2017, or 2015 must be installed. 59 | exit 1 60 | 61 | :found 62 | 63 | :: Clear environment variables that we might otherwise inherit 64 | set INCLUDE= 65 | set LIB= 66 | set LIBPATH= 67 | 68 | :: Visual Studio 2017's vcvarsall.bat changes the directory to %USERPROFILE%\Source if the directory exists. See https://developercommunity.visualstudio.com/content/problem/26780/vsdevcmdbat-changes-the-current-working-directory.html 69 | set VSCMD_START_DIR=%CD% 70 | "%BATDIR%\vcvarsall.bat" %1 71 | -------------------------------------------------------------------------------- /c/winlib.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (provide build-zlib 4 | build-lz4) 5 | 6 | (define (build-zlib zlib-dir dll?) 7 | (define options (hash 'dir zlib-dir)) 8 | (shell/wait (~a "nmake /nologo -f win32/Makefile.msc AR=\"link /lib\"" 9 | (if dll? 10 | "" 11 | " CFLAGS=\"-nologo -MT -O2\"") 12 | " zlib.lib") 13 | options)) 14 | 15 | (define (build-lz4 lz4-lib-dir config) 16 | (define .cs (map (lambda (.c) 17 | (build-path lz4-lib-dir .c)) 18 | '("lz4.c" "lz4frame.c" "lz4hc.c" "xxhash.c"))) 19 | (define .os (map .c->.o .cs)) 20 | (map (lambda (.c .o) 21 | (c-compile .o .c config)) 22 | .cs 23 | .os) 24 | (c-ar (build-path lz4-lib-dir "liblz4.lib") 25 | .os 26 | config)) 27 | -------------------------------------------------------------------------------- /csug/bibliography.stex: -------------------------------------------------------------------------------- 1 | % Copyright 2005-2017 Cisco Systems, Inc. 2 | % 3 | % Licensed under the Apache License, Version 2.0 (the "License"); 4 | % you may not use this file except in compliance with the License. 5 | % You may obtain a copy of the License at 6 | % 7 | % http://www.apache.org/licenses/LICENSE-2.0 8 | % 9 | % Unless required by applicable law or agreed to in writing, software 10 | % distributed under the License is distributed on an "AS IS" BASIS, 11 | % WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | % See the License for the specific language governing permissions and 13 | % limitations under the License. 14 | \ifhtml 15 | \chapter{Bibliography} 16 | \input{csug.bbl} 17 | \else 18 | \bibliographystyle{tspl} 19 | \bibliography{csug} 20 | \fi 21 | -------------------------------------------------------------------------------- /csug/canned/about.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | About CSUG9 4 | 5 | 6 | 7 | 8 |

9 | The printed version of this book was created with LaTeX from extended 10 | LaTeX sources with the help of a preprocessor written in Scheme. 11 | The preprocessor handles extensions for incorporating arbitrary 12 | verbatim Scheme code and various other features not directly supported 13 | by LaTeX. 14 |

15 | 16 |

17 | The HTML version was created from the preprocessed sources for the 18 | printed version by a separate Scheme program that performs a LaTeX to 19 | HTML conversion. 20 | In addition to the extended LaTeX source files, this program takes as 21 | input the .aux and .bbl files produced by a complete LaTeX/BibTeX run 22 | of the document in order to support labels and page references in the 23 | text, summary of forms, and index. 24 | As it runs, the program produces a .haux file containing urls for the 25 | labels, bibliographic entries, and index entries; as with LaTeX, a 26 | second run of the program is needed to achieve proper 27 | cross-referencing. 28 |

29 | 30 |

31 | Most of the images and certain mathematical formulas included in the 32 | HTML version were produced with the help of LaTeX, dvips, ghostscript, 33 | and various programs from the netpbm library. 34 |

35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /csug/canned/cisco-logo-large.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/csug/canned/cisco-logo-large.png -------------------------------------------------------------------------------- /csug/canned/cisco-logo-orig.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/csug/canned/cisco-logo-orig.png -------------------------------------------------------------------------------- /csug/canned/cisco-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/csug/canned/cisco-logo.png -------------------------------------------------------------------------------- /csug/canned/copyright.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Copyright Notice 4 | 5 | 6 | 7 | 8 |

9 | © 2005-2015 Cisco Systems, Inc.
10 | Licensed under the Apache License Version 2.0.
11 | Revised April 2016 for Chez Scheme Version 9.3.4. 12 |

13 | 14 |

15 | Cisco and the Cisco logo are trademarks or registered trademarks 16 | of Cisco and/or its affiliates in the U.S. and other countries. To 17 | view a list of Cisco trademarks, go to this URL: 18 | http://www.cisco.com/go/trademarks. Third-party trademarks mentioned 19 | are the property of their respective owners. The use of the word 20 | partner does not imply a partnership relationship between Cisco and 21 | any other company. (1110R) 22 |

23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /csug/canned/csug.css: -------------------------------------------------------------------------------- 1 | BODY {background-color: #FFFFFF} 2 | 3 | a:link, a:active, a:visited { color:#005568; text-decoration:underline } 4 | a:hover { color:white; text-decoration:underline; background:#005568 } 5 | 6 | a.plain:link, a.plain:active, a.plain:visited { color:#005568; text-decoration:none } 7 | a.plain:hover { color:white; text-decoration:none; background:#005568 } 8 | 9 | a.toc:link, a.toc:active, a.toc:visited {font-family: sans-serif; color:#005568; text-decoration:none} 10 | a.toc:hover {font-family: sans-serif; color:white; text-decoration:none; background:#005568} 11 | 12 | a.image:link, a.image:active, a.image:visited, a.image:hover { 13 | color: #005568; 14 | background: #FFFFFF; 15 | } 16 | 17 | ul.tocchapter { list-style: none; } 18 | ul.tocsection { list-style: circle; color: #C41230 } 19 | 20 | hr.copyright { width: 50% } 21 | 22 | input.default { background: #ffffff; color: #000000; vertical-align: middle} 23 | 24 | h1, h2, h3, h4 {font-family: sans-serif; color: #005568} 25 | h1 {font-size: 2em} 26 | h2 {margin-top: 30px; font-size: 1.5em} 27 | h3 {margin-top: 30px; font-size: 1.17em} 28 | h1, h2, h3, h4 {font-weight: bold} 29 | 30 | .title { font-family: sans-serif; font-weight: bold; font-size: 2.5em; color: #005568; white-space: nowrap} 31 | 32 | .formdef { color: #005568 } 33 | 34 | table.indent {margin-left: 20px} 35 | 36 | -------------------------------------------------------------------------------- /csug/canned/fatfibhtml-orig.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/csug/canned/fatfibhtml-orig.png -------------------------------------------------------------------------------- /csug/canned/fatfibhtml.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/csug/canned/fatfibhtml.png -------------------------------------------------------------------------------- /csug/canned/profilehtml-orig.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/csug/canned/profilehtml-orig.png -------------------------------------------------------------------------------- /csug/canned/profilehtml.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/csug/canned/profilehtml.png -------------------------------------------------------------------------------- /csug/canned/profview.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/csug/canned/profview.png -------------------------------------------------------------------------------- /csug/contents.stex: -------------------------------------------------------------------------------- 1 | % Copyright 2005-2017 Cisco Systems, Inc. 2 | % 3 | % Licensed under the Apache License, Version 2.0 (the "License"); 4 | % you may not use this file except in compliance with the License. 5 | % You may obtain a copy of the License at 6 | % 7 | % http://www.apache.org/licenses/LICENSE-2.0 8 | % 9 | % Unless required by applicable law or agreed to in writing, software 10 | % distributed under the License is distributed on an "AS IS" BASIS, 11 | % WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | % See the License for the specific language governing permissions and 13 | % limitations under the License. 14 | \iflatex 15 | \begingroup 16 | \baselineskip=15pt plus 1pt 17 | \normalbaselineskip=\baselineskip 18 | \renewcommand{\baselinestretch}{1.5} 19 | \tableofcontents 20 | \endgroup 21 | \fi 22 | 23 | \ifhtml 24 | \begin{contents} 25 | \fi 26 | -------------------------------------------------------------------------------- /csug/copyright.stex: -------------------------------------------------------------------------------- 1 | % Copyright 2005-2018 Cisco Systems, Inc. 2 | % 3 | % Licensed under the Apache License, Version 2.0 (the "License"); 4 | % you may not use this file except in compliance with the License. 5 | % You may obtain a copy of the License at 6 | % 7 | % http://www.apache.org/licenses/LICENSE-2.0 8 | % 9 | % Unless required by applicable law or agreed to in writing, software 10 | % distributed under the License is distributed on an "AS IS" BASIS, 11 | % WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | % See the License for the specific language governing permissions and 13 | % limitations under the License. 14 | \iflatex 15 | \thispagestyle{empty} 16 | 17 | \centerline{}\vfill 18 | 19 | \textbf{\copyright~2023 Cisco Systems, Inc.} 20 | 21 | Licensed under the Apache License Version 2.0\\ 22 | http://www.apache.org/licenses/LICENSE-2.0 23 | 24 | % NB: also update corresponding notice in csug.stex 25 | Revised \revisiondate~for \CSVersion. 26 | 27 | \medskip\noindent 28 | Cisco and the Cisco logo are trademarks or registered trademarks 29 | of Cisco and/or its affiliates in the U.S. and other countries. To 30 | view a list of Cisco trademarks, go to this URL: 31 | http://www.cisco.com/go/trademarks. Third-party trademarks mentioned 32 | are the property of their respective owners. The use of the word 33 | partner does not imply a partnership relationship between Cisco and 34 | any other company. (1110R) 35 | 36 | \vspace{1in}\break 37 | \fi 38 | -------------------------------------------------------------------------------- /csug/csug.css: -------------------------------------------------------------------------------- 1 | BODY {background-color: #FFFFFF} 2 | 3 | a:link, a:active, a:visited { color:#005568; text-decoration:underline } 4 | a:hover { color:white; text-decoration:underline; background:#005568 } 5 | 6 | a.plain:link, a.plain:active, a.plain:visited { color:#005568; text-decoration:none } 7 | a.plain:hover { color:white; text-decoration:none; background:#005568 } 8 | 9 | a.toc:link, a.toc:active, a.toc:visited {font-family: sans-serif; color:#005568; text-decoration:none} 10 | a.toc:hover {font-family: sans-serif; color:white; text-decoration:none; background:#005568} 11 | 12 | a.image:link, a.image:active, a.image:visited, a.image:hover { 13 | color: #005568; 14 | background: #FFFFFF; 15 | } 16 | 17 | ul.tocchapter { list-style: none; } 18 | ul.tocsection { list-style: circle; color: #C41230 } 19 | 20 | hr.copyright { width: 50% } 21 | 22 | input.default { background: #ffffff; color: #000000; vertical-align: middle} 23 | 24 | h1, h2, h3, h4 {font-family: sans-serif; color: #005568} 25 | h1 {font-size: 2em} 26 | h2 {margin-top: 30px; font-size: 1.5em} 27 | h3 {margin-top: 30px; font-size: 1.17em} 28 | h1, h2, h3, h4 {font-weight: bold} 29 | 30 | .title { font-family: sans-serif; font-weight: bold; font-size: 2.5em; color: #005568; white-space: nowrap} 31 | 32 | .formdef { color: #005568 } 33 | 34 | table.indent {margin-left: 20px} 35 | 36 | -------------------------------------------------------------------------------- /csug/docond.ss: -------------------------------------------------------------------------------- 1 | (define docond-ht (make-eq-hashtable)) 2 | (hashtable-set! docond-ht '&condition '()) 3 | (define (docond expr) 4 | (syntax-case expr (define-condition-type) 5 | [(define-condition-type &name &parent make-name name? 6 | (field-name field-accessor) ...) 7 | (let ([pfields (hashtable-ref docond-ht #'&parent #f)]) 8 | (unless pfields (error 'docond "unrecognized parent ~s" #'&parent)) 9 | (printf "\\formdef{~s}{\\categorysyntax}{~s}\n" #'&name #'&name) 10 | (let ([fields (append pfields #'(field-name ...))]) 11 | (printf "\\formdef{~s}{\\categoryprocedure}{(~s~{ \\var{~s}~})}\n" 12 | #'make-name #'make-name fields) 13 | (hashtable-set! docond-ht #'&name fields)) 14 | (printf "\\returns a condition of type \\scheme{~s}\n" #'&name) 15 | (printf "\\formdef{~s}{\\categoryprocedure}{(~s \\var{obj})}\n" #'name? #'name?) 16 | (printf "\\returns \\scheme{#t} if \\var{obj} is a condition of type \\scheme{~s}, \\scheme{#f} otherwise\n" 17 | #'&name) 18 | (for-each 19 | (lambda (field get-field) 20 | (printf "\\formdef{~s}{\\categoryprocedure}{(~s \\var{condition})}\n" get-field get-field) 21 | (printf "\\returns the contents of \\var{condition}'s \\scheme{~s} field\n" field)) 22 | #'(field-name ...) 23 | #'(field-accessor ...)) 24 | (printf "\\listlibraries\n"))])) 25 | -------------------------------------------------------------------------------- /csug/myfile.ss: -------------------------------------------------------------------------------- 1 | (+ 3 4) 2 | "hello" 3 | -------------------------------------------------------------------------------- /csug/oop.stex: -------------------------------------------------------------------------------- 1 | % Copyright 2005-2017 Cisco Systems, Inc. 2 | % 3 | % Licensed under the Apache License, Version 2.0 (the "License"); 4 | % you may not use this file except in compliance with the License. 5 | % You may obtain a copy of the License at 6 | % 7 | % http://www.apache.org/licenses/LICENSE-2.0 8 | % 9 | % Unless required by applicable law or agreed to in writing, software 10 | % distributed under the License is distributed on an "AS IS" BASIS, 11 | % WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | % See the License for the specific language governing permissions and 13 | % limitations under the License. 14 | % uncomment Thread System Oop Interface section in threads.stex 15 | -------------------------------------------------------------------------------- /csug/priminfo.ss: -------------------------------------------------------------------------------- 1 | ;;; priminfo.ss 2 | ;;; Copyright 2005-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (module priminfo (primvec get-libraries) 17 | 18 | (define prim-db (make-eq-hashtable)) 19 | 20 | (define primvec 21 | (lambda () 22 | (hashtable-keys prim-db))) 23 | 24 | (define get-libraries 25 | (lambda (name) 26 | (or (eq-hashtable-ref prim-db name #f) 27 | (errorf #f "unknown primitive ~s" name)))) 28 | 29 | (define put-priminfo! 30 | (lambda (prim lib*) 31 | (when (eq-hashtable-contains? prim-db prim) 32 | (warning 'define-symbol-type "extra entry for ~s" prim)) 33 | (eq-hashtable-set! prim-db prim lib*))) 34 | 35 | (define-syntax define-symbol-flags* 36 | (lambda (x) 37 | (syntax-case x (libraries) 38 | [(k ([libraries lib ...] [flags flag ...] ignore ...) entry ...) 39 | (or (memq 'system (datum (flag ...))) 40 | (memq 'system-keyword (datum (flag ...)))) 41 | #'(void)] 42 | [(k ([libraries] ignore ...) entry ...) 43 | #'(k ([libraries (chezscheme)] ignore ...) entry ...)] 44 | [(_ ([libraries lib ...] ignore ...) entry ...) 45 | (if (syntax-case #'(lib ...) (rnrs) 46 | [((rnrs x ...) y ...) #t] 47 | [_ #f]) 48 | #'(void) 49 | (let () 50 | (define do-entry 51 | (lambda (x) 52 | (syntax-case x () 53 | [((prefix prim) ignore ...) 54 | (and (identifier? #'prefix) (identifier? #'prim)) 55 | #'(put-priminfo! 'prim '(lib ...))] 56 | [(prim ignore ...) 57 | (identifier? #'prim) 58 | #'(put-priminfo! 'prim '(lib ...))]))) 59 | #`(begin #,@(map do-entry #'(entry ...)))))]))) 60 | 61 | (include "primdata.ss") 62 | ) 63 | -------------------------------------------------------------------------------- /csug/scheme.hsty: -------------------------------------------------------------------------------- 1 | \def\transerr#1{\raw{}} 2 | \def\transin#1{\raw{}} 3 | \def\transout#1{\raw{}} 4 | \def\endtranserr#1{\raw{}} 5 | \def\endtransin#1{\raw{}} 6 | \def\endtransout#1{\raw{}} 7 | 8 | \def\schemeblankline{{\\\\}} 9 | \def\schemelinestart{} 10 | %%% handle numbered lines in scheme.sty and scheme.hsty 11 | %%% ---have scheme-prep produce only \schemelinestart 12 | % following is probably broken until we have tables, I suspect. 13 | % Actually, the right way to fix this may be to use CSS 14 | \def\schemelinestartnumbered#1{\raw{
}#1\raw{
}} 15 | 16 | \def\scheme#1{{\tt #1}} 17 | \def\longcode\schemedisplay{\schemedisplay} 18 | \def\noskip\schemedisplay{\schemedisplay} 19 | \def\schemedisplay{\par\begingroup\tt\hardspaces} 20 | \def\endschemedisplay{\endgroup\par} 21 | \def\schemeindent{} 22 | \def\schatsign{\raw{@}} 23 | \def\schbackslash{\raw{\}} 24 | \def\schcarat{\raw{^}} 25 | \def\schdot{\raw{.}} 26 | \def\schlbrace{\raw{&##123;}} 27 | \def\schrbrace{\raw{&##125;}} 28 | \def\schtilde{\raw{~}} 29 | \def\schunderscore{\raw{_}} 30 | \def\becomes{$\rightarrow$} 31 | \def\is{$\Rightarrow$} 32 | \def\si{\raw{}} 33 | \def\var#1{\emph{#1}} 34 | -------------------------------------------------------------------------------- /csug/scheme.sty: -------------------------------------------------------------------------------- 1 | \usepackage{color} 2 | \def\transerr#1{\begingroup\slshape} 3 | \def\transin#1{\begingroup\color{red}} 4 | \def\transout#1{\begingroup\color{blue}} 5 | \def\traceout#1{\begingroup\color{blue}} 6 | \def\endtranserr#1{\endgroup} 7 | \def\endtransin#1{\endgroup} 8 | \def\endtransout#1{\endgroup} 9 | \def\endtraceout#1{\endgroup} 10 | 11 | % this didn't work --- screwed up indentation: 12 | \long\def\showinteraction#1#2{\begin{minipage}[t]{4.375in}#1\end{minipage}\hfill\fbox{\begin{minipage}[t]{2in}#2\end{minipage}}} 13 | % so I resorted to this: 14 | \def\startrepl{\begin{minipage}[t]{4.3in}} % was 4.375 and 2 when interactionwindow = 28 15 | \def\endrepl{\end{minipage}} 16 | \def\startinteraction{\begin{minipage}[t]{2.2in}\vrule\begin{minipage}[t]{2.2in}\hrule\schemeindent=2pt} 17 | \def\endinteraction{\hrule\end{minipage}\vrule\end{minipage}} 18 | 19 | \font\ninefivett=cmtt9 at 9.5pt 20 | \newskip\ttglue 21 | \ttglue=.5em plus .25em minus .15em 22 | \font\tinyvar=cmti7 23 | \font\smallvar=cmti9 24 | \font\summarysizevar=cmti9 25 | \font\indexsizevar=cmti8 26 | \font\normalvar=cmti10 at 11pt 27 | \def\schemelarge{% 28 | \def\schemelarger{\fontsize{14}{16}}% 29 | \def\schemesmaller{\fontsize{10}{12}}% 30 | \def\tt{\fontsize{12}{14}\ttfamily}% 31 | \def\var##1{{\normalvar##1\/}}} 32 | \def\schemenormal{% 33 | \def\schemelarger{\fontsize{12}{14}}% 34 | \def\schemesmaller{\fontsize{8}{9}}% 35 | \def\tt{\fontsize{10pt}{11pt}\ttfamily\ninefivett}% 36 | \def\var##1{{\smallvar##1\/}}} 37 | \def\schemesmall{% 38 | \def\schemelarger{\fontsize{10}{12}}% 39 | \def\schemesmaller{\fontsize{6}{7}}% 40 | \def\tt{\fontsize{8}{9}\ttfamily}% 41 | \def\var##1{{\smallvar##1\/}}} 42 | \def\schemesummarysize{% 43 | \def\schemelarger{\fontsize{10}{12}}% 44 | \def\schemesmaller{\fontsize{6}{7}}% 45 | \def\tt{\fontsize{8}{9}\ttfamily}% 46 | \def\var##1{{\summarysizevar##1\/}}} 47 | \def\schemeindexsize{% 48 | \def\schemelarger{\fontsize{10}{12}}% 49 | \def\schemesmaller{\fontsize{6}{7}}% 50 | \def\tt{\fontsize{7}{8}\ttfamily}% 51 | \def\var##1{{\indexsizevar##1\/}}} 52 | \schemenormal 53 | 54 | \newskip\schemeindent 55 | \schemeindent=0pt 56 | {\obeyspaces\global\let =\ } 57 | \def\schtilde{\raisebox{-.5ex}{\hbox{\char`\~}}} 58 | \def\schdot{.} 59 | \def\schcarat{\char`\^} 60 | \def\schbackslash{\char`\\} 61 | \def\schatsign{\char`\@} 62 | \def\schunderscore{\char`\_} 63 | \def\schlbrace{\char`\{} 64 | \def\schrbrace{\char`\}} 65 | \def\scheme#1{\mbox{\tt\frenchspacing\spaceskip=\ttglue#1}} 66 | 67 | \def\schemeblankline{\par\penalty-100\vskip .7\baselineskip} 68 | \def\schemelinestart{{\leavevmode\hbox{\hskip \schemeindent\relax}}} 69 | %%% handle numbered lines in scheme.sty and scheme.hsty 70 | %%% ---have scheme-prep produce only \schemelinestart 71 | \def\schemelinestartnumbered#1{{\leavevmode\hbox{\hbox to 1em {\hfil{\rm #1}} \hskip .5\schemeindent\relax}}} 72 | 73 | \def\noskip\schemedisplay{\begingroup% 74 | \parindent=0pt% 75 | \parskip=0pt% 76 | \def\becomes{\hbox to 2em{\hfil$\rightarrow$\hfil}}% 77 | \def\is{\hbox to 2em{\hfil$\Rightarrow$\hfil}}% 78 | \def\si{\hbox to 2em{\hfil}}% 79 | \interlinepenalty=2000% 80 | \tt\obeyspaces\frenchspacing} 81 | \def\schemedisplay{\beforeschemedisplay\noskip\schemedisplay} 82 | \def\longcode\schemedisplay{\penalty-200\vskip 8pt plus 4pt% 83 | \kern3pt\hrule\kern5pt\nobreak\noskip\schemedisplay} 84 | \def\endschemedisplay{\par\endgroup\afterschemedisplay} 85 | \def\var#1{{\normalsize\textrm{\textit{#1}}}} 86 | \def\raw#1{#1} 87 | \def\beforeschemedisplay{\penalty-100\vskip\parskip\vskip5pt} 88 | \def\afterschemedisplay{\penalty-200\vskip5pt} 89 | 90 | -------------------------------------------------------------------------------- /csug/setup.ss: -------------------------------------------------------------------------------- 1 | (reset-handler abort) 2 | -------------------------------------------------------------------------------- /csug/summary.ss: -------------------------------------------------------------------------------- 1 | (define read-string 2 | (lambda (ip) 3 | (unless (eqv? (read-char ip) #\") 4 | (error 'read-string "no starting double-quote")) 5 | (list->string 6 | (let f () 7 | (let ([c (read-char ip)]) 8 | (cond 9 | [(eqv? c #\") '()] 10 | [(or (eqv? c #\newline) (eof-object? c)) 11 | (error 'read-string "no ending double-quote")] 12 | [else (cons c (f))])))))) 13 | 14 | (define readrol 15 | (lambda (ip) 16 | (let ([c (read-char ip)]) 17 | (if (eq? c #\newline) 18 | '() 19 | (cons c (readrol ip)))))) 20 | 21 | (define read-line 22 | (lambda (ip) 23 | (if (eof-object? (peek-char ip)) 24 | (peek-char ip) 25 | (let ([x (read-string ip)]) 26 | (cons x (readrol ip)))))) 27 | 28 | (define summary-read 29 | (lambda (ip) 30 | (do ([ls '() (cons line ls)] 31 | [line (read-line ip) (read-line ip)]) 32 | ((eof-object? line) (reverse! ls))))) 33 | 34 | (define summary-sort 35 | (lambda (x) 36 | (sort! (lambda (x y) (string= (string-length line) 13 | (string-length prefix)) 14 | (string=? prefix (substring line 0 (string-length prefix)))) 15 | (let loop ([seps seps] [start (string-length prefix)]) 16 | (cond 17 | [(null? seps) '()] 18 | [else 19 | (let sloop ([i start]) 20 | (cond 21 | [(> i (- (string-length line) 22 | (string-length (car seps)))) 23 | #f] 24 | [(string=? (car seps) (substring line i (+ i (string-length (car seps))))) 25 | (cons (substring line start i) 26 | (loop (cdr seps) (+ i (string-length (car seps)))))] 27 | [else (sloop (+ i 1))]))]))] 28 | [else #f])) 29 | 30 | (for-each 31 | (lambda (f) 32 | (when (equal? "aux" (path-extension f)) 33 | (printf "Convert ~s\n" f) 34 | (call-with-input-file 35 | f 36 | (lambda (i) 37 | (with-output-to-file "tmp" 38 | (lambda () 39 | (let loop ([sec #f]) 40 | (let ([line (get-line i)]) 41 | (unless (eof-object? line) 42 | (cond 43 | [(line-match line 44 | "\\@writefile{toc}{\\contentsline {chapter}{\\numberline {" 45 | "}" 46 | "}") 47 | => (lambda (m) 48 | (display line) (newline) 49 | (loop (list (car m) (cadr m))))] 50 | [(line-match line 51 | "\\@writefile{toc}{\\contentsline {chapter}{" 52 | "}") 53 | => (lambda (m) 54 | (display line) (newline) 55 | (loop (list "" (car m))))] 56 | [(line-match line "\\newlabel") 57 | => (lambda (m) 58 | (display (string-append 59 | (substring line 0 (sub1 (string-length line))) 60 | "{" (or (car sec) "") "}" 61 | "{" (cadr sec) "}" 62 | "{}" 63 | "}")) 64 | (newline) 65 | (loop sec))] 66 | [else 67 | (display line) 68 | (newline) 69 | (loop sec)]))))) 70 | '(truncate)))) 71 | (rename-file "tmp" f))) 72 | (directory-list (current-directory))) 73 | -------------------------------------------------------------------------------- /csug/tspl4/tspl.aux: -------------------------------------------------------------------------------- 1 | \relax 2 | \@input{title.aux} 3 | \@input{copyright.aux} 4 | \@input{contents.aux} 5 | \@input{preface.aux} 6 | \@input{intro.aux} 7 | \@input{start.aux} 8 | \@input{further.aux} 9 | \@input{binding.aux} 10 | \@input{control.aux} 11 | \@input{objects.aux} 12 | \@input{io.aux} 13 | \@input{syntax.aux} 14 | \@input{records.aux} 15 | \@input{libraries.aux} 16 | \@input{exceptions.aux} 17 | \@input{examples.aux} 18 | \@input{bibliography.aux} 19 | \@input{answers.aux} 20 | \@input{grammar.aux} 21 | \@input{summary.aux} 22 | \@writefile{toc}{\contentsline {chapter}{Index}{481}} 23 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | # Unix make file to compile the examples. 2 | # Compilation is not necessary since the examples may be loaded from 3 | # source, but this gives an example of how to use make for Scheme. 4 | # * To compile files not already compiled, type "make". Only those 5 | # files in the object list below and not yet compiled will be compiled. 6 | # * To compile all files, type "make all". Only those files in the object 7 | # list below will be compiled. 8 | # * To compile one file, say "fumble.ss", type "make fumble.so". The 9 | # file need not be in the object list below. 10 | # * To remove the object files, type "make clean". 11 | # * To print the examples, type "make print". 12 | 13 | src = def.ss edit.ss fact.ss fatfib.ss fft.ss fib.ss freq.ss interpret.ss\ 14 | m4.ss macro.ss matrix.ss object.ss power.ss queue.ss rabbit.ss rsa.ss\ 15 | scons.ss setof.ss socket.ss unify.ss compat.ss ez-grammar-test.ss 16 | obj = ${src:%.ss=%.so} 17 | 18 | Scheme = ../bin/scheme 19 | SchemeArg = -q 20 | 21 | .SUFFIXES: 22 | .SUFFIXES: .ss .so 23 | .ss.so: ; echo '(time (compile-file "$*"))' | "${Scheme}" ${SchemeArg} 24 | 25 | needed: ${obj} 26 | 27 | all: ; echo "(time (for-each compile-file (map symbol->string '(${src}))))" | "${Scheme}" ${SchemeArg} 28 | 29 | clean: ; rm -f $(obj) expr.md 30 | -------------------------------------------------------------------------------- /examples/build.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | (require "../makefiles/lib.zuo") 3 | 4 | (provide-targets targets-at) 5 | 6 | (define (targets-at at-dir [vars (hash)]) 7 | (define config (config-file->hash (at-dir "../Mf-config") vars)) 8 | (define lookup (make-lookup config)) 9 | 10 | (define mf (config-file->hash (at-source "Makefile"))) 11 | 12 | (define m (lookup 'm)) 13 | (define host-m (or (lookup 'hostm) m)) 14 | (define host-workarea (let ([host-workarea (lookup 'hostworkarea)]) 15 | (if (equal? host-workarea "") 16 | "" 17 | ((make-at-dir (at-dir "..")) (or host-workarea "."))))) 18 | (define host-scheme (lookup 'hostscheme)) 19 | 20 | (define src-names (string-split (hash-ref mf 'src))) 21 | (define srcs (map at-source src-names)) 22 | (define objs (map (lambda (name) (at-dir (path-replace-extension name ".so"))) 23 | src-names)) 24 | 25 | (define-values (call-with-scheme run-scheme/status run-scheme) 26 | (make-run-scheme at-source at-dir lookup 27 | host-scheme host-workarea host-m)) 28 | 29 | (define (add-patchfile l) 30 | (if (and (string=? m host-m) 31 | (not (equal? (lookup 'cross) "t"))) 32 | l 33 | (append l (list (at-dir ".." "s" "xpatch"))))) 34 | 35 | (make-targets 36 | `([:target needed ,objs ,void] 37 | 38 | ,@(map (lambda (src obj) 39 | `[:target ,obj (,src ,(input-data-target 'version (source-version))) 40 | ,(lambda (path token) 41 | (run-scheme obj 42 | `((time (compile-file ,src ,obj))) 43 | (add-patchfile '())))]) 44 | srcs 45 | objs) 46 | 47 | [:target all () 48 | ,(lambda (token) 49 | (run-scheme "all" 50 | `((time (begin 51 | ,@(map (lambda (src obj) 52 | `(compile-file ,src ,obj)) 53 | srcs 54 | objs)))) 55 | (add-patchfile '())))] 56 | 57 | [:target clean () 58 | ,(lambda (token) 59 | (map rm* objs) 60 | (rm* "expr.md"))]))) 61 | -------------------------------------------------------------------------------- /examples/crepl.c: -------------------------------------------------------------------------------- 1 | /* crepl.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | /* 18 | This is a variant of main.c that implements a Scheme repl in C. 19 | It's not at all useful, but it highlights how to invoke Scheme 20 | without going through Sscheme_start. 21 | 22 | Test in a workarea's examples subdirectory with: 23 | 24 | ( cd ../c ; ln -sf ../examples/crepl.c . ) 25 | ( cd ../c ; make mainsrc=crepl.c ) 26 | sh -c 'SCHEMEHEAPDIRS=../boot/%m ../bin/scheme' 27 | */ 28 | 29 | #include "scheme.h" 30 | #include 31 | #include 32 | 33 | #define CALL0(who) Scall0(Stop_level_value(Sstring_to_symbol(who))) 34 | #define CALL1(who, arg) Scall1(Stop_level_value(Sstring_to_symbol(who)), arg) 35 | 36 | static void custom_init(void) {} 37 | 38 | int main(int argc, char *argv[]) { 39 | int n, new_argc = 1, ignoreflags = 0; 40 | ptr p; 41 | 42 | Sscheme_init(NULL); 43 | 44 | /* process command-line arguments, registering boot and heap files */ 45 | for (n = 1; n < argc; n += 1) { 46 | if (!ignoreflags && *argv[n] == '-') { 47 | switch (*(argv[n]+1)) { 48 | case '-': /* pass through remaining options */ 49 | if (*(argv[n]+2) != 0) break; 50 | ignoreflags = 1; 51 | continue; 52 | case 'b': /* boot option, expects boot file pathname */ 53 | if (*(argv[n]+2) != 0) break; 54 | if (++n == argc) { 55 | (void) fprintf(stderr,"\n-b option requires argument\n"); 56 | exit(1); 57 | } 58 | Sregister_boot_file(argv[n]); 59 | continue; 60 | default: 61 | break; 62 | } 63 | } 64 | argv[new_argc++] = argv[n]; 65 | } 66 | 67 | /* must call Sscheme_heap after registering boot and heap files 68 | * Sscheme_heap() completes the initialization of the Scheme system 69 | * and loads the boot or heap files. Before loading boot files, 70 | * it calls custom_init(). */ 71 | Sbuild_heap(argv[0], custom_init); 72 | 73 | for (;;) { 74 | CALL1("display", Sstring("* ")); 75 | p = CALL0("read"); 76 | if (Seof_objectp(p)) break; 77 | p = CALL1("eval", p); 78 | if (p != Svoid) CALL1("pretty-print", p); 79 | } 80 | CALL0("newline"); 81 | 82 | /* must call Scheme_deinit after saving the heap and before exiting */ 83 | Sscheme_deinit(); 84 | 85 | exit(0); 86 | } 87 | -------------------------------------------------------------------------------- /examples/csocket.c: -------------------------------------------------------------------------------- 1 | /*/ csocket.c 2 | R. Kent Dybvig May 1998 3 | Updated by Jamie Taylor, Sept 2016 4 | Public Domain 5 | /*/ 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | 17 | /* c_write attempts to write the entire buffer, pushing through 18 | interrupts, socket delays, and partial-buffer writes */ 19 | int c_write(int fd, char *buf, ssize_t start, ssize_t n) { 20 | ssize_t i, m; 21 | 22 | buf += start; 23 | m = n; 24 | while (m > 0) { 25 | if ((i = write(fd, buf, m)) < 0) { 26 | if (errno != EAGAIN && errno != EINTR) 27 | return i; 28 | } else { 29 | m -= i; 30 | buf += i; 31 | } 32 | } 33 | return n; 34 | } 35 | 36 | /* c_read pushes through interrupts and socket delays */ 37 | int c_read(int fd, char *buf, size_t start, size_t n) { 38 | int i; 39 | 40 | buf += start; 41 | for (;;) { 42 | i = read(fd, buf, n); 43 | if (i >= 0) return i; 44 | if (errno != EAGAIN && errno != EINTR) return -1; 45 | } 46 | } 47 | 48 | /* bytes_ready(fd) returns true if there are bytes available 49 | to be read from the socket identified by fd */ 50 | int bytes_ready(int fd) { 51 | int n; 52 | 53 | (void) ioctl(fd, FIONREAD, &n); 54 | return n; 55 | } 56 | 57 | /* socket support */ 58 | 59 | /* do_socket() creates a new AF_UNIX socket */ 60 | int do_socket(void) { 61 | 62 | return socket(AF_UNIX, SOCK_STREAM, 0); 63 | } 64 | 65 | /* do_bind(s, name) binds name to the socket s */ 66 | int do_bind(int s, char *name) { 67 | struct sockaddr_un sun; 68 | int length; 69 | 70 | sun.sun_family = AF_UNIX; 71 | (void) strcpy(sun.sun_path, name); 72 | length = sizeof(sun.sun_family) + sizeof(sun.sun_path); 73 | 74 | return bind(s, (struct sockaddr*)(&sun), length); 75 | } 76 | 77 | /* do_accept accepts a connection on socket s */ 78 | int do_accept(int s) { 79 | struct sockaddr_un sun; 80 | socklen_t length; 81 | 82 | length = sizeof(sun.sun_family) + sizeof(sun.sun_path); 83 | 84 | return accept(s, (struct sockaddr*)(&sun), &length); 85 | } 86 | 87 | /* do_connect initiates a socket connection */ 88 | int do_connect(int s, char *name) { 89 | struct sockaddr_un sun; 90 | int length; 91 | 92 | sun.sun_family = AF_UNIX; 93 | (void) strcpy(sun.sun_path, name); 94 | length = sizeof(sun.sun_family) + sizeof(sun.sun_path); 95 | 96 | return connect(s, (struct sockaddr*)(&sun), length); 97 | } 98 | 99 | /* get_error returns the operating system's error status */ 100 | char* get_error(void) { 101 | extern int errno; 102 | return strerror(errno); 103 | } 104 | -------------------------------------------------------------------------------- /examples/fact.ss: -------------------------------------------------------------------------------- 1 | ;;; simple factorial function 2 | 3 | ;;; it is interesting to change the 'lambda' into 'trace-lambda' 4 | ;;; or simply type (trace fact) before running fact to observe 5 | ;;; the nesting of recursive calls. 6 | 7 | (define fact 8 | (lambda (x) 9 | (if (zero? x) 10 | 1 11 | (* x (fact (1- x)))))) 12 | -------------------------------------------------------------------------------- /examples/fatfib.ss: -------------------------------------------------------------------------------- 1 | ;;; fat fibonacci function 2 | 3 | ;;; this is "fat" because it uses only increments and decrements 4 | ;;; for addition and subtraction (i.e., peano arithmetic). 5 | 6 | ;;; note that fat+ is tail-recursive; this is how all looping is 7 | ;;; performed in Scheme. 8 | 9 | (define fat+ 10 | (lambda (x y) 11 | (if (zero? y) 12 | x 13 | (fat+ (1+ x) (1- y))))) 14 | 15 | (define fatfib 16 | (lambda (x) 17 | (if (< x 2) 18 | 1 19 | (fat+ (fatfib (1- x)) (fatfib (1- (1- x))))))) 20 | -------------------------------------------------------------------------------- /examples/fft.ss: -------------------------------------------------------------------------------- 1 | ;;; fft.ss 2 | ;;; Copyright (C) 1996 R. Kent Dybvig 3 | ;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a 6 | ;;; copy of this software and associated documentation files (the "Software"), 7 | ;;; to deal in the Software without restriction, including without limitation 8 | ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | ;;; and/or sell copies of the Software, and to permit persons to whom the 10 | ;;; Software is furnished to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | ;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (define (dft x) 24 | (define (w-powers n) 25 | (let ((pi (* (acos 0.0) 2))) 26 | (let ((delta (/ (* -2.0i pi) n))) 27 | (let f ((n n) (x 0.0)) 28 | (if (= n 0) 29 | '() 30 | (cons (exp x) (f (- n 2) (+ x delta)))))))) 31 | (define (evens w) 32 | (if (null? w) 33 | '() 34 | (cons (car w) (evens (cddr w))))) 35 | (define (interlace x y) 36 | (if (null? x) 37 | '() 38 | (cons (car x) (cons (car y) (interlace (cdr x) (cdr y)))))) 39 | (define (split ls) 40 | (let split ((fast ls) (slow ls)) 41 | (if (null? fast) 42 | (values '() slow) 43 | (call-with-values 44 | (lambda () (split (cddr fast) (cdr slow))) 45 | (lambda (front back) 46 | (values (cons (car slow) front) back)))))) 47 | (define (butterfly x w) 48 | (call-with-values 49 | (lambda () (split x)) 50 | (lambda (front back) 51 | (values 52 | (map + front back) 53 | (map * (map - front back) w))))) 54 | (define (rfft x w) 55 | (if (null? (cddr x)) 56 | (let ((x0 (car x)) (x1 (cadr x))) 57 | (list (+ x0 x1) (- x0 x1))) 58 | (call-with-values 59 | (lambda () (butterfly x w)) 60 | (lambda (front back) 61 | (let ((w (evens w))) 62 | (interlace (rfft front w) (rfft back w))))))) 63 | (rfft x (w-powers (length x)))) 64 | -------------------------------------------------------------------------------- /examples/fib.ss: -------------------------------------------------------------------------------- 1 | ;;; simple fibonacci function 2 | 3 | ;;; uses trace-lambda to show the nesting 4 | 5 | (define fib 6 | (trace-lambda fib (x) 7 | (if (<= x 1) 8 | 1 9 | (+ (fib (- x 1)) (fib (- x 2)))))) 10 | -------------------------------------------------------------------------------- /examples/object.ss: -------------------------------------------------------------------------------- 1 | ;;; object.ss 2 | ;;; Copyright (C) 1996 R. Kent Dybvig 3 | ;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a 6 | ;;; copy of this software and associated documentation files (the "Software"), 7 | ;;; to deal in the Software without restriction, including without limitation 8 | ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | ;;; and/or sell copies of the Software, and to permit persons to whom the 10 | ;;; Software is furnished to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | ;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | ;;; define-object creates an object constructor that uses let* to bind 24 | ;;; local fields and letrec to define the exported procedures. An 25 | ;;; object is itself a procedure that accepts messages corresponding 26 | ;;; to the names of the exported procedures. The second pattern is 27 | ;;; used to allow the set of local fields to be omitted. 28 | (define-syntax define-object 29 | (syntax-rules () 30 | ((_ (name . varlist) 31 | ((var1 val1) ...) 32 | ((var2 val2) ...)) 33 | (define name 34 | (lambda varlist 35 | (let* ((var1 val1) ...) 36 | (letrec ((var2 val2) ...) 37 | (lambda (msg . args) 38 | (case msg 39 | ((var2) (apply var2 args)) ... 40 | (else 41 | (error 'name "invalid message ~s" 42 | (cons msg args)))))))))) 43 | ((_ (name . varlist) 44 | ((var2 val2) ...)) 45 | (define-object (name . varlist) 46 | () 47 | ((var2 val2) ...))))) 48 | 49 | ;;; send-message abstracts the act of sending a message from the act 50 | ;;; of applying a procedure and allows the message to be unquoted. 51 | (define-syntax send-message 52 | (syntax-rules () 53 | ((_ obj msg arg ...) 54 | (obj 'msg arg ...)))) 55 | -------------------------------------------------------------------------------- /examples/power.ss: -------------------------------------------------------------------------------- 1 | ;;; doubly recursive power (expt) function 2 | 3 | ;;; try using trace-lambda to see the nesting. 4 | 5 | (define power 6 | (lambda (x n) 7 | (cond 8 | [(= n 0) 1] 9 | [(= n 1) x] 10 | [else 11 | (let ([q (quotient n 2)]) 12 | (* (power x q) (power x (- n q))))]))) 13 | -------------------------------------------------------------------------------- /examples/queue.ss: -------------------------------------------------------------------------------- 1 | ;;; queue 2 | ;;; an abstract datatype 3 | 4 | ;;; operations: 5 | ;;; (queue) ;create a queue object 6 | 7 | ;;; if 'q' is a queue object: 8 | 9 | ;;; (q 'type?) ;return the type (queue), useful if there are other 10 | ;;; ;abstract datatypes floating around. 11 | ;;; (q 'empty?) ;returns true iff q is empty 12 | ;;; (q 'put val) ;adds val to end of q; returns val 13 | ;;; (q 'get) ;removes first element of q and returns it 14 | 15 | ;;; Examples 16 | 17 | ;;; (define! q (queue)) 18 | ;;; (q 'type?) => queue 19 | ;;; (q 'empty?) => #!true 20 | ;;; (q 'put 3) 21 | ;;; (q 'put 4) 22 | ;;; (q 'put 5) 23 | ;;; (q 'empty?) => () 24 | ;;; (q 'get) => 3 25 | ;;; (q 'get) => 4 26 | ;;; (q 'put 7) 27 | ;;; (q 'get) => 5 28 | ;;; (q 'get) => 7 29 | ;;; (q 'empty?) => #!true 30 | 31 | (define queue 32 | (lambda () 33 | (let ([head '()] [tail '()]) 34 | (lambda (request . args) 35 | (case request 36 | [type? 'queue] 37 | [empty? (null? head)] 38 | [put 39 | (let ([v (car args)]) 40 | (if (null? head) 41 | (let ([p (cons v '())]) 42 | (set! tail p) 43 | (set! head p)) 44 | (let ([quebit (cons v '())]) 45 | (set-cdr! tail quebit) 46 | (set! tail quebit))) 47 | v)] 48 | [get 49 | (if (null? head) 50 | (error 'queue "queue is empty") 51 | (let ([v (car head)]) 52 | (set! head (cdr head)) 53 | (when (null? head) (set! tail '())) 54 | v))] 55 | [else 56 | (error 'queue "~s is not a valid request" request)]))))) 57 | -------------------------------------------------------------------------------- /examples/rabbit.ss: -------------------------------------------------------------------------------- 1 | ;;; rabbit 2 | 3 | ;;; The rabbit program highlights the use of continuations and 4 | ;;; timer interrupts to perform thread scheduling. The scheduler 5 | ;;; maintains a thread queue and operating system primitives for 6 | ;;; dispatching and thread creation. The queue is only visible 7 | ;;; to the operating system kernel and all accesses are performed 8 | ;;; with the timer off to prevent corruption. 9 | 10 | ;;; (thread exp) will create a thread out of exp and place it in 11 | ;;; the thread queue. you may do this for as many threads as 12 | ;;; you like. (dispatch) starts the threads going. If the 13 | ;;; thread queue ever becomes empty, dispatch exits. Threads 14 | ;;; may create other threads. 15 | 16 | ;;; The rabbit function creates a thread that spawns two offspring 17 | ;;; and dies. Each thread has a generation number associated with 18 | ;;; it. The generation number of each rabbit is one lower than that 19 | ;;; of it's parent; rabbits in generation 0 are sterile. 20 | 21 | ;;; load the queue datatype -- might need a fuller pathname 22 | (load "queue.ss") 23 | 24 | ;;; swap-time determines the number of timer ticks in a time slice 25 | (define swap-time 26 | (make-parameter 27 | 100 28 | (lambda (x) 29 | (unless (and (integer? x) (positive? x)) 30 | (error 'swap-time "~s is not a positive integer" x)) 31 | x))) 32 | 33 | (define dispatch #f) 34 | (define thread #f) 35 | 36 | (let ([pq (queue)]) 37 | (set! dispatch 38 | (lambda () 39 | (unless (pq 'empty?) 40 | ; the thread queue holds continuations---grab one and invoke it 41 | (let ([next (pq 'get)]) 42 | (set-timer (swap-time)) 43 | (next #f))))) 44 | (set! thread 45 | (lambda (thunk) 46 | (call/cc 47 | (lambda (return) 48 | (call/cc 49 | (lambda (k) 50 | ; turn off the timer while accessing the queue 51 | (let ([time-left (set-timer 0)]) 52 | ; put the thread on the queue 53 | (pq 'put k) 54 | (set-timer time-left) 55 | ; get out of here 56 | (return #f)))) 57 | ; the first time through we will return before getting 58 | ; here. the second time is when a thread is first 59 | ; dispatched from the thread queue. 60 | (thunk) 61 | (set-timer 0) 62 | (dispatch))))) 63 | (timer-interrupt-handler 64 | (lambda () 65 | (printf "swapping~%") 66 | (call/cc 67 | (lambda (l) 68 | ; place the continuation of the interrupt on the queue 69 | (pq 'put l) 70 | (dispatch)))))) 71 | 72 | 73 | ;;; *delay-max* gives the maximum random delay before a rabbit 74 | ;;; reaches child-bearing age. 75 | (define *delay-max* 10000) 76 | 77 | (define rabbit 78 | (lambda (n) 79 | (thread 80 | (lambda () 81 | (printf "~s~%" n) 82 | (unless (zero? n) 83 | (do ([i (random *delay-max*) (1- i)]) ((zero? i))) 84 | (rabbit (1- n)) 85 | (rabbit (1- n))))))) 86 | 87 | ;;; try: 88 | ;;; (rabbit 3) 89 | ;;; (rabbit 5) 90 | ;;; (dispatch) 91 | -------------------------------------------------------------------------------- /examples/scons.ss: -------------------------------------------------------------------------------- 1 | ;;; scons.ss 2 | ;;; a stream-construction facility 3 | 4 | ;;; The scons special form performs a cons, suspending the cdr field 5 | ;;; by enclosing it in a procedure of no arguments. scdr tests to see 6 | ;;; if the cdr is a procedure, and if so, invokes it. scar is provided 7 | ;;; for symmetry; it is just car. 8 | 9 | ;;; The function stream-ref is simply list-ref defined in terms of 10 | ;;; scdr and scar. 11 | 12 | ;;; factlist and fiblist are two infinite streams. 13 | ;;; Try (stream-ref factlist 10) or (stream-ref fiblist 20). 14 | 15 | ;;; scons could easily suspend the car field as well. This would 16 | ;;; implement the lazy cons of Friedman & Wise. 17 | 18 | (define-syntax scons 19 | (syntax-rules () 20 | ((_ car cdr) (cons car (lambda () cdr))))) 21 | 22 | (define scar car) 23 | 24 | (define scdr 25 | (lambda (x) 26 | (when (procedure? (cdr x)) (set-cdr! x ((cdr x)))) 27 | (cdr x))) 28 | 29 | (define stream-ref 30 | (lambda (x n) 31 | (if (zero? n) 32 | (scar x) 33 | (stream-ref (scdr x) (1- n))))) 34 | 35 | (define factlist 36 | (let fact ([a 1] [n 1]) 37 | (scons a (fact (* a n) (1+ n))))) 38 | 39 | (define fiblist 40 | (let fib ([fib-2 0] [fib-1 1]) 41 | (scons fib-1 (fib fib-1 (+ fib-2 fib-1))))) 42 | -------------------------------------------------------------------------------- /examples/setof.ss: -------------------------------------------------------------------------------- 1 | ;;; setof.ss 2 | ;;; Copyright (C) 1996 R. Kent Dybvig 3 | ;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a 6 | ;;; copy of this software and associated documentation files (the "Software"), 7 | ;;; to deal in the Software without restriction, including without limitation 8 | ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | ;;; and/or sell copies of the Software, and to permit persons to whom the 10 | ;;; Software is furnished to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | ;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | ;;; set-of uses helper syntactic extension set-of-help, passing it 24 | ;;; an initial base expression of '() 25 | (define-syntax set-of 26 | (syntax-rules () 27 | ((_ e m ...) 28 | (set-of-help e '() m ...)))) 29 | 30 | ;;; set-of-help recognizes in, is, and predicate expressions and 31 | ;;; changes them into nested named let, let, and if expressions. 32 | (define-syntax set-of-help 33 | (syntax-rules (in is) 34 | ((_ e base) 35 | (set-cons e base)) 36 | ((_ e base (x in s) m ...) 37 | (let loop ((set s)) 38 | (if (null? set) 39 | base 40 | (let ((x (car set))) 41 | (set-of-help e (loop (cdr set)) m ...))))) 42 | ((_ e base (x is y) m ...) 43 | (let ((x y)) (set-of-help e base m ...))) 44 | ((_ e base p m ...) 45 | (if p (set-of-help e base m ...) base)))) 46 | 47 | ;;; set-cons returns the original set y if x is already in y. 48 | (define set-cons 49 | (lambda (x y) 50 | (if (memv x y) 51 | y 52 | (cons x y)))) 53 | -------------------------------------------------------------------------------- /examples/unify.ss: -------------------------------------------------------------------------------- 1 | ;;; unify.ss 2 | ;;; Copyright (C) 1996 R. Kent Dybvig 3 | ;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining a 6 | ;;; copy of this software and associated documentation files (the "Software"), 7 | ;;; to deal in the Software without restriction, including without limitation 8 | ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | ;;; and/or sell copies of the Software, and to permit persons to whom the 10 | ;;; Software is furnished to do so, subject to the following conditions: 11 | ;;; 12 | ;;; The above copyright notice and this permission notice shall be included in 13 | ;;; all copies or substantial portions of the Software. 14 | ;;; 15 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | ;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (define unify #f) 24 | (let () 25 | ;; occurs? returns true if and only if u occurs in v 26 | (define occurs? 27 | (lambda (u v) 28 | (and (pair? v) 29 | (let f ((l (cdr v))) 30 | (and (pair? l) 31 | (or (eq? u (car l)) 32 | (occurs? u (car l)) 33 | (f (cdr l)))))))) 34 | 35 | ;; sigma returns a new substitution procedure extending s by 36 | ;; the substitution of u with v 37 | (define sigma 38 | (lambda (u v s) 39 | (lambda (x) 40 | (let f ((x (s x))) 41 | (if (symbol? x) 42 | (if (eq? x u) v x) 43 | (cons (car x) (map f (cdr x)))))))) 44 | 45 | ;; try-subst tries to substitute u for v but may require a 46 | ;; full unification if (s u) is not a variable, and it may 47 | ;; fail if it sees that u occurs in v. 48 | (define try-subst 49 | (lambda (u v s ks kf) 50 | (let ((u (s u))) 51 | (if (not (symbol? u)) 52 | (uni u v s ks kf) 53 | (let ((v (s v))) 54 | (cond 55 | ((eq? u v) (ks s)) 56 | ((occurs? u v) (kf "cycle")) 57 | (else (ks (sigma u v s))))))))) 58 | 59 | ;; uni attempts to unify u and v with a continuation-passing 60 | ;; style that returns a substitution to the success argument 61 | ;; ks or an error message to the failure argument kf. The 62 | ;; substitution itself is represented by a procedure from 63 | ;; variables to terms. 64 | (define uni 65 | (lambda (u v s ks kf) 66 | (cond 67 | ((symbol? u) (try-subst u v s ks kf)) 68 | ((symbol? v) (try-subst v u s ks kf)) 69 | ((and (eq? (car u) (car v)) 70 | (= (length u) (length v))) 71 | (let f ((u (cdr u)) (v (cdr v)) (s s)) 72 | (if (null? u) 73 | (ks s) 74 | (uni (car u) 75 | (car v) 76 | s 77 | (lambda (s) (f (cdr u) (cdr v) s)) 78 | kf)))) 79 | (else (kf "clash"))))) 80 | 81 | ;; unify shows one possible interface to uni, where the initial 82 | ;; substitution is the identity procedure, the initial success 83 | ;; continuation returns the unified term, and the initial failure 84 | ;; continuation returns the error message. 85 | (set! unify 86 | (lambda (u v) 87 | (uni u 88 | v 89 | (lambda (x) x) 90 | (lambda (s) (s u)) 91 | (lambda (msg) msg))))) 92 | -------------------------------------------------------------------------------- /makefiles/Makefile-release_notes.in: -------------------------------------------------------------------------------- 1 | srcdir=oops-missing-srcdir 2 | installdir=oops-missing-installdir 3 | m=oops-missing-m 4 | STEXLIB=oops-missing-stexlib 5 | # Zuo overrides the above variables when running `make` 6 | Scheme=../$m/bin/$m/scheme -b ../$m/boot/$m/petite.boot -b ../$m/boot/$m/scheme.boot 7 | INSTALL=$(srcdir)/../makefiles/installsh 8 | 9 | # define default document pathname here 10 | # override on command line with 'make x=newdoc' 11 | x = release_notes 12 | 13 | # define latex processor: latex or pdflatex 14 | latex = pdflatex 15 | 16 | # define stex macro files here 17 | stexmacrofiles = 18 | 19 | # list bibliography files here 20 | bib = 21 | 22 | # define index if an index is to be generated 23 | # index=yes 24 | 25 | include $(STEXLIB)/Mf-stex 26 | 27 | srcs = $(x).stex releasenotes.cls releasenotes.hcls \ 28 | macros.stex releasenotes.css scheme.sty 29 | 30 | # define or override suffixes here 31 | 32 | # define any additional targets here 33 | 34 | install: $x.pdf $x.html 35 | $(INSTALL) -m 2755 -d $(installdir) 36 | $(INSTALL) -m 0644 --ifdiff $x.html $x.pdf $(installdir) 37 | $(INSTALL) -m 0644 --ifdiff releasenotes.css $(installdir) 38 | (X=`echo canned/*` ;\ 39 | if [ "$$X" != "canned/*" ] ; then\ 40 | $(INSTALL) -m 2755 -d $(installdir)/canned ;\ 41 | $(INSTALL) -m 0644 --ifdiff canned/* $(installdir)/canned ;\ 42 | fi) 43 | $(INSTALL) -m 2755 -d $(installdir)/gifs 44 | $(INSTALL) -m 0644 --ifdiff gifs/*.gif $(installdir)/gifs 45 | $(INSTALL) -m 2755 -d $(installdir)/math 46 | -rm -rf $(installdir)/$(mathdir) 47 | $(INSTALL) -m 2755 -d $(installdir)/$(mathdir) 48 | if [ -e $(mathdir)/0.gif ] ; then $(INSTALL) -m 0644 $(mathdir)/*.gif $(installdir)/$(mathdir) ; fi 49 | 50 | # define any dependencies here 51 | 52 | $(x).firstrun: macros.tex $(srcs) 53 | 54 | # define cleanup targets here: 55 | 56 | $(x).clean: 57 | 58 | $(x).reallyclean: 59 | 60 | $(x).reallyreallyclean: 61 | 62 | $(srcs): 63 | ifeq ($(OS),Windows_NT) 64 | cp -p "${srcdir}"/$@ $@ 65 | else 66 | ln -s "${srcdir}"/$@ $@ 67 | endif 68 | -------------------------------------------------------------------------------- /makefiles/Makefile.nt: -------------------------------------------------------------------------------- 1 | 2 | # Mf-config include is written above by "build.bat" 3 | 4 | build: zuo.exe 5 | .\zuo.exe 6 | 7 | kernel: zuo.exe 8 | .\zuo.exe . kernel 9 | 10 | all-dlls: zuo.exe 11 | .\zuo.exe . all-dlls 12 | 13 | test-one: zuo.exe 14 | .\zuo.exe . test-one 15 | 16 | test-some-fast: zuo.exe 17 | .\zuo.exe . test-some-fast 18 | 19 | test-some: zuo.exe 20 | .\zuo.exe . test-some 21 | 22 | test: zuo.exe 23 | .\zuo.exe . test 24 | 25 | test-more: zuo.exe 26 | .\zuo.exe . test-more 27 | 28 | zuo.exe: "$(srcdir)\zuo\zuo.c" 29 | cl.exe /O2 /Fe:pre_zuo.exe "$(srcdir)\zuo\zuo.c" 30 | .\pre_zuo.exe -X "$(srcdir)\zuo\lib" "$(srcdir)\makefiles\libpath.zuo" "$(srcdir)\zuo" 31 | cl.exe /O2 /Fe:zuo.exe zuo.c 32 | -------------------------------------------------------------------------------- /makefiles/bintar.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | (require "../makefiles/version.zuo" 3 | "../makefiles/lib.zuo" 4 | "../makefiles/install.zuo") 5 | 6 | (provide make-bintar) 7 | 8 | (define (make-bintar at-dir m) 9 | (define config (config-file->hash (at-dir "Mf-config"))) 10 | 11 | (define version (let ([l (get-version)]) 12 | (~a (list-ref l 0) "." (list-ref l 1) "." (list-ref l 2)))) 13 | 14 | (mkdir-p (at-dir "bintar")) 15 | (define R (at-dir "bintar" (~a "csv" version))) 16 | (define tarball (at-dir "bintar" (~a "csv" version "-" m ".tar.gz"))) 17 | 18 | (rm* R) 19 | (mkdir-p R) 20 | 21 | (define (immediate name) 22 | (cp/ln (at-source ".." name) (build-path R name))) 23 | 24 | (immediate "LICENSE") 25 | (immediate "NOTICE") 26 | (immediate "scheme.1.in") 27 | (cp/ln (at-source "../makefiles" "installsh") (build-path R "installsh")) 28 | 29 | (let ([o (fd-open-output (build-path R "Makefile"))]) 30 | (install at-dir (hash) #f o) 31 | (fd-close o)) 32 | 33 | (immediate "examples") 34 | 35 | (mkdir-p (build-path R "boot" m)) 36 | (define (boot-link p) 37 | (cp/ln (at-dir "boot" m p) (build-path R "boot" m p))) 38 | 39 | (boot-link "scheme.h") 40 | (boot-link "scheme.boot") 41 | (boot-link "petite.boot") 42 | (boot-link "revision") 43 | (cond 44 | [(glob-match? "*nt" m) 45 | (boot-link "csv957md.lib") 46 | (boot-link "csv957mt.lib") 47 | (boot-link "mainmd.obj") 48 | (boot-link "mainmt.obj") 49 | (boot-link "scheme.res")] 50 | [else 51 | (boot-link "main.o") 52 | (cond 53 | [(equal? (hash-ref config 'Kernel #f) "KernelLib") 54 | (boot-link "libkernel.a") 55 | (when (equal? (hash-ref config 'zlibLib #f) "") 56 | (mkdir-p (build-path R "zlib")) 57 | (cp/ln (at-dir "zlib/libz.a") (build-path R "zlib/libz.a"))) 58 | (when (equal? (hash-ref config 'LZ4Lib #f) "") 59 | (mkdir-p (build-path R "lz4/lib")) 60 | (cp/ln (at-dir "lz4/lib/liblz4.a") (build-path R "lz4/lib/liblz4.a")))] 61 | [else 62 | (boot-link "kernel.o")])]) 63 | 64 | (mkdir-p (build-path R "bin" m)) 65 | (define (bin-link p) 66 | (cp/ln (at-dir "bin" m p) (build-path R "bin" m p))) 67 | 68 | (cond 69 | [(glob-match? "*nt" m) 70 | (bin-link "scheme.exe") 71 | (bin-link "csv957.dll") 72 | (bin-link "csv957.lib") 73 | (bin-link "vcruntime140.lib")] 74 | [else 75 | (bin-link "scheme")]) 76 | 77 | (shell/wait (build-shell "tar -czhf" 78 | (string->shell (file-name-from-path tarball)) 79 | (string->shell (file-name-from-path R))) 80 | (hash 'dir (path-only tarball))) 81 | 82 | (rm* R)) 83 | -------------------------------------------------------------------------------- /makefiles/boot.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | (require (only-in "../s/build.zuo" 3 | [targets-at s-targets-at])) 4 | 5 | (provide boot-file-names 6 | cross-build-boot 7 | clean-links) 8 | 9 | (module+ main 10 | (command-line 11 | :args (scheme machine) 12 | (lambda (accum) 13 | (define vars (hash)) 14 | (cross-build-boot #f (hash) '("all") 15 | machine 16 | (if (car (split-path scheme)) 17 | scheme 18 | (find-executable-path scheme)) 19 | #f 20 | (make-at-dir "xc") vars vars #f)))) 21 | 22 | (define boot-file-names 23 | '(;; the boot files proper 24 | "petite.boot" "scheme.boot" 25 | ;; machine-specific header files: 26 | "scheme.h" "equates.h" 27 | ;; GC traversal functions 28 | "gc-ocd.inc" "gc-oce.inc" "gc-par.inc" "heapcheck.inc")) 29 | 30 | ;; Cross-builds for a given machine type 31 | (define (cross-build-boot token ccopts make-targets xpatch? 32 | xm host-scheme host-workarea 33 | at-dir config vars m) 34 | (define dir (at-dir ".." (~a "xc-" xm))) 35 | (define s-dir (build-path dir "s")) 36 | (mkdir-p s-dir) 37 | (clean-links s-dir) ; in case leftover from old build system 38 | (display-to-file (~a "m=" xm "\n" 39 | (~a "hostm=" m "\n") 40 | (if host-scheme 41 | (~a "hostscheme=" host-scheme "\n") 42 | "") 43 | "hostworkarea=" (if host-scheme 44 | "" 45 | (find-relative-path dir (or host-workarea 46 | (at-dir .)))) "\n" 47 | (if (or host-scheme host-workarea) 48 | "cross=t\n" 49 | "") 50 | "\n") 51 | (build-path dir "Mf-config") 52 | :truncate) 53 | (let ([targets (s-targets-at (make-at-dir s-dir) 54 | (hash-remove vars 'm) 55 | ccopts)]) 56 | (build (find-target "clean" targets) token) 57 | (map (lambda (t) 58 | (build (find-target t targets) token)) 59 | make-targets) 60 | (when xpatch? 61 | (build (find-target (build-path s-dir "xpatch") targets) token))) 62 | (define boot-xm-dir (at-dir "../boot" xm)) 63 | (mkdir-p boot-xm-dir) 64 | (for-each (lambda (file) 65 | (cp (build-path dir "boot" xm file) 66 | (build-path boot-xm-dir file))) 67 | boot-file-names)) 68 | 69 | (define (clean-links dir) 70 | (for-each (lambda (p) 71 | (cond 72 | [(link-exists? p) (rm p)] 73 | [(directory-exists? p) 74 | (unless (equal? "boot" (file-name-from-path p)) 75 | (clean-links p))])) 76 | (ls* dir))) 77 | -------------------------------------------------------------------------------- /makefiles/buildmain.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | ;; installed as the "main.zuo" in a build directory 3 | (define config (config-file->hash (at-source "Makefile"))) 4 | (void (module->hash (at-source (hash-ref config 'workarea) "main.zuo"))) 5 | -------------------------------------------------------------------------------- /makefiles/installsh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | if [ -x /bin/true ]; then TRUE=/bin/true; 3 | elif [ -x /usr/bin/true ]; then TRUE=/usr/bin/true; 4 | elif command -v true &> /dev/null; then TRUE=true; 5 | else echo "Can't find /bin/true or /usr/bin/true and no true command" ; exit 1; 6 | fi 7 | 8 | while ${TRUE} ; do 9 | mkdirs=0 10 | ifdiff=0 11 | 12 | while [ $# -ge 0 ] ; do 13 | case $1 in 14 | -d) mkdirs=1 ;; 15 | -o) shift; owner=$1 ;; 16 | -g) shift; group=$1 ;; 17 | -m) shift; mode=$1 ;; 18 | --ifdiff) ifdiff=1 ;; 19 | -*) break 2 ;; 20 | *) break ;; 21 | esac 22 | shift 23 | done 24 | 25 | if [ $mkdirs -eq 1 ] && [ $ifdiff -eq 1 ] ; then 26 | break 27 | fi 28 | 29 | if [ $mkdirs -eq 1 ] ; then 30 | dirs=$* 31 | 32 | for dir in $dirs ; do 33 | stack="" 34 | while [ "$dir" != "/" -a "$dir" != "." -a "$dir" != ".." ] ; do 35 | stack="$dir $stack" 36 | dir=`dirname $dir` 37 | done 38 | 39 | for dir in $stack ; do 40 | if [ ! -d $dir ] ; then 41 | if mkdir $dir ; then 42 | if [ "$owner" != "" ] ; then chown $owner $dir ; fi 43 | if [ "$group" != "" ] ; then chgrp $group $dir ; fi 44 | if [ "$mode" != "" ] ; then chmod $mode $dir ; fi 45 | fi 46 | fi 47 | done 48 | done 49 | else 50 | nargs=$# 51 | if [ $nargs -lt 2 ] ; then break ; fi 52 | 53 | files="" 54 | while [ $# -ne 1 ] ; do 55 | files="$files $1" 56 | shift 57 | done 58 | dest=$1 59 | 60 | if [ ! -d $dest -a $nargs -ne 2 ] ; then break ; fi 61 | 62 | for file in $files ; do 63 | destfile=$dest 64 | if [ -d $destfile ] ; then destfile=$destfile/`basename $file` ; fi 65 | if [ $ifdiff -eq 1 ] && cmp -s $file $destfile || cp -f -p $file $destfile ; then 66 | if [ "$owner" != "" ] ; then chown $owner $destfile ; fi 67 | if [ "$group" != "" ] ; then chgrp $group $destfile ; fi 68 | if [ "$mode" != "" ] ; then chmod $mode $destfile ; fi 69 | fi 70 | done 71 | fi 72 | 73 | exit 0 74 | done 75 | 76 | echo "usage: $0 [ -o owner] [ -g group ] [ -m mode ] [ --ifdiff] file dest" 77 | echo " $0 [ -o owner] [ -g group ] [ -m mode ] [ --ifdiff] file file ... dir" 78 | echo " $0 -d [ -o owner] [ -g group ] [ -m mode ] dir dir ..." 79 | exit 1 80 | -------------------------------------------------------------------------------- /makefiles/libpath.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (command-line 4 | :args 5 | (srcdir) 6 | (lambda (accum) 7 | (define norm-srcdir (apply build-path (explode-path srcdir))) 8 | (define lines (string-split (file->string (build-path srcdir "zuo.c")) 9 | "\n")) 10 | (define out (fd-open-output "zuo.c" :truncate)) 11 | (for-each 12 | (let ([def? (glob->matcher "# define ZUO_LIB_PATH*")]) 13 | (lambda (line) 14 | (if (def? line) 15 | (fd-write out (~a "# define ZUO_LIB_PATH " (~s (build-path norm-srcdir "lib")) "\n")) 16 | (fd-write out (~a line "\n"))))) 17 | lines) 18 | (fd-close out))) 19 | -------------------------------------------------------------------------------- /makefiles/version.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (provide get-version 4 | get-dll-version) 5 | 6 | (define (get-version) 7 | (let* ([str (file->string (at-source "../s/cmacros.ss"))] 8 | [def "(define-constant scheme-version #x"] 9 | [end (- (string-length str) (string-length def))]) 10 | (let loop ([i 0]) 11 | (cond 12 | [(> i end) (error "did not find version in cmacro.ss")] 13 | [(and (= (string-ref str i) (string-ref def 0)) 14 | (string=? (substring str i (+ i (string-length def))) def)) 15 | (let ([hex (substring str 16 | (+ i (string-length def)) 17 | (+ i (string-length def) 8))]) 18 | (define (hex-digit-val c) (cond 19 | [(>= c (char "a")) (+ (- c (char "a")) 10)] 20 | [(>= c (char "A")) (+ (- c (char "A")) 10)] 21 | [else (- c (char "0"))])) 22 | (define (hex-val i) (+ (* 16 (hex-digit-val (string-ref hex i))) 23 | (hex-digit-val (string-ref hex (+ i 1))))) 24 | (list (hex-val 0) (hex-val 2) (hex-val 4) (hex-val 6)))] 25 | [else (loop (+ i 1))])))) 26 | 27 | (define (get-dll-version) 28 | (let ([l (get-version)]) 29 | (~a (list-ref l 0) (list-ref l 1) (list-ref l 2)))) 30 | -------------------------------------------------------------------------------- /makefiles/workmain.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | ;; installed as "main.zuo" in a workarea 3 | (define config (config-file->hash (at-source "Mf-config"))) 4 | (build/command-line* (dynamic-require ((make-at-dir (at-source "..")) 5 | (hash-ref config 'srcdir) 6 | "build.zuo") 7 | 'targets-at) 8 | at-source) 9 | -------------------------------------------------------------------------------- /mats/5_8.ms: -------------------------------------------------------------------------------- 1 | ;;; 5-7.ms 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (mat box 17 | (box? (box 3)) 18 | (equal? (box 'a) '#&a) 19 | (equal? (box '(a b c)) '#&(a b c)) 20 | (not (eq? (box '()) (box '()))) 21 | ) 22 | 23 | (mat unbox 24 | (equal? (unbox '#&3) 3) 25 | (equal? (unbox (box 3)) 3) 26 | ) 27 | 28 | (mat set-box! 29 | (let ((x (box 3))) 30 | (set-box! x 4) 31 | (and (equal? x '#&4) (equal? (unbox x) 4))) 32 | ) 33 | 34 | (mat box-cas! 35 | (begin 36 | (define bx1 (box 1)) 37 | (define bx2 (box 'apple)) 38 | (eq? 1 (unbox bx1))) 39 | (not (box-cas! bx1 0 1)) 40 | (eq? 1 (unbox bx1)) 41 | (box-cas! bx1 1 2) 42 | (eq? 2 (unbox bx1)) 43 | 44 | (not (box-cas! bx2 #f 'banana)) 45 | (box-cas! bx2 'apple 'banana) 46 | (not (box-cas! bx2 'apple 'banana)) 47 | (eq? 'banana (unbox bx2)) 48 | 49 | (not (box-cas! (box (bitwise-arithmetic-shift-left 1 40)) 50 | (bitwise-arithmetic-shift-left 2 40) 51 | 'wrong)) 52 | 53 | (error? (box-cas! bx1)) ; arity 54 | (error? (box-cas! bx1 1)) ; arity 55 | (error? (box-cas! 1 bx1 2)) ; not a box 56 | (error? (box-cas! (box-immutable 1) 1 2)) ; not a mutable box 57 | 58 | ;; make sure `box-cas!` works with GC generations: 59 | (begin 60 | (collect 0) 61 | (let ([g1 (gensym)]) 62 | (and (let loop () 63 | (or (box-cas! bx2 'banana g1) 64 | (loop))) 65 | (begin 66 | (collect 0) 67 | (eq? g1 (unbox bx2)))))) 68 | ) 69 | -------------------------------------------------------------------------------- /mats/cat_flush.c: -------------------------------------------------------------------------------- 1 | /* cat_flush.c 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #include 18 | #include 19 | #if defined(_MSC_VER) || defined(__MINGW32__) 20 | #include 21 | #include 22 | #endif 23 | 24 | int main() { 25 | int c; 26 | 27 | #if defined(_MSC_VER) || defined(__MINGW32__) 28 | _setmode(_fileno(stdin), O_BINARY); 29 | _setmode(_fileno(stdout), O_BINARY); 30 | #endif 31 | 32 | while ((c = getchar()) != EOF) { 33 | putchar(c); 34 | fflush(stdout); 35 | } 36 | 37 | exit(0); 38 | } 39 | -------------------------------------------------------------------------------- /mats/freq.in: -------------------------------------------------------------------------------- 1 | Peter Piper picked a peck of pickled peppers; 2 | A peck of pickled peppers Peter Piper picked. 3 | If Peter Piper picked a peck of pickled peppers, 4 | Where's the peck of pickled peppers Peter Piper picked? 5 | -------------------------------------------------------------------------------- /mats/freq.out: -------------------------------------------------------------------------------- 1 | 1 A 2 | 1 If 3 | 4 Peter 4 | 4 Piper 5 | 1 Where 6 | 2 a 7 | 4 of 8 | 4 peck 9 | 4 peppers 10 | 4 picked 11 | 4 pickled 12 | 1 s 13 | 1 the 14 | -------------------------------------------------------------------------------- /mats/ftype.h: -------------------------------------------------------------------------------- 1 | /* ftype.h 2 | * Copyright 1984-2017 Cisco Systems, Inc. 3 | * 4 | * Licensed under the Apache License, Version 2.0 (the "License"); 5 | * you may not use this file except in compliance with the License. 6 | * You may obtain a copy of the License at 7 | * 8 | * http://www.apache.org/licenses/LICENSE-2.0 9 | * 10 | * Unless required by applicable law or agreed to in writing, software 11 | * distributed under the License is distributed on an "AS IS" BASIS, 12 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | * See the License for the specific language governing permissions and 14 | * limitations under the License. 15 | */ 16 | 17 | #ifdef SPARC 18 | 19 | typedef signed char int8_t; 20 | typedef unsigned char uint8_t; 21 | typedef signed short int16_t; 22 | typedef unsigned short uint16_t; 23 | typedef signed int int32_t; 24 | typedef unsigned int uint32_t; 25 | typedef signed long long int64_t; 26 | typedef unsigned long long uint64_t; 27 | 28 | #else 29 | 30 | #include 31 | 32 | #endif 33 | 34 | #ifdef WIN32 35 | #define EXPORT extern __declspec (dllexport) 36 | #else 37 | #define EXPORT extern 38 | #endif 39 | -------------------------------------------------------------------------------- /mats/m4test.in: -------------------------------------------------------------------------------- 1 | dnl m4test.in 2 | dnl Copyright 1984-2017 Cisco Systems, Inc. 3 | dnl 4 | dnl Licensed under the Apache License, Version 2.0 (the "License"); 5 | dnl you may not use this file except in compliance with the License. 6 | dnl You may obtain a copy of the License at 7 | dnl 8 | dnl http://www.apache.org/licenses/LICENSE-2.0 9 | dnl 10 | dnl Unless required by applicable law or agreed to in writing, software 11 | dnl distributed under the License is distributed on an "AS IS" BASIS, 12 | dnl WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | dnl See the License for the specific language governing permissions and 14 | dnl limitations under the License. 15 | dnl 16 | dnl a small excerpt from the delta 68k .m4 file that nonetheless strains 17 | dnl m4 pretty well. use "make bullym4test.in" to test more fully, if you 18 | dnl have the time. 19 | 20 | changequote({,}) 21 | 22 | dnl delta assembler does not support register masks; must convert to constant 23 | define(PUSHREGS,{moveml REGMASK({$1},{A7FIRST}),DEC(SP)}) 24 | define(POPREGS,{moveml INC(SP),REGMASK({$1},{D0FIRST})}) 25 | define(STOREREGS,{moveml REGMASK({$1},{D0FIRST}),{$2}}) 26 | define(LOADREGS,{moveml {$2},REGMASK({$1},{D0FIRST})}) 27 | define(REGMASK,{{&0x}HEXWORD(eval(REGMASK1({$1}/,0,{$2})))}) 28 | define(REGMASK1,{ 29 | ifelse( 30 | $2,len({$1}), 31 | {0}, 32 | substr({$1},eval($2+2),1),-, 33 | {REGRANGE(substr({$1},$2,1), 34 | substr({$1},eval($2+1),1), 35 | substr({$1},eval($2+4),1), 36 | {$3}) + 37 | REGMASK1({$1},eval($2+6),{$3})}, 38 | {$3(substr({$1},$2,1),substr({$1},eval($2+1),1)) + 39 | REGMASK1({$1},eval($2+3),{$3})})}) 40 | define(REGRANGE,{$4($1,$2)+ifelse($2,$3,{0},{REGRANGE($1,incr($2),$3,{$4})})}) 41 | define(A7FIRST,{(2**(ifelse($1,D,15,7)-$2))}) 42 | define(D0FIRST,{(2**(ifelse($1,A,8,0)+$2))}) 43 | 44 | dnl used to pretty up register mask 45 | define(HEXLONG,{HEXIFY($1,0)}) 46 | define(HEXWORD,{HEXIFY($1,4)}) 47 | define(HEXBYTE,{HEXIFY($1,6)}) 48 | define(HEXIFY,{ifelse($1,0,{substr(00000000,$2)},{HEXIFY(eval($1/16),incr($2)){}HEXDIGIT(eval($1%16))})}) 49 | define(HEXDIGIT,{substr({0123456789abcdef},$1,1)}) 50 | 51 | PUSHREGS({D2-D7/A2-A6}) 52 | 53 | POPREGS({D2-D7/A2-A6}) 54 | -------------------------------------------------------------------------------- /mats/m4test.out: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | moveml &0x3f3e,DEC(SP) 21 | 22 | moveml INC(SP),&0x7cfc 23 | -------------------------------------------------------------------------------- /mats/patch-compile-0-f-t-t: -------------------------------------------------------------------------------- 1 | *** output-compile-0-f-t-f-experr/errors-compile-0-f-t-f Fri Feb 24 19:33:42 2023 2 | --- output-compile-0-f-t-t-experr/errors-compile-0-f-t-t Fri Feb 24 19:33:36 2023 3 | *************** 4 | *** 9412,9424 **** 5 | fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". 6 | fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". 7 | fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". 8 | ! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow with arguments and 2". 9 | fx.mo:Expected error in mat fx*: "fx*: is not a fixnum". 10 | fx.mo:Expected error in mat fx*: "fx*: <-int> is not a fixnum". 11 | fx.mo:Expected error in mat fx*: "fx*: #f is not a fixnum". 12 | fx.mo:Expected error in mat fx*: "fx*: #f is not a fixnum". 13 | fx.mo:Expected error in mat r6rs:fx*: "fx*: (a . b) is not a fixnum". 14 | ! fx.mo:Expected error in mat r6rs:fx*: "fx*: fixnum overflow with arguments and 2". 15 | fx.mo:Expected error in mat r6rs:fx*: "fx*: is not a fixnum". 16 | fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". 17 | fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". 18 | --- 9412,9424 ---- 19 | fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". 20 | fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". 21 | fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". 22 | ! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow computing (fx* 2)". 23 | fx.mo:Expected error in mat fx*: "fx*: is not a fixnum". 24 | fx.mo:Expected error in mat fx*: "fx*: <-int> is not a fixnum". 25 | fx.mo:Expected error in mat fx*: "fx*: #f is not a fixnum". 26 | fx.mo:Expected error in mat fx*: "fx*: #f is not a fixnum". 27 | fx.mo:Expected error in mat r6rs:fx*: "fx*: (a . b) is not a fixnum". 28 | ! fx.mo:Expected error in mat r6rs:fx*: "fx*: fixnum overflow computing (fx* 2)". 29 | fx.mo:Expected error in mat r6rs:fx*: "fx*: is not a fixnum". 30 | fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". 31 | fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". 32 | -------------------------------------------------------------------------------- /mats/patch-compile-0-t-f-t: -------------------------------------------------------------------------------- 1 | *** output-compile-0-t-f-f-experr/errors-compile-0-t-f-f Fri Feb 24 19:38:21 2023 2 | --- output-compile-0-t-f-t-experr/errors-compile-0-t-f-t Fri Feb 24 19:41:49 2023 3 | *************** 4 | *** 4052,4058 **** 5 | misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". 6 | misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". 7 | misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". 8 | ! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 5". 9 | misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". 10 | misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". 11 | misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments 1 to #". 12 | --- 4052,4058 ---- 13 | misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". 14 | misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". 15 | misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". 16 | ! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 2". 17 | misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". 18 | misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". 19 | misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments 1 to #". 20 | *************** 21 | *** 7881,7891 **** 22 | 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". 23 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". 24 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". 25 | ! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". 26 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation ". 27 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation #f". 28 | ! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". 29 | ! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". 30 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 31 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 32 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 33 | --- 7881,7891 ---- 34 | 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". 35 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". 36 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". 37 | ! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 2". 38 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation ". 39 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation #f". 40 | ! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 2". 41 | ! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 2". 42 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 43 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 44 | 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 45 | -------------------------------------------------------------------------------- /mats/patch-compile-0-t-t-t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-compile-0-t-t-t -------------------------------------------------------------------------------- /mats/patch-compile-3-f-f-t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-compile-3-f-f-t -------------------------------------------------------------------------------- /mats/patch-compile-3-f-t-f: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-compile-3-f-t-f -------------------------------------------------------------------------------- /mats/patch-compile-3-f-t-t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-compile-3-f-t-t -------------------------------------------------------------------------------- /mats/patch-compile-3-t-f-f: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-compile-3-t-f-f -------------------------------------------------------------------------------- /mats/patch-compile-3-t-f-t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-compile-3-t-f-t -------------------------------------------------------------------------------- /mats/patch-compile-3-t-t-f: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-compile-3-t-t-f -------------------------------------------------------------------------------- /mats/patch-compile-3-t-t-t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-compile-3-t-t-t -------------------------------------------------------------------------------- /mats/patch-interpret-3-f-f-f: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-interpret-3-f-f-f -------------------------------------------------------------------------------- /mats/patch-interpret-3-f-t-f: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-interpret-3-f-t-f -------------------------------------------------------------------------------- /mats/patch-interpret-3-t-f-f: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-interpret-3-t-f-f -------------------------------------------------------------------------------- /mats/patch-interpret-3-t-t-f: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/mats/patch-interpret-3-t-t-f -------------------------------------------------------------------------------- /mats/thread-check.ss: -------------------------------------------------------------------------------- 1 | (define $threads (foreign-procedure "(cs)threads" () scheme-object)) 2 | (define $fib (lambda (x) (if (< x 2) 1 (+ ($fib (- x 1)) ($fib (- x 2)))))) 3 | (define $nthreads 1) 4 | (define $yield 5 | (let ([t (make-time 'time-duration 1000000 0)]) 6 | (lambda () (sleep t)))) 7 | (define $thread-check 8 | (lambda () 9 | (unless (memq (get-initial-thread) ($threads)) 10 | (errorf #f "initial thread is missing from list")) 11 | (let loop ([n 100] [nt (length ($threads))]) 12 | (cond 13 | [(<= nt $nthreads) 14 | (set! $nthreads nt) 15 | (collect)] 16 | [else 17 | ($yield) 18 | (let* ([ls ($threads)] [nnt (length ls)]) 19 | (cond 20 | [(< nnt nt) (loop n nnt)] 21 | [(= n 0) 22 | (set! $nthreads nnt) 23 | (errorf #f "extra threads running ~s" ls)] 24 | [else (loop (- n 1) nnt)]))])) 25 | #t)) 26 | -------------------------------------------------------------------------------- /pkg/rmpkg: -------------------------------------------------------------------------------- 1 | #! /bin/csh -f 2 | 3 | # rmpkg 4 | # Copyright 1984-2017 Cisco Systems, Inc. 5 | # 6 | # Licensed under the Apache License, Version 2.0 (the "License"); 7 | # you may not use this file except in compliance with the License. 8 | # You may obtain a copy of the License at 9 | # 10 | # http://www.apache.org/licenses/LICENSE-2.0 11 | # 12 | # Unless required by applicable law or agreed to in writing, software 13 | # distributed under the License is distributed on an "AS IS" BASIS, 14 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | # See the License for the specific language governing permissions and 16 | # limitations under the License. 17 | 18 | if ( $#argv != 1) then 19 | echo "Usage: sudo $0 release" 20 | echo " e.g.,: sudo $0 8.4" 21 | exit 1 22 | endif 23 | 24 | if ( `id -u` != 0 ) then 25 | echo "$0 must be run as root (e.g., via sudo)" 26 | exit 1 27 | endif 28 | 29 | set R = $1 30 | 31 | if (!(-e /usr/local/lib/csv$R)) then 32 | echo "(Petite) Chez Scheme Version $R doesn't appear to be installed" 33 | exit 34 | endif 35 | 36 | /bin/rm -rf /usr/local/bin/petite /usr/local/bin/scheme /usr/local/bin/scheme-script /usr/local/lib/csv$R /usr/local/share/man/man1/petite.1.gz /usr/local/share/man/man1/scheme.1.gz 37 | pkgutil --forget chezscheme 38 | -------------------------------------------------------------------------------- /release_notes/macros.stex: -------------------------------------------------------------------------------- 1 | \def\ChezScheme{\textsl{Chez Scheme}} 2 | \def\PetiteChezScheme{\textsl{Petite Chez Scheme}} 3 | \def\CSUG#1{\hyperlink{http://www.scheme.com/csug#1/}{\emph{Chez Scheme Version #1 User's Guide}}} 4 | \def\TSPL#1#2{\hyperlink{http://www.scheme.com/tspl#1/}{\emph{The Scheme Programming Language, #1#2 edition}}} 5 | -------------------------------------------------------------------------------- /release_notes/releasenotes.css: -------------------------------------------------------------------------------- 1 | BODY {background-color: #FFFFFF} 2 | A:link {color:#880000; text-decoration:underline} 3 | A:active {color:#880000; text-decoration:underline} 4 | A:visited {color:#000088; text-decoration:underline} 5 | A:hover {color:white; text-decoration:underline; background:#880000} 6 | 7 | A.plain:link {color:#880000; text-decoration:none} 8 | A.plain:active {color:#880000; text-decoration:none} 9 | A.plain:visited {color:#000088; text-decoration:none} 10 | A.plain:hover {color:white; text-decoration:none; background:#880000} 11 | 12 | A.static:link {color:#880000; text-decoration:underline} 13 | A.static:active {color:#880000; text-decoration:underline} 14 | A.static:visited {color:#880000; text-decoration:underline} 15 | A.static:hover {color:white; text-decoration:underline; background:#880000} 16 | 17 | A.plainstatic:link {color:#880000; text-decoration:none} 18 | A.plainstatic:active {color:#880000; text-decoration:none} 19 | A.plainstatic:visited {color:#880000; text-decoration:none} 20 | A.plainstatic:hover {color:white; text-decoration:none; background:#880000} 21 | 22 | A.ref:link {color:#880000; text-decoration:underline} 23 | A.ref:active {color:#880000; text-decoration:underline} 24 | A.ref:visited {color:#880000; text-decoration:underline} 25 | A.ref:hover {color:white; text-decoration:underline; background:#880000} 26 | 27 | A.plainlink:link {color:#880000; text-decoration:none} 28 | A.plainlink:active {color:#880000; text-decoration:none} 29 | A.plainlink:visited {color:#880000; text-decoration:none} 30 | A.plainlink:hover {color:white; text-decoration:none; background:#880000} 31 | 32 | A.toc:link {color:#000088; text-decoration:none} 33 | A.toc:active {color:#000088; text-decoration:none} 34 | A.toc:visited {color:#000088; text-decoration:none} 35 | A.toc:hover {color:white; text-decoration:none; background:#000088} 36 | 37 | input.default { background: #ffffff; color: #000000; vertical-align: middle} 38 | 39 | H1, H2 { margin-top: 1em; margin-bottom: 1em } 40 | H3, H4, H5, H6 { margin-top: 1em; margin-bottom: 0em } 41 | 42 | H1, H2 {color: #880000} 43 | H3, H4 {color: #000088} 44 | H1 {font-size: 2em} 45 | H2 {font-size: 1.5em} 46 | H3 {font-size: 1.17em} 47 | H1, H2, H3, H4 {font-weight: bold} 48 | 49 | table.indent {margin-left: 20px} 50 | 51 | .pruned{ color: red; } 52 | .inserted{ color: green; } 53 | .attr{ font-weight: bold; } 54 | .attrvalue{ color: blue; } 55 | .tag{ color: navy; font-weight: bold; } 56 | .entity{ color: purple; font-weight: bold; } 57 | .errflag{ color: red; font-weight: bold; } 58 | -------------------------------------------------------------------------------- /release_notes/scheme.sty: -------------------------------------------------------------------------------- 1 | \usepackage{color} 2 | \def\transerr#1{\begingroup\slshape} 3 | \def\transin#1{\begingroup\color{red}} 4 | \def\transout#1{\begingroup\color{blue}} 5 | \def\endtranserr#1{\endgroup} 6 | \def\endtransin#1{\endgroup} 7 | \def\endtransout#1{\endgroup} 8 | 9 | \newskip\ttglue 10 | \let\ninefivett=\tt % \font\ninefivett=cmtt9 at 9.5pt 11 | \ttglue=.5em plus .25em minus .15em 12 | \newskip\schemeindent 13 | \schemeindent=0pt 14 | {\obeyspaces\global\let =\ } 15 | \def\schtilde{\raisebox{-.5ex}{\hbox{\char`\~}}} 16 | \def\schdot{.} 17 | \def\schcarat{\char`\^} 18 | \def\schbackslash{\char`\\} 19 | \def\schatsign{\char`\@} 20 | \def\schunderscore{\char`\_} 21 | \def\schlbrace{\char`\{} 22 | \def\schrbrace{\char`\}} 23 | \def\scheme#1{\mbox{\ttfamily\ninefivett\frenchspacing\spaceskip=\ttglue#1}} 24 | 25 | \def\schemeblankline{\par\beforeschemedisplay} 26 | \def\schemelinestart{{\leavevmode\hbox{\hskip \schemeindent\relax}}} 27 | %%% handle numbered lines in scheme.sty and scheme.hsty 28 | %%% ---have scheme-prep produce only \schemelinestart 29 | \def\schemelinestartnumbered#1{{\leavevmode\hbox{\hbox to 1em {\hfil{\rm #1}} \hskip .5\schemeindent\relax}}} 30 | 31 | \def\noskip\schemedisplay{\begingroup% 32 | \parindent=0pt% 33 | \parskip=0pt% 34 | \def\becomes{\hbox to 2em{\hfil$\rightarrow$\hfil}}% 35 | \def\is{\hbox to 2em{\hfil$\Rightarrow$\hfil}}% 36 | \def\si{\hbox to 2em{\hfil}}% 37 | \interlinepenalty=2000% 38 | \baselineskip=11pt plus 1pt\ninefivett\obeyspaces\frenchspacing} 39 | \def\schemedisplay{\beforeschemedisplay\noskip\schemedisplay} 40 | \def\longcode\schemedisplay{\penalty-200\vskip 8pt plus 4pt% 41 | \kern3pt\hrule\kern5pt\nobreak\noskip\schemedisplay} 42 | \def\endschemedisplay{\par\endgroup\afterschemedisplay} 43 | \def\var#1{{\normalsize\textrm{\textit{#1}}}} 44 | \def\raw#1{#1} 45 | \def\beforeschemedisplay{\penalty-100\vskip\parskip\vskip5pt} 46 | \def\afterschemedisplay{\penalty-200\vskip5pt} 47 | 48 | -------------------------------------------------------------------------------- /rpm/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile 2 | # Copyright 1984-2017 Cisco Systems, Inc. 3 | # 4 | # Licensed under the Apache License, Version 2.0 (the "License"); 5 | # you may not use this file except in compliance with the License. 6 | # You may obtain a copy of the License at 7 | # 8 | # http://www.apache.org/licenses/LICENSE-2.0 9 | # 10 | # Unless required by applicable law or agreed to in writing, software 11 | # distributed under the License is distributed on an "AS IS" BASIS, 12 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | # See the License for the specific language governing permissions and 14 | # limitations under the License. 15 | 16 | version = 9.9.9 17 | release = 1 18 | m := $(shell find ../bin/* -type d | xargs basename) 19 | arch := $(shell if test "$(m)" == "i3le" ; then echo i686 ; elif test "$(m)" == "a6le" ; then echo x86_64 ; else echo UNKNOWN ; fi) 20 | DOTUSER := $(shell ls -ld . | sed -e 's/[^ ]* *[^ ]* *\([^ ]*\).*/\1/') 21 | DOTGROUP := $(shell ls -ldg . | sed -e 's/[^ ]* *[^ ]* *\([^ ]*\).*/\1/') 22 | TMP := $(shell pwd)/tmp 23 | SPEC = $(TMP)/ChezScheme-$(version)-$(arch)-$(release).spec 24 | RELEASE = csv$(version) 25 | TARBALL = $(RELEASE)-$(m).tar.gz 26 | RPM = ChezScheme-$(version)-$(release).$(arch).rpm 27 | 28 | 29 | $(RPM): $(TMP)/$(RPM) 30 | sudo install -m 644 -o $(DOTUSER) -g $(DOTGROUP) $(TMP)/${RPM} . 31 | 32 | $(TMP)/$(RPM): $(SPEC) $(TMP)/$(TARBALL) 33 | sudo setarch $(arch) rpmbuild\ 34 | --target $(arch)\ 35 | --define "_topdir $(TMP)" \ 36 | --define "_srcrpmdir $(TMP)" \ 37 | --define "_rpmdir $(TMP)" \ 38 | --define "_sourcedir $(TMP)" \ 39 | --define "_builddir $(TMP)" \ 40 | --define "_rpmfilename %{NAME}-%{VERSION}-%{RELEASE}.%{ARCH}.rpm" \ 41 | --quiet -ba $(SPEC) 42 | 43 | $(SPEC): $(TMP) 44 | echo 'Summary: Chez Scheme: A high-performance version of Scheme' > $(SPEC) 45 | echo 'Name: ChezScheme' >> $(SPEC) 46 | echo 'Version: $(version)' >> $(SPEC) 47 | echo 'Release: $(release)' >> $(SPEC) 48 | echo 'Provides: ChezScheme-runtime-{VERSION}' >> $(SPEC) 49 | echo 'License: Apache 2.0' >> $(SPEC) 50 | echo 'URL: http://github.com/cisco/chezscheme' >> $(SPEC) 51 | echo 'Group: Development/Languages' >> $(SPEC) 52 | echo 'Source0: $(TARBALL)' >> $(SPEC) 53 | echo 'BuildRoot: %{_tmppath}/%{name}' >> $(SPEC) 54 | echo '%description' >> $(SPEC) 55 | echo 'Chez Scheme is a programming language and an implementation of that language,' >> $(SPEC) 56 | echo 'with supporting tools and documentation.' >> $(SPEC) 57 | echo '' >> $(SPEC) 58 | echo '%prep' >> $(SPEC) 59 | echo '' >> $(SPEC) 60 | echo '%setup -T -b 0 -n $(RELEASE)' >> $(SPEC) 61 | echo '' >> $(SPEC) 62 | echo '#%build' >> $(SPEC) 63 | echo '' >> $(SPEC) 64 | echo '%install' >> $(SPEC) 65 | echo 'make install TempRoot=%{buildroot}' >> $(SPEC) 66 | echo '' >> $(SPEC) 67 | echo '%files' >> $(SPEC) 68 | echo '#%doc NOTICE' >> $(SPEC) 69 | echo '#%doc LICENSE' >> $(SPEC) 70 | echo '/usr/lib/$(RELEASE)' >> $(SPEC) 71 | echo '/usr/bin/petite' >> $(SPEC) 72 | echo '/usr/bin/scheme' >> $(SPEC) 73 | echo '/usr/bin/scheme-script' >> $(SPEC) 74 | echo '/usr/share/man/man1/petite.1.gz' >> $(SPEC) 75 | echo '/usr/share/man/man1/scheme.1.gz' >> $(SPEC) 76 | 77 | $(TMP)/$(TARBALL): $(TMP) ../bintar/$(TARBALL) 78 | cp ../bintar/$(TARBALL) $(TMP) 79 | 80 | $(TMP): 81 | mkdir $(TMP) 82 | 83 | clean: 84 | rm -rf $(TMP) $(RPM) 85 | -------------------------------------------------------------------------------- /s/.gitattributes: -------------------------------------------------------------------------------- 1 | update-revision export-subst 2 | -------------------------------------------------------------------------------- /s/a6.def: -------------------------------------------------------------------------------- 1 | (define-constant architecture 'x86_64) 2 | (define-constant ptr-bits 64) 3 | 4 | (define-constant asm-arg-reg-max 5) 5 | (define-constant asm-arg-reg-cnt 3) 6 | (define-constant asm-fpreg-max 8) 7 | 8 | (define-constant native-endianness 'little) 9 | 10 | (define-constant unaligned-floats #t) 11 | (define-constant unaligned-integers #t) 12 | (define-constant integer-divide-instruction #t) 13 | (define-constant popcount-instruction #t) 14 | -------------------------------------------------------------------------------- /s/a6nt.def: -------------------------------------------------------------------------------- 1 | ;;; a6nt.def 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (define-constant machine-type (constant machine-type-a6nt)) 17 | (features iconv expeditor windows) 18 | (include "a6.def") 19 | (include "nt.def") 20 | (include "default.def") 21 | -------------------------------------------------------------------------------- /s/arm32.def: -------------------------------------------------------------------------------- 1 | (define-constant architecture 'arm32) 2 | (define-constant ptr-bits 32) 3 | 4 | (define-constant asm-arg-reg-max 5) 5 | (define-constant asm-arg-reg-cnt 3) 6 | (define-constant asm-fpreg-max 2) 7 | 8 | (define-constant native-endianness 'little) 9 | 10 | (define-constant max-float-alignment 8) 11 | (define-constant max-integer-alignment 8) 12 | 13 | (define-constant unaligned-floats #f) 14 | (define-constant unaligned-integers #t) 15 | 16 | (define-constant arm-isa-version 6) 17 | -------------------------------------------------------------------------------- /s/arm64.def: -------------------------------------------------------------------------------- 1 | (define-constant architecture 'arm64) 2 | (define-constant ptr-bits 64) 3 | 4 | (define-constant asm-arg-reg-max 14) 5 | (define-constant asm-arg-reg-cnt 3) 6 | (define-constant asm-fpreg-max 6) 7 | 8 | (define-constant native-endianness 'little) 9 | 10 | (define-constant unaligned-floats #f) 11 | (define-constant unaligned-integers #t) 12 | (define-constant integer-divide-instruction #t) 13 | (define-constant popcount-instruction #t) 14 | -------------------------------------------------------------------------------- /s/arm64nt.def: -------------------------------------------------------------------------------- 1 | (define-constant machine-type (constant machine-type-arm64nt)) 2 | (features iconv expeditor windows) 3 | (include "arm64.def") 4 | (include "nt.def") 5 | (include "default.def") 6 | -------------------------------------------------------------------------------- /s/boot.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | setlocal 3 | 4 | set M=%1 5 | set H=%2 6 | 7 | set WORKAREA=%M% 8 | 9 | if "%WORKAREA%"=="" goto needargument 10 | 11 | if "%H%"=="" H=pb 12 | 13 | xcopy /s /i /d /y s xc-%WORKAREA%\s 14 | xcopy /s /i /d /y nanopass xc-%WORKAREA%\nanopass 15 | xcopy /s /i /d /y unicode xc-%WORKAREA%\unicode 16 | 17 | cd xc-%WORKAREA%\s 18 | ..\..\%H%\bin\%H%\scheme.exe --script make-xpatch.ss %M% macro 19 | ..\..\%H%\bin\%H%\scheme.exe --script make-xpatch.ss %M% build 20 | cd ..\.. 21 | 22 | xcopy /s /i /d /y xc-%WORKAREA%\boot\%M% boot\%M% 23 | 24 | goto donebuilding 25 | 26 | :needargument 27 | 28 | echo Please supply the machine name as an argument 29 | exit /B 1 30 | 31 | :donebuilding 32 | -------------------------------------------------------------------------------- /s/cback.ss: -------------------------------------------------------------------------------- 1 | ;;; cback.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (begin 17 | (current-eval compile) 18 | (define $compiler-is-loaded? #t) 19 | ) 20 | -------------------------------------------------------------------------------- /s/default.def: -------------------------------------------------------------------------------- 1 | ;; types that are right for most platforms: 2 | (define-constant-default int-bits 32) 3 | (define-constant-default short-bits 16) 4 | (define-constant-default typedef-ptr "void *") 5 | (define-constant-default typedef-iptr "long") 6 | (define-constant-default typedef-uptr "unsigned long") 7 | (define-constant-default typedef-i8 "char") 8 | (define-constant-default typedef-u8 "unsigned char") 9 | (define-constant-default typedef-i16 "short") 10 | (define-constant-default typedef-u16 "unsigned short") 11 | (define-constant-default typedef-i32 "int") 12 | (define-constant-default typedef-u32 "unsigned int") 13 | (define-constant-default typedef-i64 (if (= 64 (constant ptr-bits)) 14 | "long" 15 | "long long")) 16 | (define-constant-default typedef-u64 (if (= 64 (constant ptr-bits)) 17 | "unsigned long" 18 | "unsigned long long")) 19 | (define-constant-default typedef-string-char "unsigned int") 20 | (define-constant-default wchar-bits 32) 21 | 22 | ;; derivations that are usually right 23 | (define-constant-default address-bits (constant ptr-bits)) 24 | (define-constant-default size_t-bits (constant ptr-bits)) 25 | (define-constant-default ptrdiff_t-bits (constant ptr-bits)) 26 | (define-constant-default long-bits (constant ptr-bits)) 27 | (define-constant-default long-long-bits 64) 28 | (define-constant-default max-float-alignment (if (= 64 (constant ptr-bits)) 29 | 8 30 | 4)) 31 | (define-constant-default max-integer-alignment (if (= 64 (constant ptr-bits)) 32 | 8 33 | 4)) 34 | (define-constant-default special-initial-field-alignment? #f) 35 | (define-constant-default time-t-bits (constant ptr-bits)) 36 | (define-constant-default segment-table-levels (if (= 64 (constant ptr-bits)) 37 | 3 38 | 1)) 39 | 40 | (define-constant-default align-rpheader #f) 41 | 42 | ;; instruction availability (defaults to unavailable) 43 | (define-constant-default integer-divide-instruction #f) 44 | (define-constant-default popcount-instruction #f) 45 | (define-constant-default sqrt-instruction #f) 46 | (define-constant-default fence-instruction #f) 47 | (define-constant-default software-floating-point #f) 48 | -------------------------------------------------------------------------------- /s/env.ss: -------------------------------------------------------------------------------- 1 | ;;; env.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (begin 17 | ($make-base-modules) 18 | ($make-rnrs-libraries) 19 | ) 20 | -------------------------------------------------------------------------------- /s/event.ss: -------------------------------------------------------------------------------- 1 | ;;; event.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (let () 17 | (define stop-event-timer 18 | (lambda () 19 | ($set-timer (most-positive-fixnum)))) 20 | 21 | (define start-event-timer 22 | (lambda () 23 | ; set timer by way of $event, so recurrent calls to "set-timer" or 24 | ; "{dis,en}able-interrupts" can't prevent interrupts 25 | ($event))) 26 | 27 | (set! set-timer 28 | (lambda (ticks) 29 | (unless (and (fixnum? ticks) (fx>= ticks 0)) 30 | ($oops 'set-timer "~s is not a nonnegative fixnum" ticks)) 31 | (let ([ticks-left (stop-event-timer)]) 32 | (let ([t ($tc-field 'timer-ticks ($tc))]) 33 | (if (fx> ticks 0) 34 | (begin 35 | ($tc-field 'something-pending ($tc) #t) 36 | ($tc-field 'timer-ticks ($tc) ticks)) 37 | ($tc-field 'timer-ticks ($tc) #f)) 38 | (if (fx= ($tc-field 'disable-count ($tc)) 0) 39 | (let ([old (if t (fx+ t ticks-left) 0)]) 40 | (start-event-timer) 41 | old) 42 | (or t 0)))))) 43 | 44 | (set! disable-interrupts 45 | (lambda () 46 | (let ([ticks (stop-event-timer)]) 47 | (let ([disable-count ($tc-field 'disable-count ($tc))]) 48 | (when (and (fx= disable-count 0) ($tc-field 'timer-ticks ($tc))) 49 | ($tc-field 'timer-ticks ($tc) (fx+ ($tc-field 'timer-ticks ($tc)) ticks))) 50 | (when (fx= disable-count (most-positive-fixnum)) 51 | ($oops 'disable-interrupts 52 | "too many consecutive calls to disable-interrupts")) 53 | (let ([disable-count (fx+ disable-count 1)]) 54 | ($tc-field 'disable-count ($tc) disable-count) 55 | disable-count))))) 56 | 57 | (set! enable-interrupts 58 | (lambda () 59 | (let ([ticks (stop-event-timer)]) 60 | (let ([disable-count (fx- ($tc-field 'disable-count ($tc)) 1)]) 61 | (case disable-count 62 | [(-1) ($set-timer ticks) 0] 63 | [(0) ($tc-field 'disable-count ($tc) 0) 64 | (start-event-timer) 65 | 0] 66 | [else ($tc-field 'disable-count ($tc) disable-count) 67 | disable-count]))))) 68 | ) 69 | -------------------------------------------------------------------------------- /s/foreign.ss: -------------------------------------------------------------------------------- 1 | ;;; foreign.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (let () 17 | (define $foreign-address-name 18 | (foreign-procedure "(cs)foreign_address_name" (void*) 19 | string)) 20 | 21 | (define $remove-foreign-entry 22 | (foreign-procedure "(cs)remove_foreign_entry" 23 | (string) scheme-object)) 24 | 25 | (set! $foreign-entries 26 | (foreign-procedure "(cs)foreign_entries" () 27 | scheme-object)) 28 | 29 | (set! remove-foreign-entry 30 | (lambda (entry) 31 | (unless (string? entry) 32 | ($oops 'remove-foreign-entry "~s is not a string" entry)) 33 | (unless ($remove-foreign-entry entry) 34 | ($oops 'remove-foreign-entry "no entry for ~s" entry)))) 35 | 36 | (let () 37 | (define lookup 38 | (foreign-procedure "(cs)lookup_foreign_entry" (string) 39 | void*)) 40 | (set-who! foreign-entry? 41 | (lambda (str) 42 | (unless (string? str) ($oops who "~s is not a string" str)) 43 | (if (eqv? (lookup str) 0) #f #t))) 44 | (set-who! foreign-entry 45 | (lambda (str) 46 | (unless (string? str) ($oops who "~s is not a string" str)) 47 | (let ([x (lookup str)]) 48 | (when (eqv? x 0) ($oops who "no entry for ~s" str)) 49 | x)))) 50 | 51 | (set-who! foreign-address-name 52 | (lambda (n) 53 | (define void*? 54 | (constant-case ptr-bits 55 | [(32) $integer-32?] 56 | [(64) $integer-64?])) 57 | (unless (void*? n) ($oops who "~s is not a valid address" n)) 58 | ($foreign-address-name n))) 59 | 60 | (set! load-shared-object 61 | (if (foreign-entry? "(cs)load_shared_object") 62 | (let () 63 | (define lso 64 | (foreign-procedure "(cs)load_shared_object" 65 | (string) 66 | void)) 67 | (lambda (x) 68 | (unless (or (string? x) (eq? x #f)) 69 | ($oops 'load-shared-object "invalid path ~s" x)) 70 | (lso x))) 71 | (lambda args 72 | ($oops 'load-shared-object "not supported")))) 73 | ) ;let 74 | -------------------------------------------------------------------------------- /s/hashtable-types.ss: -------------------------------------------------------------------------------- 1 | ;;; hashtable-types.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (define-record-type (hashtable make-xht xht?) 17 | (fields (immutable type xht-type) (immutable mutable? xht-mutable?)) 18 | (nongenerative #{hashtable bu811z2onf9o6tfc-0})) 19 | 20 | (define-record-type ht 21 | (parent hashtable) 22 | (fields (mutable vec) (mutable minlen) (mutable size)) 23 | (nongenerative #{ht bu811z2onf9o6tfc-6})) 24 | 25 | (define-record-type eq-ht 26 | (parent ht) 27 | (fields (immutable subtype)) ; eq-hashtable-subtype-{normal,weak,ephemeron} 28 | (nongenerative #{eq-ht icguu8mlhm1y7ywsairxck-0}) 29 | (sealed #t)) 30 | 31 | (define-record-type symbol-ht 32 | (parent ht) 33 | (fields (immutable equiv?)) 34 | (nongenerative #{symbol-ht bu811z2onf9o6tfc-8}) 35 | (sealed #t)) 36 | 37 | (define-record-type gen-ht 38 | (parent ht) 39 | (fields (immutable hash) (immutable equiv?) (immutable eqht)) 40 | (nongenerative #{gen-ht bu811z2onf9o6tfc-9}) 41 | (sealed #t)) 42 | 43 | (define-record-type eqv-ht 44 | (parent hashtable) 45 | (fields (immutable eqht) (immutable genht)) 46 | (nongenerative #{eqv-ht bu811z2onf9o6tfc-4}) 47 | (sealed #t)) 48 | -------------------------------------------------------------------------------- /s/i3.def: -------------------------------------------------------------------------------- 1 | (define-constant architecture 'x86) 2 | (define-constant ptr-bits 32) 3 | 4 | (define-constant asm-arg-reg-max 1) 5 | (define-constant asm-arg-reg-cnt 1) 6 | (define-constant asm-fpreg-max 2) 7 | 8 | (define-constant native-endianness 'little) 9 | 10 | (define-constant unaligned-floats #t) 11 | (define-constant unaligned-integers #t) 12 | (define-constant integer-divide-instruction #t) 13 | -------------------------------------------------------------------------------- /s/i3nt.def: -------------------------------------------------------------------------------- 1 | ;;; i3nt.def 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (define-constant machine-type (constant machine-type-i3nt)) 17 | (features iconv expeditor windows) 18 | (include "i3.def") 19 | (include "nt.def") 20 | (include "default.def") 21 | -------------------------------------------------------------------------------- /s/i3qnx.def: -------------------------------------------------------------------------------- 1 | ;;; i3qnx.def 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (define-constant machine-type (constant machine-type-i3qnx)) 17 | (features iconv expeditor) 18 | (define-constant max-integer-alignment 8) 19 | (define-constant segment-table-levels 2) 20 | (include "i3.def") 21 | (include "default.def") 22 | -------------------------------------------------------------------------------- /s/nt.def: -------------------------------------------------------------------------------- 1 | (define-constant wchar-bits 16) 2 | (define-constant time-t-bits 64) 3 | (define-constant max-float-alignment 8) 4 | (define-constant max-integer-alignment 8) 5 | 6 | (define-constant typedef-iptr (if (= 64 (constant ptr-bits)) 7 | "long long int" 8 | "long")) 9 | (define-constant typedef-uptr (if (= 64 (constant ptr-bits)) 10 | "unsigned long long int" 11 | "unsigned long")) 12 | 13 | (define-constant typedef-i64 "long long") 14 | (define-constant typedef-u64 "unsigned long long") 15 | 16 | (define-constant long-bits 32) 17 | -------------------------------------------------------------------------------- /s/patch.ss: -------------------------------------------------------------------------------- 1 | ;;; patch.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (printf "loading ~s cross compiler~%" (constant machine-type-name)) 17 | 18 | ; (current-expand (lambda args (apply sc-expand args))) 19 | ; (current-eval (lambda args (apply interpret args))) 20 | 21 | (when-feature pthreads 22 | (meta-cond 23 | [(not (threaded?)) 24 | ; we must be cross-compiling from nonthreaded to threaded version 25 | ; handle thread parameter creation 26 | (define-syntax with-mutex 27 | (syntax-rules () 28 | [(_ mexp e0 e1 ...) (begin e0 e1 ...)])) 29 | (set! make-thread-parameter make-parameter) 30 | (set! mutex-acquire (lambda (m) (void))) 31 | (set! mutex-release (lambda (m) (void))) 32 | (set! $tc-mutex (void))])) 33 | 34 | -------------------------------------------------------------------------------- /s/pb.def: -------------------------------------------------------------------------------- 1 | (define-constant machine-type (constant machine-type-pb)) 2 | (features) 3 | 4 | (include "pbcommon64.def") 5 | (include "pbcommon.def") 6 | (include "default.def") 7 | -------------------------------------------------------------------------------- /s/pbarch.def: -------------------------------------------------------------------------------- 1 | ;; This template is turned into a machine-specific ".def" file 2 | ;; by the `workarea` script 3 | 4 | (define-constant machine-type (constant machine-type-$(M))) 5 | (features iconv expeditor pbchunk) 6 | 7 | (define-constant-default native-endianness '$(Mend)) 8 | 9 | (include "pbcommon$(Mword).def") 10 | (include "pbcommon.def") 11 | (include "default.def") 12 | -------------------------------------------------------------------------------- /s/pbcommon.def: -------------------------------------------------------------------------------- 1 | (define-constant architecture 'pb) 2 | 3 | (define-constant typedef-i8 "int8_t") 4 | (define-constant typedef-u8 "uint8_t") 5 | (define-constant typedef-i16 "int16_t") 6 | (define-constant typedef-u16 "uint16_t") 7 | (define-constant typedef-i32 "int32_t") 8 | (define-constant typedef-u32 "uint32_t") 9 | (define-constant typedef-i64 "int64_t") 10 | (define-constant typedef-u64 "uint64_t") 11 | (define-constant typedef-string-char "uint32_t") 12 | 13 | (define-constant asm-arg-reg-max 7) 14 | (define-constant asm-arg-reg-cnt 3) 15 | (define-constant asm-fpreg-max 8) 16 | 17 | (define-constant max-float-alignment 8) 18 | (define-constant max-integer-alignment 8) 19 | 20 | (define-constant-default native-endianness 'unknown) 21 | 22 | (define-constant unaligned-floats #f) 23 | (define-constant unaligned-integers #f) 24 | 25 | (define-constant integer-divide-instruction #t) 26 | 27 | (include "default.def") 28 | -------------------------------------------------------------------------------- /s/pbcommon32.def: -------------------------------------------------------------------------------- 1 | (define-constant ptr-bits 32) 2 | 3 | (define-constant typedef-ptr "uint32_t") ; not "void *" 4 | (define-constant typedef-iptr "int32_t") 5 | (define-constant typedef-uptr "uint32_t") 6 | -------------------------------------------------------------------------------- /s/pbcommon64.def: -------------------------------------------------------------------------------- 1 | (define-constant-default ptr-bits 64) 2 | 3 | (define-constant-default typedef-ptr "uint64_t") ; not "void *" 4 | (define-constant-default typedef-iptr "int64_t") 5 | (define-constant-default typedef-uptr "uint64_t") 6 | 7 | (define-constant align-rpheader #t) 8 | -------------------------------------------------------------------------------- /s/ppc32.def: -------------------------------------------------------------------------------- 1 | (define-constant architecture 'ppc32) 2 | (define-constant ptr-bits 32) 3 | 4 | (define-constant asm-arg-reg-max 14) 5 | (define-constant asm-arg-reg-cnt 3) 6 | (define-constant asm-fpreg-max 2) 7 | 8 | (define-constant native-endianness 'big) 9 | 10 | (define-constant-default max-float-alignment 8) 11 | (define-constant-default max-integer-alignment 8) 12 | 13 | (define-constant unaligned-floats #f) 14 | (define-constant unaligned-integers #t) 15 | -------------------------------------------------------------------------------- /s/ppc32osx.def: -------------------------------------------------------------------------------- 1 | ;;; ppc32osx.def 2 | 3 | (define-constant machine-type (constant machine-type-ppc32osx)) 4 | (features iconv expeditor) 5 | (define-constant max-float-alignment 4) 6 | (define-constant max-integer-alignment 4) 7 | (define-constant special-initial-field-alignment? #t) 8 | (include "ppc32.def") 9 | (include "default.def") 10 | -------------------------------------------------------------------------------- /s/primref.ss: -------------------------------------------------------------------------------- 1 | ;;; primref.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (define-record-type primref 17 | (nongenerative #{primref a0xltlrcpeygsahopkplcn-2}) 18 | (sealed #t) 19 | (fields name flags arity)) 20 | 21 | (define primref-level 22 | (lambda (pr) 23 | (if (all-set? (prim-mask unsafe) (primref-flags pr)) 3 2))) 24 | -------------------------------------------------------------------------------- /s/primvars.ss: -------------------------------------------------------------------------------- 1 | ;;; primvars.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (let () 17 | (include "primref.ss") 18 | 19 | (define record-prim! 20 | (lambda (prim unprefixed flags arity arguments-type rest-type last-type result-type pred-type) 21 | (unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed)) 22 | ($sputprop prim '*flags* flags) 23 | (when arguments-type ($sputprop prim '*arguments-type* arguments-type)) 24 | (when rest-type ($sputprop prim '*rest-type* rest-type)) 25 | (when last-type ($sputprop prim '*last-type* last-type)) 26 | (when result-type ($sputprop prim '*result-type* result-type)) 27 | (when pred-type ($sputprop prim '*pred-type* pred-type)) 28 | (when (any-set? (prim-mask (or primitive system)) flags) 29 | ($sputprop prim '*prim2* (make-primref prim flags arity)) 30 | ($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity))))) 31 | 32 | (define-syntax setup 33 | (lambda (x) 34 | (import priminfo) 35 | ; sort vector of primitive names so boot files compare equal 36 | (let ([v-prim (vector-sort (lambda (x y) (string<=? (symbol->string x) (symbol->string y))) (primvec))]) 37 | (let ([v-info (vector-map get-priminfo v-prim)]) 38 | #`(vector-for-each record-prim! 39 | '#,(datum->syntax #'* v-prim) 40 | '#,(datum->syntax #'* (vector-map priminfo-unprefixed v-info)) 41 | '#,(datum->syntax #'* (vector-map priminfo-mask v-info)) 42 | '#,(datum->syntax #'* (vector-map priminfo-arity v-info)) 43 | '#,(datum->syntax #'* (vector-map priminfo-arguments-type v-info)) 44 | '#,(datum->syntax #'* (vector-map priminfo-rest-type v-info)) 45 | '#,(datum->syntax #'* (vector-map priminfo-last-type v-info)) 46 | '#,(datum->syntax #'* (vector-map priminfo-result-type v-info)) 47 | '#,(datum->syntax #'* (vector-map priminfo-pred-type v-info))))))) 48 | 49 | (for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist)) 50 | setup) 51 | -------------------------------------------------------------------------------- /s/reboot.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | (require "../makefiles/lib.zuo" 3 | "machine.zuo") 4 | 5 | (provide reboot) 6 | 7 | (module+ main 8 | (command-line 9 | :once-each 10 | [flags ("--scheme") command "Run Scheme as " 11 | (hash-set flags 'command command)] 12 | [flags ("--target") machine "Create bootfiles for " 13 | (hash-set flags 'target machine)] 14 | [flags ("--dest") dest "Write boot files to /boot/" 15 | (hash-set flags 'dest dest)] 16 | :args 17 | () 18 | (lambda (flags) 19 | (define command (hash-ref flags 'command "scheme")) 20 | (define host (get-host-from-scheme command)) 21 | (define target (hash-ref flags 'target host)) 22 | (define dest (hash-ref flags 'dest ".")) 23 | 24 | (reboot 'infer target command (hash 'out-dir dest))))) 25 | 26 | (define (reboot given-host target command [options (hash)]) 27 | (define host (if (eq? given-host 'infer) 28 | (get-host-from-scheme command) 29 | given-host)) 30 | (alert (~a "Host: " host)) 31 | (alert (~a "Target: " target)) 32 | 33 | (define work-dir (hash-ref options 'work-dir ".")) 34 | (define xc (build-path work-dir (~a "xc-" target))) 35 | (alert (~a "Working in: " xc)) 36 | 37 | (define s-dir (build-path xc "s")) 38 | (define host-dir (build-path xc "host")) 39 | 40 | (mkdir-p s-dir) 41 | (mkdir-p host-dir) 42 | 43 | (define host-config (get-machine-files host (m->arch host))) 44 | (define target-config (get-machine-files target (m->arch target))) 45 | 46 | ((cdar host-config) (build-path host-dir "machine.def") #f) 47 | ((cdar target-config) (build-path s-dir "machine.def") #f) 48 | 49 | (define (dir-arg dir) 50 | (string->shell (find-relative-path (at-source "..") dir))) 51 | 52 | (shell/wait command "--script" "s/reboot.ss" 53 | (dir-arg s-dir) (dir-arg host-dir) (dir-arg (hash-ref options 'out-dir work-dir)) 54 | (hash-set* (hash-ref options 'shell-options (hash)) 55 | 'no-thread? #t 56 | 'dir (at-source ".."))) 57 | 58 | (void)) 59 | 60 | (define (get-host-from-scheme command) 61 | (let ([r (shell command "-q" (hash 'stdin 'pipe 'stdout 'pipe))]) 62 | (fd-write (hash-ref r 'stdin) "(machine-type)\n") 63 | (fd-close (hash-ref r 'stdin)) 64 | (define line (fd-read (hash-ref r 'stdout) eof)) 65 | (car (string-split line "\n")))) 66 | -------------------------------------------------------------------------------- /s/rv64.def: -------------------------------------------------------------------------------- 1 | (define-constant architecture 'riscv64) 2 | (define-constant ptr-bits 64) 3 | 4 | (define-constant asm-arg-reg-max 15) 5 | (define-constant asm-arg-reg-cnt 3) 6 | (define-constant asm-fpreg-max 6) 7 | 8 | (define-constant native-endianness 'little) 9 | (define-constant unaligned-floats #t) 10 | (define-constant unaligned-integers #t) 11 | (define-constant integer-divide-instruction #t) 12 | -------------------------------------------------------------------------------- /s/setup.ss: -------------------------------------------------------------------------------- 1 | ;;; setup.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (include "debug.ss") 17 | 18 | (unless (getenv "DEBUGNOW") 19 | (base-exception-handler 20 | (lambda (c) 21 | (fresh-line) 22 | (display-condition c) 23 | (newline) 24 | (reset))) 25 | 26 | (keyboard-interrupt-handler 27 | (lambda () 28 | (display "interrupted---aborting\n") 29 | (reset))) 30 | ) 31 | 32 | -------------------------------------------------------------------------------- /s/strip-types.ss: -------------------------------------------------------------------------------- 1 | (define-datatype #{fasl striprur0zx3-fasl} 2 | (#{entry striprur0zx3-0} situation fasl) 3 | (#{header striprur0zx3-1} version machine dependencies) 4 | (#{pair striprur0zx3-2} vfasl) 5 | (#{tuple striprur0zx3-3} ty vfasl) 6 | (#{string striprur0zx3-4} ty string) 7 | (#{gensym striprur0zx30-5} pname uname) 8 | (#{vector striprur0zx3-6} ty vfasl) 9 | (#{fxvector striprur0zx3-7} viptr) 10 | (#{bytevector striprur0zx3-9} ty bv) 11 | (#{stencil-vector striprur0zx0-sv} mask vfasl sys?) 12 | (#{record striprur0zx3-10} maybe-uid size nflds rtd pad-ty* fld*) ; maybe-uid => rtd 13 | (#{rtd-ref striprur0zx3-11} uid) ; field info not recorded 14 | (#{closure striprur0zx3-12} offset c) 15 | (#{flonum striprur0zx3-13} high low) 16 | (#{small-integer striprur0zx3-14} iptr) 17 | (#{large-integer striprur0zx3-15} sign vuptr) 18 | (#{eq-hashtable striprur0zx3-16} mutable? subtype minlen veclen vpfasl) 19 | (#{symbol-hashtable striprur0zx3-17} mutable? minlen equiv veclen vpfasl) 20 | (#{code striprur0zx3-18} flags free name arity-mask info pinfo* bytes m vreloc) 21 | (#{atom striprur0zx3-19} ty uptr) 22 | (#{reloc striprur0zx3-20} type-etc code-offset item-offset fasl) 23 | (#{indirect striprur0zx3-21} g i)) 24 | 25 | (define-datatype #{field stripfur0zx3-field} 26 | (#{ptr stripfur0zx3-0} fasl) 27 | (#{byte stripfur0zx3-1} n) 28 | (#{iptr stripfur0zx3-2} n) 29 | (#{single stripfur0zx3-3} n) 30 | (#{double stripfur0zx3-4} high low)) 31 | 32 | 33 | ;; cooperates better with auto-indent than `fasl-case`: 34 | (define-syntax (fasl-case* stx) 35 | (syntax-case stx (else) 36 | [(_ target [(op fld ...) body ...] ... [else e-body ...]) 37 | #'(fasl-case target [op (fld ...) body ...] ... [else e-body ...])] 38 | [(_ target [(op fld ...) body ...] ...) 39 | #'(fasl-case target [op (fld ...) body ...] ...)])) 40 | 41 | ;; reverse quoting convention compared to `constant-case`: 42 | (define-syntax (constant-case* stx) 43 | (syntax-case stx (else) 44 | [(_ target [(const ...) body ...] ... [else e-body ...]) 45 | (with-syntax ([((val ...) ...) 46 | (map (lambda (consts) 47 | (map (lambda (const) 48 | (lookup-constant const)) 49 | consts)) 50 | (datum ((const ...) ...)))]) 51 | #'(case target [(val ...) body ...] ... [else e-body ...]))] 52 | [(_ target [(const ...) body ...] ...) 53 | #'(constant-case* target [(const ...) body ...] ... [else ($oops 'constant-case* "no matching case ~s" 'target)])])) 54 | -------------------------------------------------------------------------------- /s/ta6nt.def: -------------------------------------------------------------------------------- 1 | ;;; ta6nt.def 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (define-constant machine-type (constant machine-type-ta6nt)) 17 | (features iconv expeditor pthreads windows) 18 | (include "a6.def") 19 | (include "nt.def") 20 | (include "default.def") 21 | -------------------------------------------------------------------------------- /s/target-fixnum.ss: -------------------------------------------------------------------------------- 1 | ;; Don't try to use `meta-cond` to pick these implementations. The "target" 2 | ;; in `target-fixnum?` refers to the target of compilation at the point when 3 | ;; `target-fixnum?` is called. That can be different than the host for which 4 | ;; the implementation of `target-fixnum?` is being compiled. Using `meta-cond` 5 | ;; with `(fixnum-width)` compares to a *meta*-host: the machine being used to 6 | ;; compile the host-machine code of a compiler to the target. 7 | ;; 8 | ;; In terms of cross-compilation steps: 9 | ;; * building patch files: host is meta-host 10 | ;; * using patch files to build compiler: host is target 11 | ;; A `meta-cond` would compare the meta-host to the target, which is not 12 | ;; right for that second case. 13 | 14 | (define target-fixnum? 15 | (cond 16 | [(= (constant fixnum-bits) (fixnum-width)) fixnum?] 17 | [(< (constant fixnum-bits) (fixnum-width)) 18 | (lambda (x) 19 | (and (fixnum? x) 20 | (fx<= (constant most-negative-fixnum) x (constant most-positive-fixnum))))] 21 | [else 22 | (lambda (x) 23 | (or (fixnum? x) 24 | (and (bignum? x) 25 | (<= (constant most-negative-fixnum) x (constant most-positive-fixnum)))))])) 26 | 27 | (define target-bignum? 28 | (cond 29 | [(= (constant fixnum-bits) (fixnum-width)) bignum?] 30 | [(< (constant fixnum-bits) (fixnum-width)) 31 | (lambda (x) 32 | (or (bignum? x) 33 | (and (fixnum? x) 34 | (not (fx<= (constant most-negative-fixnum) x (constant most-positive-fixnum))))))] 35 | [else 36 | (lambda (x) 37 | (and (bignum? x) 38 | (not (<= (constant most-negative-fixnum) x (constant most-positive-fixnum)))))])) 39 | -------------------------------------------------------------------------------- /s/tarm64nt.def: -------------------------------------------------------------------------------- 1 | (define-constant machine-type (constant machine-type-tarm64nt)) 2 | (features iconv expeditor pthreads windows) 3 | (include "arm64.def") 4 | (include "nt.def") 5 | (include "default.def") 6 | -------------------------------------------------------------------------------- /s/ti3nt.def: -------------------------------------------------------------------------------- 1 | ;;; ti3nt.def 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (define-constant machine-type (constant machine-type-ti3nt)) 17 | (features iconv expeditor pthreads windows) 18 | (include "i3.def") 19 | (include "nt.def") 20 | (include "default.def") 21 | -------------------------------------------------------------------------------- /s/tpb.def: -------------------------------------------------------------------------------- 1 | (define-constant machine-type (constant machine-type-tpb)) 2 | (features pthreads) 3 | 4 | (include "pbcommon64.def") 5 | (include "pbcommon.def") 6 | (include "default.def") 7 | -------------------------------------------------------------------------------- /s/tpbarch.def: -------------------------------------------------------------------------------- 1 | ;; This template is turned into a machine-specific ".def" file 2 | ;; by the `workarea` script 3 | 4 | (define-constant machine-type (constant machine-type-$(M))) 5 | (features iconv expeditor pthreads pbchunk) 6 | 7 | (define-constant-default native-endianness '$(Mend)) 8 | 9 | (include "pbcommon$(Mword).def") 10 | (include "pbcommon.def") 11 | (include "default.def") 12 | -------------------------------------------------------------------------------- /s/tppc32osx.def: -------------------------------------------------------------------------------- 1 | ;;; tppc32le.def 2 | 3 | (define-constant machine-type (constant machine-type-tppc32osx)) 4 | (features iconv expeditor pthreads) 5 | (define-constant max-float-alignment 4) 6 | (define-constant max-integer-alignment 4) 7 | (define-constant special-initial-field-alignment? #t) 8 | (include "ppc32.def") 9 | (include "default.def") 10 | -------------------------------------------------------------------------------- /s/tunix.def: -------------------------------------------------------------------------------- 1 | ;; This template is turned into a machine-specific ".def" file 2 | ;; by the `machine.def` script 3 | 4 | (define-constant machine-type (constant machine-type-$(M))) 5 | (features iconv expeditor pthreads) 6 | (define-constant time-t-bits $(Mtimet)) 7 | (include "$(March).def") 8 | (include "default.def") 9 | -------------------------------------------------------------------------------- /s/ubify.ss: -------------------------------------------------------------------------------- 1 | ;;; ubify.ss 2 | ;;; Copyright 1984-2017 Cisco Systems, Inc. 3 | ;;; 4 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); 5 | ;;; you may not use this file except in compliance with the License. 6 | ;;; You may obtain a copy of the License at 7 | ;;; 8 | ;;; http://www.apache.org/licenses/LICENSE-2.0 9 | ;;; 10 | ;;; Unless required by applicable law or agreed to in writing, software 11 | ;;; distributed under the License is distributed on an "AS IS" BASIS, 12 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | ;;; See the License for the specific language governing permissions and 14 | ;;; limitations under the License. 15 | 16 | (for-each 17 | (let () 18 | (define-record-type ub 19 | (fields (immutable x)) 20 | (nongenerative) 21 | (sealed #t)) 22 | (record-writer (type-descriptor ub) 23 | (lambda (x p wr) 24 | (display "#" p))) 27 | (lambda (x) 28 | (unless ($top-level-bound? x) 29 | ($set-top-level-value! x (make-ub x))))) 30 | (oblist)) 31 | 32 | (set-who! compile (lambda args ($oops who "disabled when cross compiling"))) 33 | (set-who! $compile-backend 34 | (lambda (x) 35 | (lambda () 36 | (lambda (fp-entry) 37 | (lambda fp-args 38 | (pretty-print ($uncprep x)) 39 | ($oops who "attempt to call foreign-procedure created while cross compiling")))))) 40 | -------------------------------------------------------------------------------- /s/unix.def: -------------------------------------------------------------------------------- 1 | ;; This template is turned into a machine-specific ".def" file 2 | ;; by the `machine.def` script 3 | 4 | (define-constant machine-type (constant machine-type-$(M))) 5 | (features iconv expeditor) 6 | (define-constant time-t-bits $(Mtimet)) 7 | (include "$(March).def") 8 | (include "default.def") 9 | -------------------------------------------------------------------------------- /s/update-revision: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | if [ -d ../../.git ]; then 3 | git describe --always --match='' --abbrev=40 --dirty 4 | echo 'git' 5 | elif [ -d ../../.hg ]; then 6 | DIRTY="$(hg status -n --color never --pager never | head -1)" 7 | hg log --limit 1 --template '{node}' --pager never 8 | if [ -n "${DIRTY}" ]; then 9 | echo '-dirty' 10 | else 11 | echo '' 12 | fi 13 | echo 'hg' 14 | elif [ -f ../../.hg_archival.txt ]; then 15 | # hg archive and hgweb embed this file by default (see .hgrc archivemeta) 16 | sed -n 's/^node: \(.*\)/\1/p' < ../../.hg_archival.txt 17 | echo 'hg' 18 | else 19 | # use export-subst git attribute to populate revision for git archive 20 | echo '402563b7a3e020e6dd5acefe94e628ee3d29fc98' 21 | echo 'git' 22 | fi 23 | -------------------------------------------------------------------------------- /unicode/Makefile: -------------------------------------------------------------------------------- 1 | Scheme=../bin/scheme 2 | 3 | doit: unicode-char-cases.ss unicode-charinfo.ss 4 | 5 | unicode-char-cases.ss: extract-char-cases.ss extract-common.ss unicode-data.ss 6 | echo | $(Scheme) -q extract-char-cases.ss 7 | 8 | unicode-charinfo.ss: extract-info.ss extract-common.ss unicode-data.ss 9 | echo | $(Scheme) -q extract-info.ss 10 | 11 | unicode-char-cases.ss: \ 12 | UNIDATA/CompositionExclusions.txt\ 13 | UNIDATA/UnicodeData.txt\ 14 | UNIDATA/CaseFolding.txt\ 15 | UNIDATA/SpecialCasing.txt 16 | 17 | unicode-charinfo.ss: \ 18 | UNIDATA/UnicodeData.txt\ 19 | UNIDATA/WordBreakProperty.txt\ 20 | UNIDATA/PropList.txt 21 | 22 | -------------------------------------------------------------------------------- /unicode/ReadMe: -------------------------------------------------------------------------------- 1 | To rebuild unicode-char-cases.ss and unicode-charinfo.ss, download into 2 | ./UNIDATA the following files: 3 | 4 | http://www.unicode.org/Public/UCD/latest/ucd/CompositionExclusions.txt 5 | http://www.unicode.org/Public/UCD/latest/ucd/UnicodeData.txt 6 | http://www.unicode.org/Public/UCD/latest/ucd/CaseFolding.txt 7 | http://www.unicode.org/Public/UCD/latest/ucd/SpecialCasing.txt 8 | http://www.unicode.org/Public/UCD/latest/ucd/auxiliary/WordBreakProperty.txt 9 | http://www.unicode.org/Public/UCD/latest/ucd/PropList.txt 10 | http://www.unicode.org/Public/UCD/latest/ucd/NormalizationTest.txt 11 | http://www.unicode.org/Public/UCD/latest/ucd/auxiliary/GraphemeBreakProperty.txt 12 | http://www.unicode.org/Public/UCD/latest/ucd/emoji/emoji-data.txt 13 | 14 | Then run 'make'. 15 | -------------------------------------------------------------------------------- /unicode/unicode-data.ss: -------------------------------------------------------------------------------- 1 | ;;; Ikarus Scheme -- A compiler for R6RS Scheme. 2 | ;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum 3 | 4 | ;;; Permission is hereby granted, free of charge, to any person obtaining a 5 | ;;; copy of this software and associated documentation files (the "Software"), 6 | ;;; to deal in the Software without restriction, including without limitation 7 | ;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | ;;; and/or sell copies of the Software, and to permit persons to whom the 9 | ;;; Software is furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be included in 12 | ;;; all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 | ;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19 | ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 20 | ;;; DEALINGS IN THE SOFTWARE. 21 | 22 | (library (unicode-data) 23 | (export get-unicode-data) 24 | (import (rnrs)) 25 | 26 | (define (find-semi/hash str i n) 27 | (cond 28 | [(or (fx=? i n) (memv (string-ref str i) '(#\; #\#))) i] 29 | [else (find-semi/hash str (+ i 1) n)])) 30 | 31 | (define (cleanup str) 32 | (let ([lo 33 | (let f ([i 0] [n (string-length str)]) 34 | (cond 35 | [(= i n) n] 36 | [(char=? #\space (string-ref str i)) 37 | (f (+ i 1) n)] 38 | [else i]))] 39 | [hi 40 | (let f ([i (- (string-length str) 1)]) 41 | (cond 42 | [(< i 0) i] 43 | [(char=? #\space (string-ref str i)) 44 | (f (- i 1))] 45 | [else (+ i 1)]))]) 46 | (if (> hi lo) 47 | (substring str lo hi) 48 | ""))) 49 | 50 | (define (split str) 51 | (let f ([i 0] [n (string-length str)]) 52 | (cond 53 | [(or (= i n) (memv (string-ref str i) '(#\#))) 54 | '("")] 55 | [else 56 | (let ([j (find-semi/hash str i n)]) 57 | (cond 58 | [(or (= j n) (memv (string-ref str i) '(#\#))) 59 | (list (cleanup (substring str i j)))] 60 | [else 61 | (cons (cleanup (substring str i j)) 62 | (f (+ j 1) n))]))]))) 63 | 64 | (define (extract-uni-data) 65 | (let f ([ls '()]) 66 | (let ([line (get-line (current-input-port))]) 67 | (cond 68 | [(eof-object? line) 69 | (reverse ls)] 70 | [else 71 | (let ([fields (split line)]) 72 | (if (or (null? fields) (equal? fields '(""))) 73 | (f ls) 74 | (f (cons fields ls))))])))) 75 | 76 | (define (get-unicode-data filename) 77 | (with-input-from-file 78 | filename 79 | extract-uni-data))) 80 | -------------------------------------------------------------------------------- /wininstall/.gitignore: -------------------------------------------------------------------------------- 1 | *.exe 2 | *.msi 3 | *.wixobj 4 | *.wixpdb 5 | /vcredist.wxs 6 | -------------------------------------------------------------------------------- /wininstall/Makefile: -------------------------------------------------------------------------------- 1 | VERSION := 9.9.9 2 | WIXEXTENSIONS := -ext WixUIExtension -ext WixBalExtension 3 | export MSYS_NO_PATHCONV=1 4 | 5 | ChezScheme.exe: x86/bundle.wixobj ChezScheme32.msi ChezScheme64.msi 6 | cmd.exe /c "light.bat -nologo $(WIXEXTENSIONS) $< -out $@" 7 | 8 | ChezScheme32.msi: x86/product.wixobj x86/examples.wixobj x86/i3nt.wixobj x86/ti3nt.wixobj x86/vcredist.wixobj x86/ui.wixobj 9 | cmd.exe /c "light.bat -nologo $(WIXEXTENSIONS) $^ -sice:ICE64 -sice:ICE03 -sice:ICE82 -sice:ICE61 -out $@" 10 | 11 | ChezScheme64.msi: x64/product.wixobj x64/a6nt.wixobj x64/examples.wixobj x64/ta6nt.wixobj x64/vcredist.wixobj x64/ui.wixobj 12 | cmd.exe /c "light.bat -nologo $(WIXEXTENSIONS) $^ -sice:ICE64 -sice:ICE03 -sice:ICE82 -sice:ICE61 -out $@" 13 | 14 | x86/%.wixobj: %.wxs 15 | cmd.exe /c "candle.bat -nologo -dVersion=$(VERSION) $(WIXEXTENSIONS) $< -out $@" 16 | 17 | x64/%.wixobj: %.wxs 18 | cmd.exe /c "candle.bat -arch x64 -nologo -dVersion=$(VERSION) $(WIXEXTENSIONS) $< -out $@" 19 | 20 | vcredist.wxs: locate-vcredist.bat 21 | cmd.exe /c "locate-vcredist.bat" 22 | 23 | # After building a6nt, use it to create boot files for the 24 | # other machine types, since that's faster than going through 25 | # pb every time 26 | .PHONY: workareas 27 | workareas: 28 | cd ..; cmd.exe /c "build.bat a6nt" 29 | cd ..; ./zuo.exe . bootquick i3nt 30 | cd ..; ./zuo.exe . bootquick ta6nt 31 | cd ..; ./zuo.exe . bootquick ti3nt 32 | cd ..; cmd.exe /c "build.bat i3nt" 33 | cd ..; cmd.exe /c "build.bat ta6nt" 34 | cd ..; cmd.exe /c "build.bat ti3nt" 35 | 36 | .PHONY: clean 37 | clean: 38 | -rm -rf *.msi *.wixpdb x86/ x64/ vcredist.wxs *.wixobj *.exe 39 | -------------------------------------------------------------------------------- /wininstall/bundle.wxs: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 9 | 13 | 14 | 15 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /wininstall/candle.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | if exist "%WIX%bin\candle.exe" goto found 3 | 4 | echo WiX must be installed. 5 | exit 1 6 | 7 | :found 8 | "%WIX%bin\candle.exe" %* 9 | -------------------------------------------------------------------------------- /wininstall/cs.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/ChezScheme/402563b7a3e020e6dd5acefe94e628ee3d29fc98/wininstall/cs.png -------------------------------------------------------------------------------- /wininstall/light.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | if exist "%WIX%bin\light.exe" goto found 3 | 4 | echo WiX must be installed. 5 | exit 1 6 | 7 | :found 8 | "%WIX%bin\light.exe" %* 9 | -------------------------------------------------------------------------------- /wininstall/locate-vcredist.bat: -------------------------------------------------------------------------------- 1 | @call "../c/vs.bat" x86 2 | 3 | @IF "%VisualStudioVersion%"=="" ( GOTO error-undefined-vs ) 4 | 5 | @IF "%VisualStudioVersion%"=="14.0" ( 6 | SET "Path32=%CommonProgramFiles(x86)%\Merge Modules\Microsoft_VC140_CRT_x86.msm" 7 | SET "Path64=%CommonProgramFiles(x86)%\Merge Modules\Microsoft_VC140_CRT_x64.msm" 8 | ) 9 | 10 | @IF "%VisualStudioVersion%"=="15.0" or "%VisualStudioVersion%"=="16.0" or "%VisualStudioVersion%"=="17.0" ( 11 | @PUSHD "%VCINSTALLDIR%Redist\MSVC" 12 | @FOR /D %%D IN (*) DO ( 13 | @PUSHD %%D 14 | @FOR %%F IN (MergeModules\Microsoft_VC*_CRT_x86.msm) DO ( 15 | SET "Path32=%VCINSTALLDIR%Redist\MSVC\%%D\%%F" 16 | ) 17 | @FOR %%F IN (MergeModules\Microsoft_VC*_CRT_x64.msm) DO ( 18 | SET "Path64=%VCINSTALLDIR%Redist\MSVC\%%D\%%F" 19 | ) 20 | @POPD 21 | ) 22 | @POPD 23 | ) 24 | 25 | @DEL vcredist.wxs >nul 2>&1 26 | 27 | IF "%Path32%"=="" ( GOTO error-unknown-vs ) 28 | IF NOT EXIST "%Path32%" ( GOTO error-32-doesnt-exist ) 29 | IF NOT EXIST "%Path64%" ( GOTO error-64-doesnt-exist ) 30 | 31 | @( 32 | @ECHO ^ 33 | @ECHO ^ 34 | @ECHO ^ 35 | @ECHO ^ 36 | @ECHO ^ 37 | @ECHO ^ 38 | @ECHO ^ 39 | @ECHO ^ 40 | @ECHO ^ 41 | @ECHO ^ 42 | @ECHO ^ 43 | @ECHO ^ 44 | @ECHO ^ 45 | @ECHO ^ 46 | @ECHO ^ 47 | @ECHO ^ 48 | @ECHO ^ 49 | @ECHO ^ 50 | @ECHO ^ 51 | @ECHO ^ 52 | @ECHO ^ 53 | @ECHO ^ 54 | @ECHO ^ 55 | ) > vcredist.wxs 56 | 57 | @ECHO Built vcredist.wxs 58 | @EXIT /b 0 59 | 60 | :error-undefined-vs 61 | @ECHO Error building vcredist.wxs: Visual Studio version not defined. 62 | @EXIT /b 1 63 | 64 | :error-unknown-vs 65 | @ECHO Error building vcredist.wxs: Unexpected Visual Studio version. 66 | @EXIT /b 1 67 | 68 | :error-32-doesnt-exist 69 | @ECHO Error building vcredist.wxs: Merge Module couldn't be found: 70 | @ECHO %Path32% 71 | @EXIT /b 1 72 | 73 | :error-64-doesnt-exist 74 | @ECHO Error building vcredist.wxs: Merge Module couldn't be found: 75 | @ECHO %Path64% 76 | @EXIT /b 1 77 | -------------------------------------------------------------------------------- /wininstall/product.wxs: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 25 | 34 | 35 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | --------------------------------------------------------------------------------