commit 371df69f80b9c1f28ccee1b134a6b3957c8870eb Spenser Truex <truex@equwal.com> 2026-10-04 08:47:28 +0000 Initial import
.github/workflows/ci.yml | 21 + LICENSE | 21 + NOTES.md | 209 ++++ README.md | 81 ++ conformance.txt | 1 + demo.lisp | 3 + docs/build-docs.py | 331 ++++++ docs/forthlisp-cheatsheet.txt | 55 + host.lisp | 299 +++++ lisp.fs | 500 ++++++++ prelude.scm | 105 ++ prims.lisp | 50 + r7rs-tests.scm | 326 ++++++ suite.lisp | 237 ++++ tests/r7rs/LICENSE | 29 + tests/r7rs/r7rs-tests.scm | 2523 +++++++++++++++++++++++++++++++++++++++++ tests/r7rs/results.txt | 306 +++++ tests/r7rs/shim.scm | 8 + tests/r7rs/skip.scm | 51 + 19 files changed, 5156 insertions(+)
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..54a1d42 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,21 @@ +name: ci +on: [push, pull_request] +jobs: + host: + # The host side alone: the host dialect compiles prims.lisp and demo.lisp to Forth. + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - run: sudo apt-get update && sudo apt-get install -y sbcl + - run: sbcl --script host.lisp compile prims.lisp + - run: sbcl --script host.lisp compile demo.lisp + stm32: + # The whole stack on the STM32F446 target in QEMU, with this core checked out beside it. + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + with: { path: forthlisp } + - uses: actions/checkout@v4 + with: { repository: equwal/forthlisp-stm32, path: forthlisp-stm32 } + - run: sudo apt-get update && sudo apt-get install -y sbcl qemu-system-arm binutils-arm-none-eabi + - run: cd forthlisp-stm32 && sh test.sh diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..da3111d --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Spenser Truex + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/NOTES.md b/NOTES.md new file mode 100644 index 0000000..ae64687 --- /dev/null +++ b/NOTES.md @@ -0,0 +1,209 @@ +# Assembly -> SBCL breadboard -> Forth -> Lisp on the STM32F446 + +One emulated STM32F446 (Cortex-M4F, 128 KiB RAM, 512 KiB flash). Every layer is built here, +from Thumb-2 machine code up; no third-party Forth (Mecrisp-Stellaris, used before +2026-10-04, is gone, and with it the GPLv3 question). All published numbers are measured +on this stack: `asm-tests.txt`, `kernel-tests.txt`, `conformance.txt`. + +``` + 4 LISP R7RS-small subset Scheme, written in Forth words (lisp.fs), loaded through + the Forth console; prims.lisp + prelude.scm on top. tests: r7rs-tests.scm + ------------------------------------------------------------------------ + 3 FORTH our own indirect-threaded Forth kernel on the chip: primitives in Thumb-2, + outer interpreter in Forth (kernel.fs), dictionary, serial console. + tests: forth-tests.txt + ------------------------------------------------------------------------ + 2 SBCL breadboard on the host: a Thumb-2 assembler on SBCL's sb-assem segments, + VOP-style primitive templates, a metacompiler for kernel.fs, image writer. + tests: asm-tests (vs GNU as) + ------------------------------------------------------------------------ + 1 ASM Thumb-2 / ARMv7-M instructions (and FPv4-SP for floats) tests: byte-exact encodings +``` + +Each layer has its own tests, run in this order: assembler encodings (byte-identical to +`arm-none-eabi-as`), kernel words over the serial console, then the Scheme conformance suite. + +## Plan + +### Layer 2: the SBCL breadboard + +Paul Khuong, "SBCL: the ultimate assembly code breadboard" +(https://pvk.ca/Blog/2014/03/15/sbcl-the-ultimate-assembly-code-breadboard/), writes machine +code from the SBCL REPL with SBCL's own assembler (`sb-assem` segments, `inst`, `define-vop`) +and inspects it with `sb-disassem`. SBCL's backend targets the host (x86-64), so +its instruction definitions and `define-vop` cannot emit Thumb-2, and a VOP cannot run on the +host. The decision: + +- **Reuse `sb-assem` for what is ISA-neutral**: segments (`make-segment`, `emit-byte`), + labels (`gen-label`, `emit-label`, `label-position`), and back-patches (`emit-back-patch`) + for forward references, branch offsets and absolute cells. Checked on SBCL 2.6.9. +- **Write the Thumb-2 encoders as plain Lisp functions** over those segments, one per + instruction form, and test each form against `arm-none-eabi-as` byte for byte. +- **VOP-style templates for primitives**: `defcode` takes a Forth name and a body of + instructions, lays down the dictionary header, and appends `NEXT`, the way a VOP pairs + a name with a code template. +- The host also metacompiles the high-level kernel (`kernel.fs`) into threaded code, links + every reference with labels, and writes the flash image. + +### Layer 3: the kernel + +- **Threading: indirect-threaded code (ITC).** A colon definition is a list of execution + tokens (cell addresses), so the on-chip compiler only appends cells and never encodes + instructions. The cost is one extra load per word, which is acceptable for an interpreter host. +- **Registers:** r4 = IP, r5 = data stack pointer (full descending; holds the second item), + r6 = TOS, r7 = W (current xt), sp = return stack, r0-r3 and r12 scratch. +- **NEXT:** `ldr r7,[r4],#4 ; ldr r0,[r7] ; bx r0`. +- **Header:** link (4 bytes), flags (bit 7 immediate, bit 6 hidden), name length, name, + pad to 4, then the code field (CFA), then the body. An xt is a CFA address. +- **Memory map:** + - Flash `0x08000000`: vector table, primitives, kernel headers and threads (read-only). + - RAM `0x20000000`: system variables and the 512-byte input buffer, then the user dictionary. + - Data stack: 4 KiB below `0x2001EFE0`. + - Return stack: 4 KiB below `0x2001FFE0`. QEMU's netduinoplus2 breaks on writes to the last + 32 bytes of RAM, so the stacks stop short of them. +- **Console:** USART2, polled, 115200 baud from the 16 MHz HSI. It is QEMU's second + `-serial`. `accept` treats Backspace and Delete alike. +- **Compatibility:** the console protocol (` ok.`, `not found.`) and the word set that + `lisp.fs` uses (`variable` with an initial value, `buffer:`, `token`, `h@`, `cbis!`, ...) + follow Mecrisp, so layer 4 loads unchanged. +- **Flash writing:** the image is written by the host. A runtime `flash!` follows RM0390 + (unlock keys, PG, PSIZE). QEMU does not model the F4 flash controller, so `flash!` is + untested in emulation. + +## Influences: remote patching of running systems + +- **gll-mag-patch** (Ron Garret, JPL 1993; https://github.com/rongarret/gll-mag-patch). + Galileo's magnetometer ran Forth on an RCA 1802. A RAM byte had failed, and the original + development system no longer worked (README). Garret rebuilt the toolchain in Macintosh + Common Lisp: + - `forthcomp.lisp` rebuilds the flight dictionary from the ROM and RAM images and their + word index (`build-gll-dictionary`). + - `compiler-test` recompiles every recovered RAM word from `ram source.lisp` and diffs it + byte for byte against the flight RAM image. This proves the new compiler reproduces the + old one. + - `compile-patch` compiles a replacement word at the **old word's address**. It warns when + the patch overflows the old slot and prints only the bytes that differ. `Patches/delivered` + holds those address-plus-hex deltas, which are what was uplinked. + - `Patches/development` frees space by merging the slots of retired words (DSP12 and DSP3) + into one larger slot for the new word. + - `sim1802` simulates the 1802; `asm1802` is its assembler; `lisp->forth` and macros such + as `main-event-loop` generate Forth from Lisp. + - `Patches/test results` records the instrument team's independent review. They confirmed + the compiled bytes matched the source, then ran the logic on their own test setup and + found it still wrong (extra vectors at rim 0 and 90). Review caught the bug before uplink. + - The flight `MAIN` computes ROM and RAM checksums (`ram source.lisp`). +- **"Lisping at JPL"** (Ron Garret; https://flownet.com/gat/jpl-lisp.html). + - The magnetometer team had judged the patch too costly to attempt. A Lisp-built Forth + environment with a hardware simulator delivered it in under three months of part-time work. + - On Deep Space 1, a Lisp REPL running on the spacecraft let the team find and fix a race + condition that ground testing had missed, about 100 million miles away. + - Earlier robots used Lisp-hosted compilers for small targets, for example a 68HC11 + with 256 bytes of RAM. + +What this design takes from them: +- The host holds the full development system: assembler, metacompiler, simulator-like tests. +- The target keeps a live interpreter, so code can be redefined over the serial link. +- The compiler is proven by reproducing known-good bytes, as `compiler-test` did. +- Patches are small, addressed, size-checked deltas. Each one is reviewed and tested off the + target before it is sent. + +## Status + +| Layer | Test | Result | +|---|---|---| +| 1-2 assembler | `asm-test.lisp`: every encoder form vs `arm-none-eabi-as` (incl. FPv4-SP), plus repeated label references | 105/105 | +| 3 kernel | `forth-tests.txt` via `host.lisp ktest`, fresh boot | 71/71 | +| 4 Scheme | chibi-scheme's R7RS suite, `tests/r7rs/`, via `host.lisp suite` | see `tests/r7rs/results.txt` | +| 4 Scheme | our own regression suite `r7rs-tests.scm` via `host.lisp test` | 297/297 | + +- Kernel image: about 10.4 KiB of flash, 197 words (FPU words `f+ f- f* f/ s>f f>s fsqrt f< f=`). +- RAM after `lisp.fs`, `prims.lisp` and `prelude.scm` load: + - cons heap 48 KiB (6143 cells); + - blob heap 16 KiB; + - symbol names 4 KiB; + - 23.5 KiB free (`unused` = 24112). +- The kernel prints `Redefine NAME.` when a definition shadows an existing word, and `host.lisp` + stops the load on it. A list-length word named `llen` once silently captured the reader's + `llen` variable in every later word. +- `lisp.fs` loaded unchanged: the kernel follows Mecrisp's console protocol and word set. +- Gotcha: sb-assem's `emit-back-patch` (SBCL 2.6.9) resolved only the first of several adjacent + references to one label, which left zero cells in the vector table and `li` loads. + `asm.lisp` now keeps its own fixup list; `asm-test.lisp` has a regression case for it. +- A Z80 machine built the same way (own Z80 kernel, SBCL Z80 assembler, z80pack cpmsim) + lives in `z80/`; see `z80/NOTES.md`. +## Conformance + +**Target: the full R7RS-small suite of chibi-scheme** (Alex Shinn; `tests/r7rs-tests.scm`, +1132 test calls; BSD licence, kept in `tests/r7rs/LICENSE`), vendored unmodified in `tests/r7rs/`. +- `host.lisp suite` splits the file into top-level forms and sends each one to the chip as one + line (the longest is 454 bytes; the line buffer is 512). +- `shim.scm` defines `test`, `test-assert`, `test-begin` and `test-end` as chip procedures that + print a pass or fail marker. +- `skip.scm` lists what cannot run yet, by section, test head, text or number-literal kind, + each with a reason. A test that uses a name whose definition was skipped is skipped with + that reason too. `results.txt` counts the skips per reason; no test is deleted. +- A form that errors counts all of its unreported tests as failed. If the chip stops + answering, every later test counts as failed. +- First run on the own stack: 244 passed, 78 failed, 810 skipped, 1132 total. After item 1 (numbers): 302 passed, 119 failed, 711 skipped. After item 2 (characters, + strings, vectors, bytevectors): 486 passed, 123 failed, 523 skipped. It found two + bugs, now fixed and covered by local regression tests: `list?` looped on a circular list, + and `case` lacked `=>`. + +Our own suite below stays local: a reported sieve program, string cases and those regressions. + +`r7rs-tests.scm` holds 205 cases, most of them the examples of R7RS-small sections 4.1, 4.2, 5.3, 6.1-6.5, 6.7, 6.8 and 6.10, a 20000-iteration tail-call loop, and a regression case: a multi-line Sieve of Eratosthenes with a docstring, vectors, `do`, `when` and named let. `host.lisp test` sends each to the emulated chip and compares the printed result. Last run: see `conformance.txt` (205 passed, 0 failed). + +### Supported + +- Special forms: `quote` `'x` `if` `define` (variables, procedures, internal defines) `set!` `lambda` (fixed, dotted and rest parameters) `begin` `let` (and named let) `let*` `letrec` `letrec*` `cond` (with `else` and `=>`) `case` `and` `or` `when` `unless` `do`. +- Data: exact integers, strings (escapes `\"` `\\` `\n` `\t`; may span lines), vectors (`#(...)`), symbols, pairs and lists, `#t` `#f` (also `#true` `#false`), `'()` distinct from `#f`, procedures. +- Procedures: `+ - * quotient remainder modulo = < > <= >= eq? eqv? equal? car cdr cons set-car! set-cdr! null? pair? list? symbol? number? integer? exact? exact-integer? inexact? boolean? procedure? apply display write newline string? vector? list->string list->vector make-vector vector-ref vector-set!` and, from `prelude.scm`, `not caar cadr cdar cddr caddr list length reverse append list-tail list-ref list-copy make-list map for-each memq memv member assq assv assoc zero? positive? negative? odd? even? abs max min gcd lcm square boolean=? symbol=? string->list string-length string=? string-append vector vector->list vector-length floor ceiling round truncate exact inexact sqrt exact-integer-sqrt`. +- Proper tail calls in `if`, `cond`, `case`, `and`, `or`, `when`, `unless`, `let` forms, `begin`, `do` and procedure bodies. + +### Deviations from R7RS-small + +- Numbers: exact integers are 31-bit fixnums; a result outside -2^30..2^30-1 raises `overflow` + (no bignums; 64-bit products are checked with `m*`). Exact rationals are normalized fixnum + pairs. Inexact reals are IEEE **single** precision on the M4F FPU (R7RS expects double): + about 7 significant digits. Printing uses 7 digits and the last one can be off by one, so + output need not read back to the same float. No complex numbers, no `exp`/`log`/trig yet. +- Characters are bytes (Latin-1): no Unicode, since the serial console and the string storage + are 8-bit. Strings, vectors and bytevectors live in a 16 KiB blob heap, with O(1) access. + The GC compacts live blobs. Missing from the string library: `string-fill!`, `string-copy!`, + case conversion of whole strings, and `-ci` string comparisons. +- `sqrt` returns the exact integer floor of the root (`(sqrt 500)` is 22, not 22.36); `floor`, `round` and friends are the identity on integers. +- No `define-syntax`/`syntax-rules`, `quasiquote`, `delay`/`force`, `call/cc`, `dynamic-wind`, `values`, exceptions, `guard`, parameters, records, libraries (`import`), ports beyond the console. +- Errors print a message and return to the prompt; they are not raisable objects. +- Primitives check argument types but not arity; extra arguments are ignored. +- Recursion depth is bounded by the 4 KiB stacks: non-tail recursion raises `too deep` between 150 and 200 levels (measured with `(d 150)` and `(d 200)`). +- `define` returns the defined symbol (R7RS leaves the value unspecified). + +## Implementation + +- Values are 32-bit. Low bits: `xx1` fixnum, `000` pair (0 is `'()`), `010` symbol, `100` immediate (`#f` `#t`, unspecified, unbound, special-form markers), `110` procedure. Cells are 8 bytes (car, cdr) in a 64 KiB heap (8191 cells). +- A symbol's cdr is its global value. A special form name is bound to a marker value, so a local variable of the same name shadows it. +- An environment is an alist in front of the globals. Each procedure call and `let` adds a dummy binding first, so an internal `define` can splice its binding in after the head without touching the enclosing scope. +- `eval` is a loop: special-form handlers return either a value or a new (expression, environment) pair, which is how tail calls run in constant stack. +- GC: mark-sweep, run when `cons` finds the free list empty. Roots are the symbol list and every word on the data and return stacks that looks like a heap reference (conservative scan), so a GC inside a running expression is safe. +- Reader: lines come from Mecrisp's `accept`, which handles Backspace (0x08) and Delete (0x7f) and echoes the erase; the reader then parses from that line buffer (512 bytes). An expression may span lines. + +## Serial driving + +The host sends one character at a time and waits for the echo, then waits for ` ok.` (Forth) or `> ` (Scheme). The emulated USART has a one-byte receive register. + +## Files + +- `host.lisp` -- compiler and serial driver: `compile FILE | load | demo | test [FILE] | eval EXPR... | forth LINE...`. +- `lisp.fs` -- the chip Scheme: values, GC, symbols, reader, printer, eval, special forms, Forth-side primitives, REPL. +- `prims.lisp` -- arithmetic, comparison and type primitives in the host dialect. +- `prelude.scm` -- library procedures in Scheme, one form per line. +- `r7rs-tests.scm`, `conformance.txt` -- the conformance subset and its last result. +- `demo.lisp`, `demo.sh`, `transcript.txt` -- scripted proof of all three layers. +- `build-firmware.sh` -- the F446 Mecrisp build. The image is not committed; the launchers build it when missing. +- `stm32-lisp`, `stm32-forth` -- launchers (QEMU netduinoplus2). + +## Sources used + +- Ron Garret, gll-mag-patch (`forthcomp.lisp`, README) and "Lisp at JPL" (flownet.com/gat/jpl-lisp.html). +- R7RS-small report (r7rs.org) for the forms, procedures and test examples. +- Mecrisp-Stellaris 2.6.5 source (`common/forth-core.s` stack sizes, `common/query.s` accept, `stm32f407/` port). diff --git a/README.md b/README.md new file mode 100644 index 0000000..d292e9f --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +# forthlisp + +A Scheme that runs on a small chip, on top of a Forth kernel built for that chip, on top of +machine code assembled by Lisp on the host. Every layer is built from scratch. This repo +holds the parts that both targets share: the host-side Lisp, the Scheme (written in Forth +words), the R7RS test harness and the reference-page generator. + +``` + 4 LISP R7RS-small subset Scheme, written in Forth words (lisp.fs), loaded through + the chip's Forth console; prims.lisp + prelude.scm on top + 3 FORTH the target's own Forth kernel (in the target repo) + 2 SBCL breadboard on the host: assembler, primitive templates, metacompiler, + serial driver, test harness (host.lisp, suite.lisp here; assemblers in the targets) + 1 ASM the target's instructions: Thumb-2 (STM32F446) or Z80 +``` + +Targets: + +- [forthlisp-stm32](https://github.com/equwal/forthlisp-stm32): STM32F446 (Cortex-M4F) in QEMU `netduinoplus2` +- [forthlisp-z80](https://github.com/equwal/forthlisp-z80): Z80 in z80pack `cpmsim` + +Reference page with cheat sheets and the full spec: https://dickt.store/forthlisp/ + +## Quickstart + +Check out this repo next to a target repo; the targets find it at `../forthlisp` (or set +`FORTHLISP_CORE`): + +```sh +git clone https://github.com/equwal/forthlisp +git clone https://github.com/equwal/forthlisp-stm32 +cd forthlisp-stm32 && ./build-firmware.sh && ./stm32-lisp +``` + +Needs SBCL, `qemu-system-arm`, `arm-none-eabi-as`/`objcopy` (for the assembler tests), and +`nc`. At the `>` prompt, type Scheme. `(forth)` returns to the Forth prompt. + +## Files + +- `host.lisp`: host compiler for a small Lisp dialect into Forth words, the serial + driver, and the commands `load`, `demo`, `ktest`, `test`, `suite`, `eval`, `forth` +- `lisp.fs`: the Scheme in Forth: tagged values, mark-sweep GC with a conservative stack + scan, a compacting blob heap for strings, vectors and bytevectors, a tail-calling eval, + the reader and the printer +- `prims.lisp`: arithmetic and type primitives, written in the host dialect +- `prelude.scm`: library procedures written in the chip Scheme +- `r7rs-tests.scm`: our own regression suite (`EXPR ==> printed result`) +- `tests/r7rs/`: chibi-scheme's R7RS-small suite, vendored unmodified (BSD, see its + `LICENSE`), with `shim.scm`, the machine-readable `skip.scm` and `results.txt` +- `suite.lisp`: runs that suite over the serial link +- `docs/build-docs.py`: generates the reference page from the sources + +## Test counts (STM32F446 target, QEMU) + +- Our regression suite: see `conformance.txt` (297/297 at publication) +- chibi-scheme R7RS suite: see `tests/r7rs/results.txt` (486 passed, 123 failed, 523 skipped + of 1132 at publication; every skip names its reason) + +## Limits + +- Fixnums are 31-bit; overflow is an error, and there are no bignums. +- Inexact reals are IEEE single precision (the M4F FPU); R7RS expects double. +- Characters are bytes; there is no Unicode. +- No `define-syntax`, `call/cc`, `dynamic-wind`, exceptions, parameters, records, + libraries or ports yet. `NOTES.md` lists every deviation. + +## Influences + +- Paul Khuong, "SBCL: the ultimate assembly code breadboard" + (https://pvk.ca/Blog/2014/03/15/sbcl-the-ultimate-assembly-code-breadboard/): machine code + written and tested from the SBCL REPL. The assemblers here reuse SBCL's `sb-assem` segments + and labels. +- Ron Garret, gll-mag-patch (https://github.com/rongarret/gll-mag-patch): a Lisp-hosted Forth + toolchain that rebuilt and patched the Galileo magnetometer's flight code. +- Ron Garret, "Lisping at JPL" (https://flownet.com/gat/jpl-lisp.html): the live REPL on + Deep Space 1, and why a patchable live image matters. + +## Licence + +MIT (see `LICENSE`). `tests/r7rs/r7rs-tests.scm` is chibi-scheme's, under its BSD licence +(`tests/r7rs/LICENSE`). diff --git a/conformance.txt b/conformance.txt new file mode 100644 index 0000000..ba5c1c7 --- /dev/null +++ b/conformance.txt @@ -0,0 +1 @@ +conformance: 297 passed, 0 failed, 297 total diff --git a/demo.lisp b/demo.lisp new file mode 100644 index 0000000..3f0b57a --- /dev/null +++ b/demo.lisp @@ -0,0 +1,3 @@ +;;; demo.lisp -- layer 1 input: host-dialect Lisp that host.lisp compiles to Forth words. +(defun sq (x) (* x x)) +(defun fact (n) (if (< n 2) 1 (* n (fact (- n 1))))) diff --git a/docs/build-docs.py b/docs/build-docs.py new file mode 100755 index 0000000..d7b98b3 --- /dev/null +++ b/docs/build-docs.py @@ -0,0 +1,331 @@ +#!/usr/bin/env python3 +"""Build docs/index.html: cheat sheets on top, the implementation spec below. + +Hand-written parts: docs/forth-cheatsheet.txt, docs/forthlisp-cheatsheet.txt. +Everything else comes from the sources, so the page follows the code: +NOTES.md (spec prose), prims.lisp (primitive table), lisp.fs (special forms, +word list with stack comments), host.lisp (commands, demo checks), +build-firmware.sh / demo.sh / stm32-lisp (build and run), transcript.txt. +A source file that is missing or renamed is skipped, not fatal. +""" +import html, os, re, subprocess, sys + +ROOT = os.path.dirname(os.path.dirname(os.path.abspath(__file__))) +esc = html.escape + + +def read(name): + p = name if os.path.isabs(name) else os.path.join(ROOT, name) + try: + with open(p, encoding="utf-8", errors="replace") as f: + return f.read() + except OSError: + return None + + +def slug(s): + return re.sub(r"[^a-z0-9]+", "-", s.lower()).strip("-") + + +def inline(s): + out = [] + for i, part in enumerate(re.split(r"(`[^`]*`)", s)): + if i % 2: + out.append("<code>%s</code>" % esc(part[1:-1])) + else: + t = esc(part) + t = re.sub(r"\*\*(.+?)\*\*", r"<b>\1</b>", t) + t = re.sub(r"\[([^\]]+)\]\(([^)]+)\)", r'<a href="\2">\1</a>', t) + out.append(t) + return "".join(out) + + +def md(text, toc, prefix, base=2): + """Small Markdown subset: headings, paragraphs, lists, tables, code.""" + out, lines, i = [], text.splitlines(), 0 + while i < len(lines): + l = lines[i] + m = re.match(r"(#+)\s+(.*)", l) + if m: + lvl = min(len(m.group(1)) - 1 + base, 6) + if lvl < base: + i += 1 + continue + a = prefix + slug(m.group(2)) + if lvl <= base + 1: + toc.append((lvl, a, m.group(2))) + out.append('<h%d id="%s">%s</h%d>' % (lvl, a, inline(m.group(2)), lvl)) + i += 1 + elif l.startswith("```"): + j = i + 1 + while j < len(lines) and not lines[j].startswith("```"): + j += 1 + out.append("<pre>%s</pre>" % esc("\n".join(lines[i + 1:j]))) + i = j + 1 + elif l.startswith(" "): + j = i + while j < len(lines) and (lines[j].startswith(" ") or not lines[j].strip()): + j += 1 + out.append("<pre>%s</pre>" % esc("\n".join(x[4:] for x in lines[i:j]).rstrip())) + i = j + elif l.startswith("|"): + rows = [] + while i < len(lines) and lines[i].startswith("|"): + cells = [c.strip() for c in lines[i].strip().strip("|").split("|")] + if not all(re.fullmatch(r":?-+:?", c) for c in cells): + rows.append(cells) + i += 1 + h = "".join("<th>%s</th>" % inline(c) for c in rows[0]) + b = "".join("<tr>%s</tr>" % "".join("<td>%s</td>" % inline(c) for c in r) for r in rows[1:]) + out.append('<div class="tw"><table><tr>%s</tr>%s</table></div>' % (h, b)) + elif re.match(r"- ", l): + items = [] + while i < len(lines) and (lines[i].startswith("- ") or lines[i].startswith(" ")): + if lines[i].startswith("- "): + items.append(lines[i][2:]) + else: + items[-1] += " " + lines[i].strip() + i += 1 + out.append("<ul>%s</ul>" % "".join("<li>%s</li>" % inline(x) for x in items)) + elif not l.strip(): + i += 1 + else: + j = i + while j < len(lines) and lines[j].strip() and not re.match(r"(#|\||- |```| )", lines[j]): + j += 1 + out.append("<p>%s</p>" % inline(" ".join(lines[i:j]))) + i = j + return "\n".join(out) + + +def table(head, rows): + h = "".join("<th>%s</th>" % esc(x) for x in head) + b = "".join("<tr>%s</tr>" % "".join("<td>%s</td>" % c for c in r) for r in rows) + return '<div class="tw"><table><tr>%s</tr>%s</table></div>' % (h, b) + + +def code(s): + return "<code>%s</code>" % esc(s) + + +def prims_section(): + src = read("prims.lisp") + if not src: + return "" + defs = {m.group(1): (m.group(2), m.group(3)) for m in re.finditer( + r"^\(defun\s+(\S+)\s+\(([^)]*)\)\s+(.*)\)\s*$", src, re.M)} + reg = re.search(r"\(defprims(.*?)\)\s*$", src, re.S) + pairs = re.findall(r"\((\S+)\s+(\S+)\)", reg.group(1)) if reg else [] + rows = [] + for name, word in pairs: + params, body = defs.get(word, ("", "")) + nargs = len(set(re.findall(r"\(car(?: \(cdr)* a", body))) + rows.append([code(name), str(nargs), code(word), code(body)]) + fs = read("lisp.fs") or "" + for m in re.finditer(r"' (\S+) defprim (\S+)", fs): + rows.append([code(m.group(2)), "0", code(m.group(1)), + "defined in Forth in lisp.fs"]) + return ("<p>Generated from <code>prims.lisp</code> (the <code>defprims</code> table and " + "each <code>defun</code> body) and the <code>defprim</code> lines of " + "<code>lisp.fs</code>. Arity = distinct list positions the body reads. " + "Primitives check argument types but not arity.</p>" + table(["Lisp name", "Arity", "Forth word", "Semantics (host-dialect body)"], rows)) + + +def forms_section(): + fs = read("lisp.fs") + if not fs: + return "" + rows = [[code(n), code(w)] for w, n in re.findall(r"' (\S+) defform (\S+)", fs)] + return ("<p>Extracted from the <code>defform</code> lines of <code>lisp.fs</code>. A special " + "form name is bound to a marker value, so a local variable of the same name shadows it.</p>" + + table(["Special form", "Forth handler"], rows)) + + +def prelude_section(): + s = read("prelude.scm") + if not s: + return "" + names = re.findall(r"^\(define \((\S+)", s, re.M) + return ("<p>Procedures written in the chip Scheme itself (<code>prelude.scm</code>), loaded " + "through the REPL at boot:</p><p>%s</p>" % " ".join(code(n) for n in names)) + + +def conformance_section(): + t = read("r7rs-tests.scm") + if not t: + return "" + rows = [] + for l in t.splitlines(): + if not l.strip() or l.startswith(";"): + continue + e, _, w = l.partition("==>") + rows.append([code(e.strip()), code(w.strip())]) + res = read("conformance.txt") or "" + m = re.search(r"conformance: .*", res) + head = ("<p><b>Last run on the emulated chip: %s</b> (<code>conformance.txt</code>).</p>" + % esc(m.group(0))) if m else "" + return head + "<details><summary>All %d cases (<code>r7rs-tests.scm</code>)</summary>%s</details>" % ( + len(rows), table(["Expression", "Expected print"], rows)) + + +def words_section(): + fs = read("lisp.fs") + if not fs: + return "" + rows, group = [], "" + for l in fs.splitlines(): + g = re.match(r"\\ --- (.*) ---", l) + if g: + group = g.group(1) + m = re.match(r": (\S+)\s*(\([^)]*\))?\s*(.*)", l) + if m: + note = re.search(r"\\\s*(.*)$", l) + rows.append([esc(group), code(m.group(1)), code(m.group(2) or ""), + esc(note.group(1) if note else "")]) + return ("<p>Every colon definition in <code>lisp.fs</code>, in load order, with its stack " + "comment.</p>" + table(["Section", "Word", "Stack effect", "Comment"], rows)) + + +def header_comment(name, mark): + s = read(name) + if not s: + return "" + lines = [] + for l in s.splitlines(): + if l.startswith("#!"): + continue + if l.startswith(mark): + lines.append(l[len(mark):].strip()) + elif lines: + break + return " ".join(lines) + + +def build_section(): + rows = [] + for f in ("build-firmware.sh", "demo.sh", "stm32-lisp", "docs/deploy.sh"): + if read(f) is not None: + rows.append([code(f), esc(header_comment(f, "#"))]) + host = read("host.lisp") or "" + cmds = re.findall(r";;;\s{3}(\S+(?: \S+)?)\s{2,}(.*)", host) + out = table(["File", "Purpose (from its header comment)"], rows) + if cmds: + out += "<h3 id=\"spec-host-commands\">host.lisp commands</h3>" + table( + ["sbcl --script host.lisp ...", "What"], [[code(a), esc(b)] for a, b in cmds]) + for f in ("build-firmware.sh", "demo.sh", "stm32-lisp"): + s = read(f) + if s: + out += "<details><summary><code>%s</code></summary><pre>%s</pre></details>" % (f, esc(s)) + return out + + +def demo_section(): + host = read("host.lisp") or "" + checks = re.findall(r'\("((?:[^"\\]|\\.)*)" "((?:[^"\\]|\\.)*)"\)', host) + out = "" + if checks: + out += ("<p>The expressions <code>demo.sh</code> sends to the chip and the answers it " + "requires (from <code>host.lisp</code>). Any mismatch fails the demo.</p>" + + table(["Expression", "Expected"], [[code(e), code(w)] for e, w in checks])) + t = read("transcript.txt") + if t: + out += "<details><summary>Last recorded transcript.txt</summary><pre>%s</pre></details>" % esc(t) + return out + + +def results_section(): + rows = [] + for layer, f, pat in (("1-2 assembler vs GNU as", "asm-tests.txt", r"asm-test: .*"), + ("3 Forth kernel words", "kernel-tests.txt", r"kernel tests: .*"), + ("4 Scheme: chibi-scheme R7RS suite (pass / fail / skip / total)", + "tests/r7rs/results.txt", r"r7rs suite: .*"), + ("4 Scheme: our own regression suite", "conformance.txt", r"conformance: .*")): + m = re.search(pat, read(f) or "") + if m: + rows.append([esc(layer), code(f), esc(m.group(0))]) + return ("<p>Measured on the current stack (own kernel, no third-party Forth). Each file is " + "written by its test run and committed with the code.</p>" + + table(["Layer", "File", "Last result"], rows)) if rows else "" + + +CSS = """ +:root{--bg:#fdfdfb;--fg:#1d1d1b;--mut:#666;--line:#ddd;--code:#f2f1ec;--acc:#1f5fbf} +@media (prefers-color-scheme:dark){:root{--bg:#16171a;--fg:#e6e6e3;--mut:#9a9a9a;--line:#33353a;--code:#202227;--acc:#7fb0ff}} +*{box-sizing:border-box}html{-webkit-text-size-adjust:100%} +body{margin:0 auto;max-width:72rem;padding:1rem 16px 4rem;background:var(--bg);color:var(--fg); +font:16px/1.55 system-ui,-apple-system,"Segoe UI",sans-serif} +a{color:var(--acc)}h1{font-size:1.7rem;margin:.2rem 0}h2{border-bottom:1px solid var(--line);padding-bottom:.2rem;margin-top:2.5rem} +code,pre{font-family:ui-monospace,"SFMono-Regular",Menlo,Consolas,monospace;font-size:.88em} +code{background:var(--code);padding:.05em .3em;border-radius:3px} +pre{background:var(--code);padding:.8rem;overflow-x:auto;border-radius:6px;line-height:1.4} +pre code{background:none;padding:0} +.tw{overflow-x:auto}table{border-collapse:collapse;margin:.6rem 0;font-size:.92em} +th,td{border:1px solid var(--line);padding:.3rem .5rem;text-align:left;vertical-align:top} +th{background:var(--code)}.cs{display:grid;gap:1rem;grid-template-columns:repeat(auto-fit,minmax(min(100%,34rem),1fr))} +.cs pre{margin:0;font-size:.82em}nav ol{padding-left:1.2rem}nav li{margin:.1rem 0}.mut{color:var(--mut);font-size:.9em} +details{margin:.5rem 0}summary{cursor:pointer} +""" + + +def main(): + toc, body = [], [] + + def sec(lvl, title, content): + if not content: + return + a = slug(title) + toc.append((lvl, a, title)) + body.append('<h%d id="%s">%s</h%d>\n%s' % (lvl, a, esc(title), lvl, content)) + + # TOP: cheat sheets + cs = [] + for f, t in (("docs/forth-cheatsheet.txt", "Mecrisp Forth"), ("docs/forthlisp-cheatsheet.txt", "Chip Lisp")): + s = read(f) + if s: + cs.append('<div><h3 id="cheat-%s">%s</h3><pre>%s</pre></div>' % (slug(t), t, esc(s))) + sec(2, "Cheat sheets", '<div class="cs">%s</div>' % "".join(cs)) + + # BELOW: spec + toc.append((2, "spec", "Implementation spec")) + body.append('<h2 id="spec">Implementation spec</h2>') + notes = read("NOTES.md") + if notes: + body.append(md(notes, toc, "spec-", base=3)) + sec(3, "Special forms (from lisp.fs)", forms_section()) + sec(3, "Primitives (from prims.lisp)", prims_section()) + sec(3, "Library procedures (from prelude.scm)", prelude_section()) + sec(3, "R7RS conformance subset", conformance_section()) + sec(3, "Forth words of the interpreter (from lisp.fs)", words_section()) + sec(3, "Build, flash, run", build_section()) + sec(3, "Test results by layer", results_section()) + sec(3, "Verified examples", demo_section()) + z = read("z80/NOTES.md") + if z: + sec(2, "Z80 version (z80/NOTES.md)", md(z, [], "z80-", base=3)) + + try: + rev = subprocess.run(["git", "-C", ROOT, "log", "-1", "--format=%h %cd", "--date=short"], + capture_output=True, text=True).stdout.strip() + except OSError: + rev = "" + nav = "<nav><b>Contents</b><ol>%s</ol></nav>" % "".join( + '<li style="margin-left:%drem"><a href="#%s">%s</a></li>' % ((lvl - 2) * 1.2, a, inline(t)) + for lvl, a, t in toc) + page = """<!doctype html><html lang="en"><head><meta charset="utf-8"> +<meta name="viewport" content="width=device-width,initial-scale=1"> +<meta name="color-scheme" content="light dark"> +<title>Forth + Lisp on STM32</title><style>%s</style></head><body> +<h1>Assembly → SBCL → Forth → Lisp on STM32</h1> +<p class="mut">Generated from <a href="https://github.com/equwal/lisp-forth-lisp">equwal/lisp-forth-lisp</a> at %s by <code>docs/build-docs.py</code>. Do not edit the HTML; edit the sources.</p> +%s +%s +</body></html> +""" % (CSS, esc(rev or "working tree"), nav, "\n".join(body)) + out = sys.argv[1] if len(sys.argv) > 1 else os.path.join(ROOT, "docs", "index.html") + with open(out, "w", encoding="utf-8") as f: + f.write(page) + print(out) + + +if __name__ == "__main__": + main() diff --git a/docs/forthlisp-cheatsheet.txt b/docs/forthlisp-cheatsheet.txt new file mode 100644 index 0000000..63d43ea --- /dev/null +++ b/docs/forthlisp-cheatsheet.txt @@ -0,0 +1,55 @@ +CHIP SCHEME CHEAT SHEET (R7RS-small subset, written in Forth, emulated STM32F446) +================================================================================== +Start: stm32-lisp (boots QEMU, loads the Scheme, gives the > prompt) +Layers: assembly -> SBCL breadboard -> our own Forth kernel -> this Scheme. + The Scheme is Forth source loaded through the chip's Forth console. +Edit: Backspace and Delete both erase. An expression may span lines. + +SWITCHING + (forth) leave Scheme, back to the Forth ok. prompt + lisp (at the Forth prompt) re-enter Scheme + Ctrl-C quit QEMU + +DATA + 42 -7 exact integers, 31 bits, no overflow check + #t #f booleans; only #f is false ('() is true) + 'a '(1 2 . 3) symbols, lists, dotted pairs + "a b\n" #(1 2 3) strings, vectors + +SPECIAL FORMS + (define x 10) (define (f a . rest) ...) (set! x 11) + (lambda (x) ...) (lambda args ...) (begin e1 e2) + (if c a b) (when c ...) (unless c ...) (and ...) (or ...) + (cond (test e) (test => proc) (else e)) (case k ((1 2) e) (else e)) + (let ((x 1)) ...) (let* ...) (letrec ...) (letrec* ...) + (let loop ((i 0)) (if (< i 10) (loop (+ i 1)) i)) named let + (do ((i 0 (+ i 1))) ((= i 5) 'done) body) + +PROCEDURES + + - * quotient remainder modulo abs max min gcd lcm square + = < > <= >= zero? positive? negative? odd? even? + eq? eqv? equal? not car cdr cons set-car! set-cdr! caar cadr cdar cddr caddr + list length append reverse list-tail list-ref list-copy make-list + memq memv member assq assv assoc map for-each apply + null? pair? list? symbol? number? integer? boolean? procedure? + string? string-length string-append string=? string->list list->string`n make-vector vector vector-ref vector-set! vector-length vector->list`n sqrt (exact floor) floor round display write newline + +EXAMPLES TO TYPE + (define (fact n) (if (< n 2) 1 (* n (fact (- n 1))))) + (fact 10) => 3628800 + (map (lambda (n) (* n n)) '(1 2 3 4)) => (1 4 9 16) + (map + '(1 2 3) '(10 20 30)) => (11 22 33) + (let loop ((i 0)) (if (< i 10000) (loop (+ i 1)) i)) => 10000 + (assq 'b '((a 1) (b 2))) => (b 2) + (apply + 1 2 '(3 4)) => 10 + (vector-ref (make-vector 3 7) 1) => 7 + (string-append "a " "b") => "a b" + +LIMITS + 64 KiB heap (8191 cells), garbage collected at any time + tail calls run in constant stack; deep non-tail recursion: too deep + no chars, floats, macros, call/cc; vector-ref walks a list + Errors (unbound variable, not a pair, too deep, ...) return to > + +FORTH SIDE (after (forth)) + 1 2 + . => 3 words list Forth words diff --git a/host.lisp b/host.lisp new file mode 100644 index 0000000..ac116bc --- /dev/null +++ b/host.lisp @@ -0,0 +1,299 @@ +;;; host.lisp -- host side: a Lisp-to-Forth compiler and a serial driver for the +;;; Mecrisp Forth that runs in QEMU. Run with: sbcl --script host.lisp <command> +;;; +;;; compile FILE print the Forth that FILE's defuns compile to +;;; load send lisp.fs and the compiled prims.lisp, enter the target REPL +;;; demo scripted transcript of all three layers +;;; ktest [FILE] run the kernel word tests (default forth-tests.txt) on a fresh chip +;;; suite run the vendored chibi-scheme R7RS suite (tests/r7rs/), write results.txt +;;; test [FILE] run the R7RS conformance subset (default r7rs-tests.scm) on the chip +;;; +;;; The compiler keeps every local on the Forth data stack and tracks the stack +;;; layout at compile time, so a variable reference becomes dup / over / n pick. + +(require :sb-bsd-sockets) +(defpackage :lfl (:use :cl)) +(in-package :lfl) + +;;; ---------- compiler ---------- + +(defvar *out*) +(defvar *current* nil) +(defparameter *void-words* '(print cr) + "Forth words that push nothing.") + +(defun emit (&rest toks) (dolist (tok toks) (push tok *out*))) +(defun word (sym) (string-downcase (symbol-name sym))) + +(defun compile-expr (x env) + "Compile X with ENV, the compile-time stack top first (NIL marks a temporary). +Return T when the code leaves one value on the stack." + (cond ((integerp x) (emit (princ-to-string x)) t) + ((null x) (emit "0") t) + ((symbolp x) + (let ((n (position x env))) + (case n + ((nil) (emit (word x)) (not (member x *void-words*))) + (0 (emit "dup") t) + (1 (emit "over") t) + (t (emit (format nil "~d pick" n)) t)))) + ((eq (car x) 'if) + (destructuring-bind (c a b) (cdr x) + (compile-expr c env) (emit "if") (compile-expr a env) + (emit "else") (compile-expr b env) (emit "then") t)) + ((eq (car x) 'forth) (apply #'emit (cdr x)) t) + (t (let ((e env)) + (dolist (a (cdr x)) + (unless (compile-expr a e) (error "~s pushes nothing" a)) + (push nil e))) + (compile-expr (if (eq (car x) *current*) 'recurse (car x)) + (make-list (length (cdr x)) :initial-element :arg))))) + +(defun compile-defun (form) + "(defun name (params) body...) -> one line of Forth." + (destructuring-bind (name params &rest body) (cdr form) + (let ((*current* name) (*out* nil) (env (reverse params))) + (emit ":" (word name)) + (loop for (b . more) on body + do (when (and (compile-expr b env) more) (emit "drop"))) + (loop repeat (length params) do (emit "nip")) + (emit ";") + (format nil "~{~a~^ ~}" (reverse *out*))))) + +(defun compile-form (form) + "Return the Forth lines for one top-level form." + (ecase (car form) + (defun (list (compile-defun form))) + (defprims (loop for (name fw) in (cdr form) + collect (format nil "' ~a defprim ~a" (word fw) (word name)))))) + +(defun read-forms (path) + (with-open-file (s path) + (loop for f = (read s nil) while f collect f))) + +(defun compile-file-to-forth (path) + (mapcan #'compile-form (read-forms path))) + +;;; ---------- serial transport (QEMU -serial tcp:127.0.0.1:PORT,server,nowait) ---------- + +(defvar *sock*) +(defvar *io*) +(defvar *log* t "Echo the conversation to stdout.") + +(defun connect (&optional (port (parse-integer (or (sb-ext:posix-getenv "PORT") "4444")))) + (loop repeat 150 + do (handler-case + (let ((s (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) + (sb-bsd-sockets:socket-connect s #(127 0 0 1) port) + (setf *sock* s + *io* (sb-bsd-sockets:socket-make-stream + s :input t :output t :element-type 'character + :buffering :none :external-format :latin-1)) + (return t)) + (sb-bsd-sockets:socket-error () (sleep 0.2))) + finally (error "QEMU serial port ~d not reachable" port))) + +(defun read-until (done-p timeout) + "Read chars until (funcall done-p text) or TIMEOUT seconds. Return the text." + (let ((acc (make-array 0 :element-type 'character :adjustable t :fill-pointer 0)) + (deadline (+ (get-internal-real-time) (* timeout internal-time-units-per-second))) + (fd (sb-bsd-sockets:socket-file-descriptor *sock*))) + (loop + (when (funcall done-p acc) (return (remove #\Return acc))) + (let ((left (/ (- deadline (get-internal-real-time)) internal-time-units-per-second))) + (when (<= left 0) (error "timeout after ~as; target said: ~s" timeout acc)) + ;; Drain the stream's own buffer before sleeping on the fd. + (let ((c (read-char-no-hang *io* nil :eof))) + (cond ((eq c :eof) (error "serial connection closed")) + (c (vector-push-extend c acc)) + (t (sb-sys:wait-until-fd-usable fd :input left)))))))) + +(defun ends-with (suffix s) + (let ((n (length s)) (m (length suffix))) + (and (>= n m) (string= suffix s :start2 (- n m))))) + +(defun send (line) + "Send LINE one char at a time, waiting for the target's echo of each. QEMU's USART +has a one-byte receive register and Mecrisp polls it, so a burst loses characters." + (loop for c across line + do (write-char c *io*) (finish-output *io*) + (read-until (lambda (s) (find c s)) 2)) + (write-char #\Newline *io*) (finish-output *io*) + (show line)) + +(defun show (text) + (when *log* (write-string text) (finish-output))) + +(defun forth (line &key (timeout 5)) + "Send one line to the Forth interpreter and wait for its ok." + (send line) + (let ((reply (read-until (lambda (s) (or (ends-with " ok." s) + (search "not found." s) + (search "Stack" s))) + timeout))) + (show reply) (show (string #\Newline)) + (unless (ends-with " ok." reply) (error "Forth error: ~a" reply)) + (when (search "Redefine" reply) (error "~a: a word was redefined; later words may bind to the wrong one" reply)) + reply)) + +(defun comment-start (l) + "Position of a Forth \\ comment word in L: a backslash at the start or after a space, +followed by a space or the end of the line. A backslash inside code (e.g. in .\" #\\\") stays." + (loop for i from 0 below (length l) + when (and (char= (char l i) #\\) + (or (zerop i) (char= (char l (1- i)) #\Space)) + (or (= i (1- (length l))) (char= (char l (1+ i)) #\Space))) + return i)) + +(defun forth-lines (lines) + (dolist (l lines) + (let ((l (string-trim " " (subseq l 0 (comment-start l))))) + (unless (string= l "") (forth l))))) + +(defun lisp-prompt (&key (timeout 5)) + "Read up to the target Lisp's prompt. Return the text before it." + (let ((reply (read-until (lambda (s) (ends-with "> " s)) timeout))) + (show reply) + (string-trim '(#\Newline #\Space) (subseq reply 0 (- (length reply) 2))))) + +(defun lisp-eval (expr &key (timeout 10)) + "Send EXPR to the target Lisp REPL. Return the printed result." + (send expr) + (lisp-prompt :timeout timeout)) + +;;; ---------- commands ---------- + +(defparameter *here* (directory-namestring (or *load-truename* "./"))) +(defun here (name) + "NAME relative to this file's directory, unless NAME is already absolute." + (if (and (plusp (length name)) (char= (char name 0) #\/)) name (concatenate 'string *here* name))) + +(defun load-target () + "Layer 2 + 3: send lisp.fs, then the Forth that prims.lisp compiles to." + (forth "") + (forth-lines (with-open-file (s (here "lisp.fs")) + (loop for l = (read-line s nil) while l collect l))) + (forth-lines (compile-file-to-forth (here "prims.lisp"))) + (forth "unused .")) + +(defun file-lines (name) + "Lines of NAME that are not blank and not ; comments." + (with-open-file (s (here name)) + (loop for l = (read-line s nil) while l + for tl = (string-trim " " l) + unless (or (string= tl "") (char= (char tl 0) #\;)) collect tl))) + +(defun enter-lisp () + "Enter the chip REPL and load prelude.scm, one form per line." + (send "lisp") + (lisp-prompt) + (let ((*log* nil)) + (dolist (l (file-lines "prelude.scm")) + (let ((r (lisp-eval l))) + (when (search "error" r) (error "prelude: ~a gave ~a" l r)))))) + +(defun ktest (name) + "Layer 3: run NAME (lines of INPUT ==> OUTPUT) on a freshly booted kernel. Return failures." + (let ((pass 0) (fail 0)) + (forth "") + (with-open-file (s (here name)) + (loop for l = (read-line s nil) while l + for tl = (string-trim " " l) + unless (or (string= tl "") (char= (char tl 0) #\\)) + do (let* ((k (search "==>" tl)) + (in (string-trim " " (subseq tl 0 k))) + (want (and k (string-trim " " (subseq tl (+ k 3)))))) + (send in) + (let* ((r (read-until (lambda (s) (or (ends-with " ok." s) (search "not found." s) + (search "underflow" s))) + 10)) + (r (string-trim '(#\Space #\Newline) (if (ends-with " ok." r) (subseq r 0 (- (length r) 4)) r)))) + (if (or (null want) (string= r want)) + (incf pass) + (progn (incf fail) (format t "~&FAIL ~a => ~s (want ~s)~%" in r want))))))) + (format t "~&kernel tests: ~d passed, ~d failed, ~d total~%" pass fail (+ pass fail)) + fail)) + +(defun conformance (name) + "Run NAME: lines of EXPR ==> WANT, compared as printed text. Return the failure count." + (let ((pass 0) (fail 0)) + (dolist (l (file-lines name)) + (let* ((k (search "==>" l)) + (e (string-trim " " (subseq l 0 k))) + (want (if k (string-trim " " (subseq l (+ k 3))) nil)) + (got (lisp-eval e))) + (if (or (null want) (string= got want)) + (incf pass) + (progn (incf fail) (format t "FAIL ~a => ~a (want ~a)~%" e got want))))) + (format t "~%conformance: ~d passed, ~d failed, ~d total~%" pass fail (+ pass fail)) + fail)) + +(defun demo () + (connect) + (format t "~%=== Layer 1: host Lisp compiles Lisp to Forth and runs it on the chip ===~%") + (forth "") + (dolist (line (compile-file-to-forth (here "demo.lisp"))) + (format t "[compiled] ~a~%" line) + (forth line)) + (flet ((check (line want) + (let ((r (forth line))) + (unless (search want r) (error "layer 1: ~a gave ~a" line r))))) + (check "7 sq ." "49") (check "10 fact ." "3628800")) + (format t "~%=== Layer 2: load the Forth Lisp (core lisp.fs + prims compiled from prims.lisp) ===~%") + (let ((*log* nil)) (load-target)) + (format t "~a~%" (forth "unused .")) + (format t "~%=== Layer 3: Lisp (host) -> Forth (chip) -> Lisp (chip) ===~%") + (enter-lisp) + (let ((bad 0)) + (loop for (e want) in + '(("(+ 1 2)" "3") + ("(define (sq x) (* x x))" "sq") + ("(sq 7)" "49") + ("(define (fact n) (if (< n 2) 1 (* n (fact (- n 1)))))" "fact") + ("(fact 7)" "5040") + ("(cons 1 (cons 2 '()))" "(1 2)") + ("(car '(a b c))" "a") + ("(define (my-map f l) (if (null? l) '() (cons (f (car l)) (my-map f (cdr l)))))" "my-map") + ("(my-map sq '(1 2 3 4))" "(1 4 9 16)") + ("((lambda (x y) (- x y)) 10 3)" "7") + ("(map fact '(1 2 3 4 5))" "(1 2 6 24 120)") + ("(let loop ((i 0)) (if (< i 10000) (loop (+ i 1)) i))" "10000") + ("(eq? (car '(a)) 'a)" "#t") + ("(< 2 1)" "#f")) + do (let ((v (lisp-eval e))) + (format t "~a => ~a~a~%" e v (if (string= v want) "" (progn (incf bad) " <-- WRONG"))))) + (send "(forth)") (forth "") + (format t "(forth) => back at the Forth prompt~%") + (format t "~a~%" (forth "unused .")) + (if (zerop bad) + (format t "~%SUCCESS: all three layers answered as expected.~%") + (progn (format t "~%FAILED: ~d wrong answers.~%" bad) (sb-ext:exit :code 1))))) + +(load (here "suite.lisp")) + +(defun main (args) + (let ((cmd (first args))) + (cond ((equal cmd "compile") + (format t "~{~a~%~}" (compile-file-to-forth (second args)))) + ((equal cmd "load") + (connect) (load-target) (enter-lisp)) + ((equal cmd "demo") (demo)) + ((equal cmd "forth") + (connect) (let ((*log* nil)) (load-target)) + (dolist (e (cdr args)) (forth e))) + ((equal cmd "ktest") + (connect) + (let ((*log* nil)) (unless (zerop (ktest (or (second args) "forth-tests.txt"))) (sb-ext:exit :code 1)))) + ((equal cmd "suite") + (connect) (let ((*log* nil)) (load-target) (enter-lisp)) + (run-suite "tests/r7rs/")) + ((equal cmd "test") + (connect) (let ((*log* nil)) (load-target) (enter-lisp)) + (unless (zerop (conformance (or (second args) "r7rs-tests.scm"))) (sb-ext:exit :code 1))) + ((equal cmd "eval") + (connect) (let ((*log* nil)) (load-target) (enter-lisp)) + (dolist (e (cdr args)) (format t "~a => ~a~%" e (lisp-eval e)))) + (t (format t "usage: host.lisp compile FILE | load | demo | ktest [FILE] | suite | test [FILE] | eval EXPR... | forth LINE...~%"))))) + +(handler-case (main (cdr sb-ext:*posix-argv*)) + (error (e) (format t "~&FAILED: ~a~%" e) (sb-ext:exit :code 1))) diff --git a/lisp.fs b/lisp.fs new file mode 100644 index 0000000..706c197 --- /dev/null +++ b/lisp.fs @@ -0,0 +1,500 @@ +\ lisp.fs -- an R7RS-small subset Scheme in Forth (our own kernel) for the STM32F446 (128 KiB RAM). +\ Values are 32-bit. Low 3 bits: xx1 fixnum (31-bit signed), 000 pair (0 is '()), +\ 010 symbol, 100 immediate (#f #t, unspecified, unbound, box tags, special-form markers, +\ characters), 110 procedure or box. +\ Pairs, symbols and procedures are 8-byte cells in `heap`: car word, cdr word. +\ Symbol: car = fixnum offset of its counted name in `names`, cdr = global value. +\ Procedure: car = fixnum primitive number, or a closure's parameters; closure cdr = (body . env). +\ Box: a 110 cell whose car is a box tag. Strings, vectors and bytevectors keep their contents +\ in a contiguous blob in `bheap`; the box's cdr holds the blob's data address. A blob header +\ names its one owner box, so the GC can slide live blobs down and fix the owner's cdr. +\ Rule: never hold a blob address across an allocation (cons, newbox); re-fetch it from the box. +\ A character is an immediate: (code+1) << 12 | 4. +\ An environment is an alist of (symbol . value) bindings in front of the globals. +\ GC: mark-sweep, run when cons finds the free list empty. Roots: the symbol list, plus +\ every word on the data and return stacks that looks like a heap reference (conservative). + +49152 constant heapsize +heapsize buffer: heap +heapsize 64 / buffer: marks \ one bit per 8-byte cell +16384 constant bsize \ blob heap for strings, vectors, bytevectors +bsize buffer: bheap +0 variable btop +4096 constant namesize +namesize buffer: names +64 buffer: tok +128 cells buffer: prims +32 cells buffer: forms \ special-form handlers +512 constant linesize \ one REPL line; an expression may span lines +linesize buffer: lbuf +0 variable lpos 0 variable llen +0 variable free 0 variable ntop 0 variable syms 0 variable nprims 0 variable nforms +-1 variable pk +0 variable rsave 0 variable ssave +0 variable raw \ 1 while display prints strings without quotes +0 variable 'eval 0 variable 'read 0 variable 'repl 0 variable 'print + +4 constant #f 12 constant #t 20 constant unspec 28 constant unbound + +: fixnum? ( v -- f ) 1 and 0<> ; +: sym? ( v -- f ) 7 and 2 = ; +: pair? ( v -- f ) dup 7 and 0= swap 0<> and ; +: special? ( v -- f ) dup 7 and 4 = swap dup 131 > swap 4096 < and and ; \ forms: (k+16)*8+4 +: char? ( v -- f ) dup 7 and 4 = swap 4095 > and ; +: mkchar ( code -- v ) 1+ 12 lshift 4 or ; +: charcode ( v -- code ) 12 rshift 1- ; +: fix ( n -- v ) 2* 1 or ; +: unfix ( v -- n ) 1 arshift ; +: addr ( v -- a ) 7 bic heap + ; +: car ( v -- v ) addr @ ; +: cdr ( v -- v ) addr cell+ @ ; +: car! ( v p -- ) addr ! ; +: cdr! ( v p -- ) addr cell+ ! ; +36 constant strtag 44 constant vectag 68 constant bvtag +: box? ( v tag -- f ) over 7 and 6 = if swap car = else 2drop false then ; +: proc? ( v -- f ) dup 7 and 6 = if car 7 and 4 <> else drop false then ; \ boxes have an immediate tag in car +: truth ( v -- f ) #f <> ; +: bool ( f -- v ) if #t else #f then ; +: (eval) 'eval @ execute ; : (read) 'read @ execute ; : (print) 'print @ execute ; + +: err ( addr len -- ) type cr rsave @ 0= if quit then + 1 lpos ! 0 llen ! -1 pk ! ssave @ sp! rsave @ rp! 'repl @ execute ; +: pair ( v -- v ) dup pair? 0= if s" not a pair" err then ; +: num ( v -- n ) dup fixnum? 0= if s" not a number" err then unfix ; + +\ --- garbage collector --- +: mbit ( v -- addr mask ) 3 rshift dup 3 rshift marks + swap 7 and 1 swap lshift ; +: marked? ( v -- f ) 7 bic mbit swap c@ and 0<> ; +: ref? ( w -- f ) \ tag 000, 010 or 110 and inside the heap + dup 7 and dup 4 = swap 1 and or 0= swap 7 bic dup 7 > swap heapsize u< and and ; +: mark ( v -- ) begin dup ref? while + dup marked? if drop exit then dup 7 bic mbit swap cbis! + dup vectag box? if dup cdr ?dup if dup 4 - @ 2 rshift 0 ?do dup i cells + @ recurse loop drop then then + dup car recurse cdr repeat drop ; +: scan ( hi lo -- ) begin 2dup u> while dup @ mark cell+ repeat 2drop ; +: sweep 0 free ! heapsize 8 - begin dup 7 > while + dup marked? 0= if free @ over heap + ! dup free ! then 8 - repeat drop ; +0 variable bsrc 0 variable bdst +: blive? ( hdr -- f ) dup @ dup marked? if cdr swap 8 + = else 2drop false then ; +: bcompact \ slide live blobs down, fix each owner's data address + 0 bsrc ! 0 bdst ! + begin bsrc @ btop @ < while + bheap bsrc @ + dup 4 + @ aligned 8 + + over blive? if + over bheap bdst @ + 2 pick move + bheap bdst @ + dup 8 + swap @ cdr! + dup bdst +! + then nip bsrc +! + repeat bdst @ btop ! ; +: gc marks heapsize 64 / 0 fill syms @ mark + rsave @ if ssave @ sp@ scan rsave @ rp@ scan then sweep bcompact ; +: cons ( a d -- p ) free @ 0= if gc free @ 0= if s" out of memory" err then then + free @ dup car free ! tuck cdr! tuck car! ; +: balloc ( n box -- ) over aligned 8 + dup btop @ + bsize > if gc dup btop @ + bsize > if + s" out of memory" err then then + bheap btop @ + >r btop +! dup r@ ! over r@ 4 + ! r@ 8 + rot 0 fill r> 8 + swap cdr! ; +: newbox ( n tag -- box ) 0 cons 6 or tuck balloc ; +: blen ( box -- n ) cdr 4 - @ ; +: bdat ( box -- addr ) cdr ; +: chk ( v tag -- v ) over over box? 0= if s" wrong type" err then drop ; +: listlen ( list -- n ) 0 swap begin dup pair? while swap 1+ swap cdr repeat drop ; +: l>s ( list -- str ) dup listlen strtag newbox swap 0 swap begin dup pair? while + dup car charcode 3 pick bdat 3 pick + c! swap 1+ swap cdr repeat 2drop ; +: l>bv ( list -- bv ) dup listlen bvtag newbox swap 0 swap begin dup pair? while + dup car unfix 3 pick bdat 3 pick + c! swap 1+ swap cdr repeat 2drop ; +: l>v ( list -- vec ) dup listlen cells vectag newbox swap 0 swap begin dup pair? while + dup car 3 pick bdat 3 pick cells + ! swap 1+ swap cdr repeat 2drop ; + +\ --- symbols --- +: name ( sym -- addr len ) car unfix names + count ; +: intern ( addr len -- sym ) + syms @ begin dup while + >r 2dup r@ car name compare if 2drop r> car exit then r> cdr + repeat drop + ntop @ over + 1+ namesize > if s" symbol space full" err then + ntop @ >r dup r@ names + c! dup 1+ ntop +! r@ names + 1+ swap move + r> fix unbound cons 2 or dup syms @ cons syms ! ; + +0 ntop ! 0 syms ! 0 nprims ! 0 nforms ! gc +token quote intern constant s-quote +token else intern constant s-else +token => intern constant s-=> + +\ --- numbers: 31-bit fixnums (overflow is an error), exact rationals, single-precision flonums --- +\ A rational is a 110 cell: car rattag, cdr (numerator . denominator), normalized, denominator > 1. +\ A flonum is a 110 cell: car flotag, cdr the IEEE-754 single bits (the kernel's FPU words). +52 constant rattag 60 constant flotag +: rat? ( v -- f ) rattag box? ; +: flo? ( v -- f ) flotag box? ; +: numeric? ( v -- f ) dup fixnum? over rat? or swap flo? or ; +: ovf s" overflow" err ; +: fits? ( n -- f ) dup 1073741823 > swap -1073741824 < or 0= ; +: >fix ( n -- v ) dup fits? 0= if ovf then fix ; +: *c ( a b -- n ) m* over 0< if 1+ then if ovf then dup fits? 0= if ovf then ; +: +c ( a b -- n ) + dup fits? 0= if ovf then ; +: -c ( a b -- n ) - dup fits? 0= if ovf then ; +: flo ( bits -- v ) flotag swap cons 6 or ; +: gcd ( a b -- g ) abs swap abs begin dup while tuck mod repeat drop ; +: mkrat ( n d -- v ) dup 0= if s" division by zero" err then + dup 0< if negate swap negate swap then + 2dup gcd tuck / >r / r> + dup 1 = if drop >fix exit then + >r >fix r> >fix cons rattag swap cons 6 or ; +: numden ( v -- n d ) dup fixnum? if unfix 1 exit then + dup rat? if cdr dup car unfix swap cdr unfix exit then s" not an exact number" err ; +0 variable n1 0 variable d1 0 variable n2 0 variable d2 +: nd2 ( a b -- ) numden d2 ! n2 ! numden d1 ! n1 ! ; +: >float ( v -- bits ) dup fixnum? if unfix s>f exit then dup flo? if cdr exit then + dup rat? if cdr dup car unfix s>f swap cdr unfix s>f f/ exit then s" not a number" err ; +: inex? ( a b -- f ) flo? swap flo? or ; +: fl2 ( a b -- af bf ) >float swap >float swap ; +: add2 ( a b -- v ) 2dup inex? if fl2 f+ flo exit then + 2dup and 1 and if unfix swap unfix +c fix exit then + nd2 n1 @ d2 @ *c n2 @ d1 @ *c +c d1 @ d2 @ *c mkrat ; +: sub2 ( a b -- v ) 2dup inex? if fl2 f- flo exit then + 2dup and 1 and if unfix swap unfix swap -c fix exit then + nd2 n1 @ d2 @ *c n2 @ d1 @ *c -c d1 @ d2 @ *c mkrat ; +: mul2 ( a b -- v ) 2dup inex? if fl2 f* flo exit then + 2dup and 1 and if unfix swap unfix *c fix exit then + nd2 n1 @ n2 @ *c d1 @ d2 @ *c mkrat ; +: div2 ( a b -- v ) 2dup inex? if fl2 f/ flo exit then + nd2 n2 @ 0= if s" division by zero" err then n1 @ d2 @ *c d1 @ n2 @ *c mkrat ; +: lt2 ( a b -- f ) 2dup inex? if fl2 f< exit then + 2dup and 1 and if < exit then nd2 n1 @ d2 @ *c n2 @ d1 @ *c < ; +: eq2 ( a b -- f ) 2dup inex? if fl2 f= exit then nd2 n1 @ n2 @ = d1 @ d2 @ = and ; +: eqv ( a b -- f ) 2dup = if 2drop true exit then + 2dup flo? swap flo? and if cdr swap cdr = exit then + 2dup rat? swap rat? and if cdr swap cdr 2dup car swap car = >r cdr swap cdr = r> and exit then + 2drop false ; +: fint? ( bits -- f ) dup 23 rshift 255 and dup 255 = if 2drop false exit then + 150 >= if drop true exit then dup f>s s>f f= ; +: fexact ( bits -- v ) dup $7F800000 and $7F800000 = if s" no exact representation" err then + 1 swap begin dup fint? 0= while $40000000 f* swap 2* swap over 1073741824 u> if ovf then repeat + dup $7FFFFFFF and $4E800000 f< 0= if ovf then f>s swap mkrat ; +: exact ( v -- v ) dup flo? if cdr fexact exit then dup numeric? 0= if s" not a number" err then ; +: inexact ( v -- v ) dup flo? if exit then >float flo ; + +\ --- reader: lines come from the kernel's accept, which handles BS and DEL --- +: refill lbuf linesize accept llen ! 0 lpos ! cr ; +: getc ( -- c ) pk @ dup 0< 0= if -1 pk ! exit then drop + lpos @ llen @ > if refill then + lpos @ llen @ = if 1 lpos +! 10 exit then + lbuf lpos @ + c@ 1 lpos +! ; +: skipws begin getc dup 59 = if drop begin getc 10 = until 32 then dup 33 < while drop repeat pk ! ; +: delim? ( c -- f ) dup 33 < over 40 = or over 41 = or swap 59 = or ; +: rdtok ( n -- addr len ) begin getc dup delim? 0= while + over 63 < if over tok + c! 1+ else drop then repeat pk ! tok swap ; +: digits ( addr len -- u true | false ) dup 0= if 2drop false exit then + 0 -rot over + swap do dup 107374182 > if drop false unloop exit then + 10 * i c@ 48 - dup 9 u> if 2drop false unloop exit then + loop true ; +: num? ( addr len -- v true | false ) + over c@ 45 = if swap 1+ swap 1- digits if negate >fix true else false then exit then + over c@ 43 = if swap 1+ swap 1- then digits if >fix true else false then ; +0 variable fm 0 variable fe 0 variable fsaw 0 variable fneg 0 variable fpt +: dig? ( c -- f ) 48 - 10 u< ; +: /1 ( a n -- a+1 n-1 ) swap 1+ swap 1- ; +: adddig ( d -- ) s>f fm @ $41200000 f* f+ fm ! ; +: rdflo ( addr len -- v true | false ) + 2dup s" +inf.0" compare if 2drop $7F800000 flo true exit then + 2dup s" -inf.0" compare if 2drop $FF800000 flo true exit then + 2dup s" +nan.0" compare if 2drop $7FC00000 flo true exit then + 0 fm ! 0 fe ! 0 fsaw ! 0 fneg ! 0 fpt ! + over c@ 45 = if -1 fneg ! /1 else over c@ 43 = if /1 then then + begin dup if over c@ dig? else 0 then while over c@ 48 - adddig -1 fsaw ! /1 repeat + dup if over c@ 46 = if -1 fpt ! /1 + begin dup if over c@ dig? else 0 then while over c@ 48 - adddig -1 fe +! -1 fsaw ! /1 repeat then then + fsaw @ 0= if 2drop false exit then + dup if over c@ 32 or 101 = if -1 fpt ! /1 num? 0= if false exit then unfix fe +! 0 0 + else 2drop false exit then then + 2drop fpt @ 0= if ovf then \ only digits, yet num? refused it: too big for a fixnum + fm @ fe @ dup 0< if negate 0 ?do $41200000 f/ loop else 0 ?do $41200000 f* loop then + fneg @ if $80000000 or then flo true ; +: slash ( addr len -- i | -1 ) 0 begin 2dup > while 2 pick over + c@ 47 = if nip nip exit then 1+ repeat 2drop drop -1 ; +: rdrat ( addr len -- v true | false ) 2dup slash dup 0< if drop 2drop false exit then + >r over r@ num? 0= if rdrop 2drop false exit then + -rot swap r@ 1+ + swap r> 1+ - digits 0= if drop false exit then + swap unfix swap mkrat true ; +: atom ( addr len -- v ) 2dup num? if nip nip exit then + 2dup rdrat if nip nip exit then 2dup rdflo if nip nip exit then + 2dup s" #t" compare if 2drop #t exit then 2dup s" #true" compare if 2drop #t exit then + 2dup s" #f" compare if 2drop #f exit then 2dup s" #false" compare if 2drop #f exit then + intern ; +: rdstr ( -- list ) getc dup 34 = if drop 0 exit then + dup 92 = if drop getc dup 110 = if drop 10 then dup 116 = if drop 9 then then + mkchar recurse cons ; +: cname ( addr len -- code | -1 ) + 2dup s" space" compare if 2drop 32 exit then 2dup s" newline" compare if 2drop 10 exit then + 2dup s" tab" compare if 2drop 9 exit then 2dup s" null" compare if 2drop 0 exit then + 2dup s" alarm" compare if 2drop 7 exit then 2dup s" backspace" compare if 2drop 8 exit then + 2dup s" delete" compare if 2drop 127 exit then 2dup s" escape" compare if 2drop 27 exit then + 2dup s" return" compare if 2drop 13 exit then + over c@ 120 = if base @ >r 16 base ! /1 number r> base ! if exit then -1 exit then + 2drop -1 ; +: rdchar ( -- v ) getc tok c! 1 rdtok dup 1 = if drop c@ mkchar exit then + cname dup 0< if drop s" bad character name" err then mkchar ; +: rdlist ( -- list ) skipws getc + dup 41 = if drop 0 exit then + dup 46 = if drop (read) skipws getc drop exit then + pk ! (read) recurse cons ; +: read ( -- v ) skipws getc + dup 40 = if drop rdlist exit then + dup 39 = if drop s-quote recurse 0 cons cons exit then + dup 41 = if drop s" unexpected )" err then + dup 34 = if drop rdstr l>s exit then + dup 35 = if drop getc dup 40 = if drop rdlist l>v exit then + dup 92 = if drop rdchar exit then + dup 117 = if drop getc drop getc drop rdlist l>bv exit then \ #u8( + pk ! 35 tok c! 1 rdtok atom exit then + pk ! 0 rdtok atom ; +' read 'read ! + +\ --- printer --- +: pint ( n -- ) dup 0< if 45 emit negate then 0 <# #s #> type ; +: pdigits ( E addr len -- ) rot dup -5 < over 9 > or if + >r over c@ emit 46 emit 1- swap 1+ swap dup if type else 2drop 48 emit then 101 emit r> pint exit then + dup 0< if ." 0." negate 1- 0 ?do 48 emit loop type exit then + 1+ 2dup < if over - >r type r> 0 ?do 48 emit loop ." .0" exit then + >r over r@ type swap r@ + swap r> - 46 emit dup if type else 2drop 48 emit then ; +: pflo ( bits -- ) \ ponytail: 7 significant digits from float scaling; the last digit can be off by one, + \ so output need not read back to the same float. Shortest round-trip printing needs 64-bit digit generation. + dup $7F800000 and $7F800000 = if dup $7FFFFF and if drop ." +nan.0" exit then + 0< if ." -inf.0" else ." +inf.0" then exit then + dup 0< if 45 emit $7FFFFFFF and then + dup 0= if drop ." 0.0" exit then + 0 swap begin dup $4B189680 f< 0= while $41200000 f/ swap 1+ swap repeat + begin dup $49742400 f< while $41200000 f* swap 1- swap repeat + $3F000000 f+ f>s dup 9999999 > if 10 / swap 1+ swap then + swap 6 + swap 0 <# #s #> + begin dup 1 > if 2dup + 1- c@ 48 = else 0 then while 1- repeat pdigits ; +: pnum ( v -- ) unfix pint ; +: pchar ( v -- ) charcode raw @ if emit exit then ." #\" + dup 32 = if drop ." space" exit then dup 10 = if drop ." newline" exit then + dup 9 = if drop ." tab" exit then dup 0= if drop ." null" exit then emit ; +: pstr ( box -- ) raw @ if dup bdat swap blen type exit then + 34 emit dup blen 0 ?do dup bdat i + c@ + dup 34 = over 92 = or if 92 emit then dup 10 = if drop 92 emit 110 emit else emit then loop drop 34 emit ; +: pvec ( box -- ) ." #(" dup blen 2 rshift 0 ?do i if space then dup bdat i cells + @ (print) loop drop 41 emit ; +: pbv ( box -- ) ." #u8(" dup blen 0 ?do i if space then dup bdat i + c@ pint loop drop 41 emit ; +: print ( v -- ) + dup fixnum? if pnum exit then + dup 0= if drop ." ()" exit then + dup sym? if name type exit then + dup #t = if drop ." #t" exit then + dup #f = if drop ." #f" exit then + dup char? if pchar exit then + dup strtag box? if pstr exit then + dup vectag box? if pvec exit then + dup bvtag box? if pbv exit then + dup rat? if cdr dup car pnum 47 emit cdr pnum exit then + dup flo? if cdr pflo exit then + dup proc? if drop ." #<procedure>" exit then + dup special? if drop ." #<syntax>" exit then + dup pair? 0= if drop exit then + 40 emit begin dup car recurse cdr + dup 0= if drop 41 emit exit then + dup pair? 0= if ." . " recurse 41 emit exit then space again ; +' print 'print ! + +\ --- environments --- +: where ( sym env -- binding | 0 ) + begin dup while 2dup car car = if nip car exit then cdr repeat 2drop 0 ; +: lookup ( sym env -- v ) over swap where ?dup if nip cdr exit then + dup cdr dup unbound <> if nip exit then drop ." unbound variable: " name type s" " err ; +: frame ( env -- env' ) #f #f cons swap cons ; \ a dummy binding that internal defines can follow +: bind ( params args env -- env' ) + begin 2 pick pair? while over pair? 0= if s" too few arguments" err then + 2 pick car 2 pick car cons swap cons rot cdr rot cdr rot repeat + rot dup 0= if drop swap if s" too many arguments" err then exit then + rot cons swap cons ; +: def-bind ( val sym env -- ) dup 0= if drop cdr! exit then + >r swap cons r@ car r@ cdr cons r@ cdr! r> car! ; +: closure ( params body env -- proc ) cons cons 6 or ; +: evlis ( list env -- list' ) over 0= if drop exit then + over car over (eval) >r swap cdr swap recurse r> swap cons ; + +\ --- eval: handlers return ( x env 0 ) for a tail call or ( v -1 ) for a value --- +: seq ( body env -- x env 0 | v -1 ) over 0= if 2drop unspec -1 exit then + begin over cdr while over car over (eval) drop swap cdr swap repeat swap car swap 0 ; +: applyc ( f args -- x env 0 | v -1 ) + over proc? 0= if s" not a procedure" err then + over car fixnum? if swap car unfix cells prims + @ execute -1 exit then + over car swap rot cdr dup >r cdr frame bind r> car swap seq ; +: apply ( f args -- v ) applyc if exit then (eval) ; +: eval ( x env -- v ) + begin + rp@ rsave @ 3500 - u< sp@ ssave @ 3500 - u< or if s" too deep" err then \ 4 KiB stacks + over sym? if lookup exit then + over pair? 0= if drop exit then + over car over recurse + dup special? if 3 rshift 16 - cells forms + @ execute + else -rot swap cdr swap evlis applyc then + until ; +' eval 'eval ! + +: defform ( xt "name" -- ) nforms @ cells forms + ! + nforms @ 16 + 3 lshift 4 or token intern cdr! 1 nforms +! ; + +: f-quote ( x env ) drop cdr car -1 ; +: f-if ( x env ) >r cdr dup car r@ (eval) truth if cdr car else cdr cdr dup if car else drop unspec then then r> 0 ; +: f-lambda ( x env ) >r cdr dup car swap cdr r> closure -1 ; +: f-begin ( x env ) swap cdr swap seq ; +: f-define ( x env ) swap cdr dup car sym? if + dup car >r cdr car over (eval) r@ rot def-bind r> -1 exit then + dup car car >r dup car cdr swap cdr 2 pick closure r@ rot def-bind r> -1 ; +: f-set ( x env ) swap cdr dup car >r cdr car over (eval) swap r@ swap where + ?dup if cdr! else r@ cdr! then rdrop unspec -1 ; +: lbind ( binds env eenv -- env' ) \ evaluate each (name expr) in eenv, bind onto env + begin 2 pick while 2 pick car dup car swap cdr car 2 pick (eval) cons + rot cons swap rot cdr -rot repeat drop nip ; +: lbind* ( binds env -- env' ) begin over while + over car dup car swap cdr car 2 pick (eval) cons swap cons swap cdr swap repeat nip ; +: cars ( list -- list' ) dup 0= if exit then dup car car swap cdr recurse cons ; +: evargs ( binds env -- vals ) over 0= if drop exit then + over car cdr car over (eval) >r swap cdr swap recurse r> swap cons ; +: namedlet ( env rest -- x env 0 ) + dup cdr car 2 pick evargs >r + dup car unbound cons >r + swap frame r@ swap cons + over cdr car cars rot cdr cdr 2 pick closure + dup r> cdr! nip r> applyc ; +: f-let ( x env ) swap cdr dup car sym? if namedlet exit then + dup car rot dup frame swap lbind swap cdr swap seq ; +: f-let* ( x env ) swap cdr dup car rot frame lbind* swap cdr swap seq ; +: prebind ( binds env -- env' ) begin over while over car car unbound cons swap cons swap cdr swap repeat nip ; +: setall ( binds env -- ) begin over while + over car cdr car over (eval) 2 pick car car 2 pick where cdr! swap cdr swap repeat 2drop ; +: f-letrec ( x env ) swap cdr dup car rot frame over swap prebind tuck setall swap cdr swap seq ; +: f-cond ( x env ) swap cdr begin dup while + dup car car s-else = if car cdr swap seq exit then + dup car car 2 pick (eval) dup truth if + swap car cdr dup 0= if drop nip -1 exit then + dup car s-=> = if cdr car 2 pick (eval) rot drop swap 0 cons applyc exit then + nip swap seq exit then + drop cdr repeat 2drop unspec -1 ; +: memq ( v list -- f ) begin dup pair? while 2dup car = if 2drop true exit then cdr repeat 2drop false ; +: f-case ( x env ) swap cdr dup car 2 pick (eval) swap cdr begin dup while + dup car car dup s-else = swap 3 pick swap memq or if + car cdr dup car s-=> = if cdr car 2 pick (eval) rot drop swap 0 cons applyc exit then + nip swap seq exit then + cdr repeat drop 2drop unspec -1 ; +: f-and ( x env ) swap cdr dup 0= if 2drop #t -1 exit then + begin dup cdr while dup car 2 pick (eval) truth 0= if 2drop #f -1 exit then cdr repeat car swap 0 ; +: f-or ( x env ) swap cdr dup 0= if 2drop #f -1 exit then + begin dup cdr while dup car 2 pick (eval) dup truth if nip nip -1 exit then drop cdr repeat car swap 0 ; +: f-when ( x env ) >r cdr dup car r@ (eval) truth if cdr r> seq else drop rdrop unspec -1 then ; +: f-unless ( x env ) >r cdr dup car r@ (eval) truth if drop rdrop unspec -1 else cdr r> seq then ; +: seqall ( body env -- ) begin over while over car over (eval) drop swap cdr swap repeat 2drop ; +: stepvals ( vars env -- vals ) over 0= if drop exit then + over car cdr cdr dup if car over (eval) else drop over car car over lookup then + >r swap cdr swap recurse r> swap cons ; +: f-do ( x env ) swap cdr swap over car over dup frame swap lbind + begin 2 pick cdr car car over (eval) truth 0= while + 2 pick cdr cdr over seqall + 2 pick car over stepvals nip 2 pick car cars swap 2 pick frame bind + repeat nip swap cdr car cdr swap seq ; + +' f-quote defform quote ' f-if defform if ' f-lambda defform lambda +' f-begin defform begin ' f-define defform define ' f-set defform set! +' f-let defform let ' f-let* defform let* ' f-letrec defform letrec +' f-letrec defform letrec* ' f-cond defform cond ' f-case defform case +' f-and defform and ' f-or defform or ' f-when defform when +' f-unless defform unless ' f-do defform do + +\ --- primitives written in Forth; prims.lisp adds the rest --- +: defprim ( xt "name" -- ) token intern >r nprims @ dup 1+ nprims ! + tuck cells prims + ! fix 0 cons 6 or r> cdr! ; +: spread ( list -- list' ) dup cdr 0= if car exit then dup car swap cdr recurse cons ; +: p-apply ( args -- v ) dup car swap cdr spread apply ; +: p-display ( args -- v ) 1 raw ! car print 0 raw ! unspec ; +: p-write ( args -- v ) car print unspec ; +0 variable fsz +: arg2 ( args -- a b ) dup car swap cdr car ; +: arg3 ( args -- a b c ) dup car swap cdr dup car swap cdr car ; +: ix ( box i size -- addr ) >r over blen r@ / over u> 0= if s" index out of range" err then r> * swap bdat + ; +: range ( box s e size -- box s e ) >r 2dup > if s" bad range" err then + over 0< if s" bad range" err then 2 pick blen r> / over < if s" bad range" err then ; +: p-string? ( args -- v ) car strtag box? bool ; +: p-vector? ( args -- v ) car vectag box? bool ; +: p-bv? ( args -- v ) car bvtag box? bool ; +: p-char? ( args -- v ) car char? bool ; +: p-c>i ( args -- v ) car dup char? 0= if s" not a character" err then charcode fix ; +: p-i>c ( args -- v ) car num mkchar ; +: p-slen ( args -- v ) car strtag chk blen fix ; +: p-vlen ( args -- v ) car vectag chk blen 2 rshift fix ; +: p-bvlen ( args -- v ) car bvtag chk blen fix ; +: p-sref ( args -- v ) arg2 num swap strtag chk swap 1 ix c@ mkchar ; +: p-sset ( args -- v ) arg3 charcode >r num swap strtag chk swap 1 ix r> swap c! unspec ; +: p-vref ( args -- v ) arg2 num swap vectag chk swap 4 ix @ ; +: p-vset ( args -- v ) arg3 >r num swap vectag chk swap 4 ix r> swap ! unspec ; +: p-bvref ( args -- v ) arg2 num swap bvtag chk swap 1 ix c@ fix ; +: p-bvset ( args -- v ) arg3 num >r num swap bvtag chk swap 1 ix r> swap c! unspec ; +: fillbox ( k tag c size -- box ) \ a new box of k elements, each c; c stays on the stack (a GC root) + fsz ! -rot over fsz @ * swap newbox swap 0 ?do + dup bdat i fsz @ * + 2 pick fsz @ 1 = if swap c! else swap ! then loop nip ; +: opt ( args default -- x ) over cdr if drop cdr car else nip then ; +: p-mkstr ( args -- v ) dup car num swap 32 mkchar opt charcode strtag swap 1 fillbox ; +: p-mkvec ( args -- v ) dup car num swap #f opt vectag swap 4 fillbox ; +: p-mkbv ( args -- v ) dup car num swap 1 opt unfix bvtag swap 1 fillbox ; +: >list ( box s e size -- list ) \ elements s..e-1 as a list: chars, values or byte fixnums + >r 0 swap begin 2 pick over < while 1- + 3 pick bdat over r@ * + r@ 1 = if c@ else @ then + 4 pick strtag box? if mkchar else 4 pick bvtag box? if fix then then + rot cons swap repeat drop nip nip rdrop ; +: p-s>l ( args -- v ) arg3 num >r num r> 2 pick strtag chk drop 1 range 1 >list ; +: p-v>l ( args -- v ) arg3 num >r num r> 2 pick vectag chk drop 4 range 4 >list ; +: p-bv>l ( args -- v ) car bvtag chk 0 over blen 1 >list ; +: p-l>s ( args -- v ) car l>s ; +: p-l>v ( args -- v ) car l>v ; +: p-l>bv ( args -- v ) car l>bv ; +: ssub ( box s e -- str ) 1 range over - dup strtag newbox >r rot bdat rot + r@ bdat rot move r> ; +: p-substr ( args -- v ) arg3 num >r num r> 2 pick strtag chk drop ssub ; +: p-sapp ( args -- v ) arg2 strtag chk swap strtag chk swap + over blen over blen + strtag newbox >r + over bdat r@ bdat 3 pick blen move + dup bdat r@ bdat 3 pick blen + 2 pick blen move 2drop r> ; +: scmp ( a b -- n ) over blen over blen min 0 ?do over bdat i + c@ over bdat i + c@ - ?dup if + nip nip 0< if -1 else 1 then unloop exit then loop + blen swap blen swap - dup 0< if drop -1 else 0> if 1 else 0 then then ; +: p-scmp ( args -- v ) arg2 strtag chk swap strtag chk swap scmp fix ; +: p-s>sym ( args -- v ) car strtag chk dup blen 63 min >r bdat tok r@ move tok r> intern ; +: p-sym>s ( args -- v ) car dup sym? 0= if s" not a symbol" err then + name dup strtag newbox dup >r bdat swap move r> ; +: p-newline ( args -- v ) drop cr unspec ; +: p-set-car ( args -- v ) dup cdr car swap car pair car! unspec ; +: p-set-cdr ( args -- v ) dup cdr car swap car pair cdr! unspec ; +: p-forth ( args -- ) drop ssave @ sp! rsave @ rp! ; +: p-exact ( args -- v ) car exact ; +: p-inexact ( args -- v ) car inexact ; +: p-eqv ( args -- v ) dup car swap cdr car eqv bool ; +: p-number? ( args -- v ) car numeric? bool ; +: p-integer? ( args -- v ) car dup fixnum? if drop #t exit then dup flo? if cdr fint? bool exit then drop #f ; +: p-rational? ( args -- v ) car dup flo? if cdr $7F800000 and $7F800000 <> bool exit then dup fixnum? swap rat? or bool ; +: p-exact? ( args -- v ) car dup numeric? 0= if s" not a number" err then dup fixnum? swap rat? or bool ; +: p-inexact? ( args -- v ) car dup numeric? 0= if s" not a number" err then flo? bool ; +: p-exint? ( args -- v ) car fixnum? bool ; +: p-num ( args -- v ) car numden drop >fix ; +: p-den ( args -- v ) car numden nip >fix ; +: p-nan? ( args -- v ) car dup flo? if cdr dup $7F800000 and $7F800000 = swap $7FFFFF and 0<> and bool exit then drop #f ; +: p-inf? ( args -- v ) car dup flo? if cdr $7FFFFFFF and $7F800000 = bool exit then drop #f ; +' p-exact defprim exact ' p-inexact defprim inexact ' p-eqv defprim eqv? +' p-number? defprim number? ' p-number? defprim real? ' p-number? defprim complex? +' p-integer? defprim integer? ' p-rational? defprim rational? +' p-exact? defprim exact? ' p-inexact? defprim inexact? ' p-exint? defprim exact-integer? +' p-num defprim %numerator ' p-den defprim %denominator ' p-nan? defprim nan? ' p-inf? defprim infinite? +' p-apply defprim apply ' p-display defprim display ' p-write defprim write +' p-string? defprim string? ' p-vector? defprim vector? ' p-bv? defprim bytevector? +' p-char? defprim char? ' p-c>i defprim char->integer ' p-i>c defprim integer->char +' p-slen defprim string-length ' p-vlen defprim vector-length ' p-bvlen defprim bytevector-length +' p-sref defprim string-ref ' p-sset defprim string-set! ' p-vref defprim vector-ref +' p-vset defprim vector-set! ' p-bvref defprim bytevector-u8-ref ' p-bvset defprim bytevector-u8-set! +' p-mkstr defprim make-string ' p-mkvec defprim make-vector ' p-mkbv defprim make-bytevector +' p-s>l defprim %string->list ' p-v>l defprim %vector->list ' p-bv>l defprim %bytevector->list +' p-l>s defprim list->string ' p-l>v defprim list->vector ' p-l>bv defprim list->bytevector +' p-substr defprim %substring ' p-sapp defprim %string-append2 ' p-scmp defprim %string-compare +' p-s>sym defprim string->symbol ' p-sym>s defprim symbol->string +' p-newline defprim newline ' p-set-car defprim set-car! ' p-set-cdr defprim set-cdr! +' p-forth defprim forth + +: repl begin 0 raw ! ." > " read 0 eval dup unspec = if drop else print then cr again ; +' repl 'repl ! +: lisp ( -- ) sp@ ssave ! rp@ rsave ! 1 lpos ! 0 llen ! -1 pk ! cr repl ; diff --git a/prelude.scm b/prelude.scm new file mode 100644 index 0000000..849fe52 --- /dev/null +++ b/prelude.scm @@ -0,0 +1,105 @@ +; prelude.scm -- R7RS-small procedures written in the chip Scheme itself. +; host.lisp sends this file to the chip REPL one line at a time: keep one form per line. +(define (not x) (if x #f #t)) +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caddr x) (car (cddr x))) +(define (list . xs) xs) +(define (length l) (let loop ((l l) (n 0)) (if (pair? l) (loop (cdr l) (+ n 1)) n))) +(define (reverse l) (let loop ((l l) (acc '())) (if (pair? l) (loop (cdr l) (cons (car l) acc)) acc))) +(define (append2 a b) (if (pair? a) (cons (car a) (append2 (cdr a) b)) b)) +(define (append . ls) (cond ((null? ls) '()) ((null? (cdr ls)) (car ls)) (else (append2 (car ls) (apply append (cdr ls)))))) +(define (list-tail l k) (if (= k 0) l (list-tail (cdr l) (- k 1)))) +(define (list-ref l k) (car (list-tail l k))) +(define (map1 f l) (if (pair? l) (cons (f (car l)) (map1 f (cdr l))) '())) +(define (any-null? ls) (cond ((null? ls) #f) ((null? (car ls)) #t) (else (any-null? (cdr ls))))) +(define (map f . ls) (if (null? (cdr ls)) (map1 f (car ls)) (if (any-null? ls) '() (cons (apply f (map1 car ls)) (apply map f (map1 cdr ls)))))) +(define (for-each f . ls) (if (any-null? ls) #t (begin (apply f (map1 car ls)) (apply for-each f (map1 cdr ls))))) +(define (equal? a b) (cond ((and (pair? a) (pair? b)) (and (equal? (car a) (car b)) (equal? (cdr a) (cdr b)))) ((and (string? a) (string? b)) (= 0 (%string-compare a b))) ((and (vector? a) (vector? b)) (equal? (vector->list a) (vector->list b))) ((and (bytevector? a) (bytevector? b)) (equal? (%bytevector->list a) (%bytevector->list b))) (else (eqv? a b)))) +(define (mem= same? x l) (cond ((null? l) #f) ((same? x (car l)) l) (else (mem= same? x (cdr l))))) +(define (memq x l) (mem= eq? x l)) +(define (memv x l) (mem= eqv? x l)) +(define (member x l) (mem= equal? x l)) +(define (ass= same? x l) (cond ((null? l) #f) ((same? x (car (car l))) (car l)) (else (ass= same? x (cdr l))))) +(define (assq x l) (ass= eq? x l)) +(define (assv x l) (ass= eqv? x l)) +(define (assoc x l) (ass= equal? x l)) +(define (zero? n) (= n 0)) +(define (positive? n) (> n 0)) +(define (negative? n) (< n 0)) +(define (odd? n) (not (= 0 (remainder n 2)))) +(define (even? n) (= 0 (remainder n 2))) +(define (abs n) (if (< n 0) (- n) n)) +(define (max x . r) (let loop ((m x) (r r) (i (inexact? x))) (if (null? r) (if i (inexact m) m) (loop (if (> (car r) m) (car r) m) (cdr r) (or i (inexact? (car r))))))) +(define (min x . r) (let loop ((m x) (r r) (i (inexact? x))) (if (null? r) (if i (inexact m) m) (loop (if (< (car r) m) (car r) m) (cdr r) (or i (inexact? (car r))))))) +(define (numerator q) (if (exact? q) (%numerator q) (inexact (%numerator (exact q))))) +(define (denominator q) (if (exact? q) (%denominator q) (inexact (%denominator (exact q))))) +(define (exact->inexact z) (inexact z)) +(define (inexact->exact z) (exact z)) +(define (finite? z) (not (or (nan? z) (infinite? z)))) +(define (gcd . ns) (if (null? ns) 0 (let loop ((a (abs (car ns))) (r (cdr ns))) (if (null? r) a (loop (let g ((a a) (b (abs (car r)))) (if (= b 0) a (g b (remainder a b)))) (cdr r)))))) +(define (lcm . ns) (if (null? ns) 1 (let loop ((a (abs (car ns))) (r (cdr ns))) (if (null? r) a (loop (if (= a 0) 0 (quotient (abs (* a (car r))) (gcd a (car r)))) (cdr r)))))) +(define (square n) (* n n)) +(define (boolean=? a b) (eq? a b)) +(define (symbol=? a b) (eq? a b)) +(define (list? l) (let loop ((slow l) (fast l)) (cond ((null? fast) #t) ((not (pair? fast)) #f) ((null? (cdr fast)) #t) ((not (pair? (cdr fast))) #f) (else (let ((fast (cddr fast)) (slow (cdr slow))) (if (eq? fast slow) #f (loop slow fast))))))) +(define (list-copy l) (if (pair? l) (cons (car l) (list-copy (cdr l))) l)) +(define (make-list k . fill) (let loop ((k k) (acc '())) (if (= k 0) acc (loop (- k 1) (cons (if (null? fill) #f (car fill)) acc))))) +(define (string->list s . r) (%string->list s (if (pair? r) (car r) 0) (if (and (pair? r) (pair? (cdr r))) (cadr r) (string-length s)))) +(define (vector->list v . r) (%vector->list v (if (pair? r) (car r) 0) (if (and (pair? r) (pair? (cdr r))) (cadr r) (vector-length v)))) +(define (substring s start end) (%substring s start end)) +(define (string-copy s . r) (%substring s (if (pair? r) (car r) 0) (if (and (pair? r) (pair? (cdr r))) (cadr r) (string-length s)))) +(define (string-append . ss) (let loop ((acc "") (ss ss)) (if (null? ss) acc (loop (%string-append2 acc (car ss)) (cdr ss))))) +(define (string . cs) (list->string cs)) +(define (%chain cmp ok? xs) (let loop ((xs xs)) (cond ((null? (cdr xs)) #t) ((ok? (cmp (car xs) (cadr xs))) (loop (cdr xs))) (else #f)))) +(define (string=? . ss) (%chain %string-compare zero? ss)) +(define (string<? . ss) (%chain %string-compare negative? ss)) +(define (string>? . ss) (%chain %string-compare positive? ss)) +(define (string<=? . ss) (%chain %string-compare (lambda (n) (<= n 0)) ss)) +(define (string>=? . ss) (%chain %string-compare (lambda (n) (>= n 0)) ss)) +(define (%ccmp a b) (- (char->integer a) (char->integer b))) +(define (char=? . cs) (%chain %ccmp zero? cs)) +(define (char<? . cs) (%chain %ccmp negative? cs)) +(define (char>? . cs) (%chain %ccmp positive? cs)) +(define (char<=? . cs) (%chain %ccmp (lambda (n) (<= n 0)) cs)) +(define (char>=? . cs) (%chain %ccmp (lambda (n) (>= n 0)) cs)) +(define (char-upper-case? c) (let ((n (char->integer c))) (and (>= n 65) (<= n 90)))) +(define (char-lower-case? c) (let ((n (char->integer c))) (and (>= n 97) (<= n 122)))) +(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) +(define (char-numeric? c) (let ((n (char->integer c))) (and (>= n 48) (<= n 57)))) +(define (char-whitespace? c) (if (memv (char->integer c) '(32 9 10 12 13)) #t #f)) +(define (char-upcase c) (if (char-lower-case? c) (integer->char (- (char->integer c) 32)) c)) +(define (char-downcase c) (if (char-upper-case? c) (integer->char (+ (char->integer c) 32)) c)) +(define (char-foldcase c) (char-downcase c)) +(define (digit-value c) (if (char-numeric? c) (- (char->integer c) 48) #f)) +(define (vector . xs) (list->vector xs)) +(define (vector-fill! v x . r) (let loop ((i (if (pair? r) (car r) 0))) (if (< i (if (and (pair? r) (pair? (cdr r))) (cadr r) (vector-length v))) (begin (vector-set! v i x) (loop (+ i 1)))))) +(define (vector-copy v . r) (list->vector (apply vector->list v r))) +(define (vector-append . vs) (list->vector (apply append (map vector->list vs)))) +(define (vector-map f . vs) (list->vector (apply map f (map vector->list vs)))) +(define (vector-for-each f . vs) (apply for-each f (map vector->list vs))) +(define (string-map f . ss) (list->string (apply map f (map string->list ss)))) +(define (string-for-each f . ss) (apply for-each f (map string->list ss))) +(define (vector->string v . r) (list->string (apply vector->list v r))) +(define (string->vector s . r) (list->vector (apply string->list s r))) +(define (bytevector . bs) (list->bytevector bs)) +(define (bytevector->list b) (%bytevector->list b)) +(define (bytevector-copy b . r) (let ((l (%bytevector->list b))) (list->bytevector (list-head (list-tail l (if (pair? r) (car r) 0)) (- (if (and (pair? r) (pair? (cdr r))) (cadr r) (length l)) (if (pair? r) (car r) 0)))))) +(define (list-head l k) (if (= k 0) '() (cons (car l) (list-head (cdr l) (- k 1))))) +(define (bytevector-append . bs) (list->bytevector (apply append (map %bytevector->list bs)))) +(define (utf8->string b) (list->string (map integer->char (%bytevector->list b)))) +(define (string->utf8 s) (list->bytevector (map char->integer (string->list s)))) +(define (floor n) n) +(define (ceiling n) n) +(define (round n) n) +(define (truncate n) n) +(define (sqrt n) (if (< n 2) n (let loop ((x n)) (let ((y (quotient (+ x (quotient n x)) 2))) (if (>= y x) x (loop y)))))) +(define (exact-integer-sqrt n) (let ((s (sqrt n))) (list s (- n (* s s))))) +(define (%cicmp a b) (- (char->integer (char-foldcase a)) (char->integer (char-foldcase b)))) +(define (char-ci=? . cs) (%chain %cicmp zero? cs)) +(define (char-ci<? . cs) (%chain %cicmp negative? cs)) +(define (char-ci>? . cs) (%chain %cicmp positive? cs)) +(define (char-ci<=? . cs) (%chain %cicmp (lambda (n) (<= n 0)) cs)) +(define (char-ci>=? . cs) (%chain %cicmp (lambda (n) (>= n 0)) cs)) \ No newline at end of file diff --git a/prims.lisp b/prims.lisp new file mode 100644 index 0000000..a416da5 --- /dev/null +++ b/prims.lisp @@ -0,0 +1,50 @@ +;;; prims.lisp -- the chip Scheme's arithmetic and type primitives, in the host dialect. +;;; host.lisp compiles each defun to a Mecrisp Forth word and sends it to the chip, where +;;; lisp.fs registers it with defprim. A primitive takes its argument list (a chip list) +;;; and returns one tagged value. car cdr cons fix num bool pair? sym? proc? fixnum? err +;;; are words from lisp.fs; + - * / mod negate xor = < > are Forth. + +;; Generic arithmetic: add2 sub2 mul2 div2 lt2 eq2 (lisp.fs) handle fixnums, rationals and +;; flonums. The accumulators here are tagged values: 1 is the fixnum 0, 3 is the fixnum 1. +(defun sum (l acc) (if (= l 0) acc (sum (cdr l) (add2 acc (car l))))) +(defun prod (l acc) (if (= l 0) acc (prod (cdr l) (mul2 acc (car l))))) +(defun diff (l acc) (if (= l 0) acc (diff (cdr l) (sub2 acc (car l))))) +(defun quo (l acc) (if (= l 0) acc (quo (cdr l) (div2 acc (car l))))) +(defun prim+ (a) (sum a 1)) +(defun prim* (a) (prod a 3)) +(defun prim- (a) (if (= (cdr a) 0) (sub2 1 (car a)) (diff (cdr a) (car a)))) +(defun prim/ (a) (if (= (cdr a) 0) (div2 3 (car a)) (quo (cdr a) (car a)))) +(defun divisor (a) (if (= (num (car (cdr a))) 0) (forth "s\" division by zero\" err") (num (car (cdr a))))) +(defun prim-quotient (a) (fix (/ (num (car a)) (divisor a)))) +(defun prim-remainder (a) (fix (mod (num (car a)) (divisor a)))) +(defun floored (r y) (if (if (= r 0) 0 (< (xor r y) 0)) (+ r y) r)) +(defun prim-modulo (a) (fix (floored (mod (num (car a)) (divisor a)) (num (car (cdr a)))))) + +;; Comparison chains: (< 1 2 3) is #t. Each returns a Forth flag for bool. +(defun chain= (l) (if (= (cdr l) 0) -1 (if (eq2 (car l) (car (cdr l))) (chain= (cdr l)) 0))) +(defun chain< (l) (if (= (cdr l) 0) -1 (if (lt2 (car l) (car (cdr l))) (chain< (cdr l)) 0))) +(defun chain> (l) (if (= (cdr l) 0) -1 (if (lt2 (car (cdr l)) (car l)) (chain> (cdr l)) 0))) +(defun chain<= (l) (if (= (cdr l) 0) -1 (if (lt2 (car (cdr l)) (car l)) 0 (chain<= (cdr l))))) +(defun chain>= (l) (if (= (cdr l) 0) -1 (if (lt2 (car l) (car (cdr l))) 0 (chain>= (cdr l))))) +(defun prim= (a) (bool (chain= a))) +(defun prim< (a) (bool (chain< a))) +(defun prim> (a) (bool (chain> a))) +(defun prim<= (a) (bool (chain<= a))) +(defun prim>= (a) (bool (chain>= a))) + +(defun prim-eq (a) (bool (= (car a) (car (cdr a))))) +(defun prim-car (a) (car (pair (car a)))) +(defun prim-cdr (a) (cdr (pair (car a)))) +(defun prim-cons (a) (cons (car a) (car (cdr a)))) +(defun prim-null (a) (bool (= (car a) 0))) +(defun prim-pair (a) (bool (pair? (car a)))) +(defun prim-symbol (a) (bool (sym? (car a)))) +(defun prim-procedure (a) (bool (proc? (car a)))) +(defun prim-boolean (a) (bool (if (= (car a) (forth "#t")) -1 (= (car a) (forth "#f"))))) + +;; (name forth-word): what defprim registers. Values are tagged words, so eq? and eqv? agree. +(defprims (+ prim+) (- prim-) (* prim*) (/ prim/) (quotient prim-quotient) (remainder prim-remainder) + (modulo prim-modulo) (= prim=) (< prim<) (> prim>) (<= prim<=) (>= prim>=) + (eq? prim-eq) (car prim-car) (cdr prim-cdr) (cons prim-cons) + (null? prim-null) (pair? prim-pair) (symbol? prim-symbol) + (procedure? prim-procedure) (boolean? prim-boolean)) \ No newline at end of file diff --git a/r7rs-tests.scm b/r7rs-tests.scm new file mode 100644 index 0000000..56fe448 --- /dev/null +++ b/r7rs-tests.scm @@ -0,0 +1,326 @@ +; r7rs-tests.scm -- conformance subset, run on the emulated chip by: host.lisp test +; Each line: EXPR ==> printed result. Most cases are the examples of R7RS-small +; (sections 4.1, 4.2, 5.3, 6.1, 6.2, 6.3, 6.4, 6.10); a line without ==> only has to evaluate. +; 4.1.1 variables, 4.1.2 literals +(define x 28) ==> x +x ==> 28 +(quote a) ==> a +'a ==> a +'(+ 1 2) ==> (+ 1 2) +'() ==> () +'#t ==> #t +145932 ==> 145932 +#t ==> #t +#false ==> #f +; 4.1.3 procedure calls +(+ 3 4) ==> 7 +((if #f + *) 3 4) ==> 12 +; 4.1.4 lambda +((lambda (x) (+ x x)) 4) ==> 8 +(define reverse-subtract (lambda (x y) (- y x))) ==> reverse-subtract +(reverse-subtract 7 10) ==> 3 +(define add4 (let ((x 4)) (lambda (y) (+ x y)))) ==> add4 +(add4 6) ==> 10 +((lambda x x) 3 4 5 6) ==> (3 4 5 6) +((lambda (x y . z) z) 3 4 5 6) ==> (5 6) +; 4.1.5 if +(if (> 3 2) 'yes 'no) ==> yes +(if (> 2 3) 'yes 'no) ==> no +(if (> 3 2) (- 3 2) (+ 3 2)) ==> 1 +; 4.1.6 set! +(define y 2) ==> y +(+ y 1) ==> 3 +(set! y 4) +(+ y 1) ==> 5 +; 4.2.1 cond, case, and, or, when, unless +(cond ((> 3 2) 'greater) ((< 3 2) 'less)) ==> greater +(cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal)) ==> equal +(cond ((assv 'b '((a 1) (b 2))) => cadr) (else #f)) ==> 2 +(case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite)) ==> composite +(case (car '(c d)) ((a e i o u) 'vowel) ((w y) 'semivowel) (else 'consonant)) ==> consonant +(and (= 2 2) (> 2 1)) ==> #t +(and (= 2 2) (< 2 1)) ==> #f +(and 1 2 'c '(f g)) ==> (f g) +(and) ==> #t +(or (= 2 2) (> 2 1)) ==> #t +(or (= 2 2) (< 2 1)) ==> #t +(or #f #f #f) ==> #f +(or (memq 'b '(a b c)) (/ 3 0)) ==> (b c) +(when (= 1 1) 'a 'b) ==> b +(unless (= 1 1) 'a 'b) ==> +; 4.2.2 binding constructs +(let ((x 2) (y 3)) (* x y)) ==> 6 +(let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))) ==> 35 +(let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))) ==> 70 +(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) (even? 88)) ==> #t +(letrec* ((p (lambda (x) (+ 1 (q (- x 1))))) (q (lambda (y) (if (zero? y) 0 (+ 1 (p (- y 1)))))) (x (p 5)) (y x)) y) ==> 5 +; 4.2.3 sequencing +(define x 0) ==> x +(begin (set! x 5) (+ x 1)) ==> 6 +; 4.2.4 iteration +(let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) (cond ((null? numbers) (list nonneg neg)) ((>= (car numbers) 0) (loop (cdr numbers) (cons (car numbers) nonneg) neg)) ((< (car numbers) 0) (loop (cdr numbers) nonneg (cons (car numbers) neg))))) ==> ((6 1 3) (-5 -2)) +(let ((x '(1 3 5 7 9))) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum))) ==> 25 +; 5.3 definitions, internal definitions +(define add3 (lambda (x) (+ x 3))) ==> add3 +(add3 3) ==> 6 +(define first car) ==> first +(first '(1 2)) ==> 1 +(let ((x 5)) (define foo (lambda (y) (bar x y))) (define bar (lambda (a b) (+ (* a b) a))) (foo (+ x 3))) ==> 45 +; 6.1 equivalence +(eqv? 'a 'a) ==> #t +(eqv? 'a 'b) ==> #f +(eqv? 2 2) ==> #t +(eqv? '() '()) ==> #t +(eqv? 100000000 100000000) ==> #t +(eqv? (cons 1 2) (cons 1 2)) ==> #f +(eqv? (lambda () 1) (lambda () 2)) ==> #f +(eqv? #f 'nil) ==> #f +(let ((p (lambda (x) x))) (eqv? p p)) ==> #t +(eq? 'a 'a) ==> #t +(eq? (list 'a) (list 'a)) ==> #f +(eq? '() '()) ==> #t +(eq? car car) ==> #t +(let ((x '(a))) (eq? x x)) ==> #t +(equal? 'a 'a) ==> #t +(equal? '(a) '(a)) ==> #t +(equal? '(a (b) c) '(a (b) c)) ==> #t +(equal? 2 2) ==> #t +; 6.2 numbers (exact integers only) +(integer? 3) ==> #t +(number? 'a) ==> #f +(= 1 1 1) ==> #t +(< 1 2 3) ==> #t +(< 1 3 2) ==> #f +(>= 3 3 1) ==> #t +(zero? 0) ==> #t +(positive? -5) ==> #f +(odd? 7) ==> #t +(even? 0) ==> #t +(max 3 4) ==> 4 +(min 3 4 -1) ==> -1 +(+ 3 4) ==> 7 +(+ 3) ==> 3 +(+) ==> 0 +(* 4) ==> 4 +(*) ==> 1 +(- 3 4) ==> -1 +(- 3 4 5) ==> -6 +(- 3) ==> -3 +(abs -7) ==> 7 +(quotient 17 5) ==> 3 +(remainder 17 5) ==> 2 +(modulo 17 5) ==> 2 +(modulo 17 -5) ==> -3 +(remainder 17 -5) ==> 2 +(modulo -17 5) ==> 3 +(remainder -17 5) ==> -2 +(gcd 32 -36) ==> 4 +(gcd) ==> 0 +(lcm 32 -36) ==> 288 +(lcm) ==> 1 +(square 42) ==> 1764 +; 6.3 booleans +#t ==> #t +'#f ==> #f +(not #t) ==> #f +(not 3) ==> #f +(not (list 3)) ==> #f +(not #f) ==> #t +(not '()) ==> #f +(not (list)) ==> #f +(not 'nil) ==> #f +(boolean? #f) ==> #t +(boolean? 0) ==> #f +(boolean? '()) ==> #f +; 6.4 pairs and lists +(define x (list 'a 'b 'c)) ==> x +(define y x) ==> y +(list? y) ==> #t +(set-cdr! x 4) +x ==> (a . 4) +(eqv? x y) ==> #t +y ==> (a . 4) +(list? y) ==> #f +(pair? '(a . b)) ==> #t +(pair? '(a b c)) ==> #t +(pair? '()) ==> #f +(cons 'a '()) ==> (a) +(cons '(a) '(b c d)) ==> ((a) b c d) +(cons 'a 3) ==> (a . 3) +(cons '(a b) 'c) ==> ((a b) . c) +(car '(a b c)) ==> a +(car '((a) b c d)) ==> (a) +(car '(1 . 2)) ==> 1 +(cdr '((a) b c d)) ==> (b c d) +(cdr '(1 . 2)) ==> 2 +(list? '(a b c)) ==> #t +(list? '()) ==> #t +(list? '(a . b)) ==> #f +(make-list 2 3) ==> (3 3) +(list 'a (+ 3 4) 'c) ==> (a 7 c) +(list) ==> () +(length '(a b c)) ==> 3 +(length '(a (b) (c d e))) ==> 3 +(length '()) ==> 0 +(append '(x) '(y)) ==> (x y) +(append '(a) '(b c d)) ==> (a b c d) +(append '(a (b)) '((c))) ==> (a (b) (c)) +(append '(a b) '(c . d)) ==> (a b c . d) +(append '() 'a) ==> a +(reverse '(a b c)) ==> (c b a) +(reverse '(a (b c) d (e (f)))) ==> ((e (f)) d (b c) a) +(list-tail '(a b c d) 2) ==> (c d) +(list-ref '(a b c d) 2) ==> c +(memq 'a '(a b c)) ==> (a b c) +(memq 'b '(a b c)) ==> (b c) +(memq 'a '(b c d)) ==> #f +(memq (list 'a) '(b (a) c)) ==> #f +(member (list 'a) '(b (a) c)) ==> ((a) c) +(memv 101 '(100 101 102)) ==> (101 102) +(define e '((a 1) (b 2) (c 3))) ==> e +(assq 'a e) ==> (a 1) +(assq 'b e) ==> (b 2) +(assq 'd e) ==> #f +(assq (list 'a) '(((a)) ((b)) ((c)))) ==> #f +(assoc (list 'a) '(((a)) ((b)) ((c)))) ==> ((a)) +(assv 5 '((2 3) (5 7) (11 13))) ==> (5 7) +(list-copy '(1 2 3)) ==> (1 2 3) +; 6.5 symbols +(symbol? 'foo) ==> #t +(symbol? (car '(a b))) ==> #t +(symbol? 'nil) ==> #t +(symbol? '()) ==> #f +(symbol=? 'a 'a) ==> #t +; 6.10 control features +(procedure? car) ==> #t +(procedure? 'car) ==> #f +(procedure? (lambda (x) (* x x))) ==> #t +(procedure? '(lambda (x) (* x x))) ==> #f +(apply + (list 3 4)) ==> 7 +(apply + 1 2 '(3 4)) ==> 10 +(map cadr '((a b) (d e) (g h))) ==> (b e h) +(map + '(1 2 3) '(10 20 30)) ==> (11 22 33) +(map (lambda (n) (* n n)) '(1 2 3 4 5)) ==> (1 4 9 16 25) +(let ((v '())) (for-each (lambda (x) (set! v (cons x v))) '(1 2 3)) v) ==> (3 2 1) +; proper tail calls (3.5): a loop of 20000 iterations runs in constant stack +(define (count n) (if (= n 0) 'done (count (- n 1)))) ==> count +(count 20000) ==> done +; 6.7 strings (regression: a string literal with spaces must read as one string) +"hello world" ==> "hello world" +(string? "a b") ==> #t +(string-length "a b c") ==> 5 +(string->list "ab") ==> (#\a #\b) +"say \"hi\" \\ ok" ==> "say \"hi\" \\ ok" +(equal? "a b" "a b") ==> #t +(begin (display "a b") 'x) ==> a bx +; 6.8 vectors +(make-vector 3 0) ==> #(0 0 0) +(let ((v (make-vector 3 #t))) (vector-set! v 1 #f) v) ==> #(#t #f #t) +(vector-ref '#(1 2 3) 2) ==> 3 +(vector-length (make-vector 7 1)) ==> 7 +(vector->list (vector 1 2 3)) ==> (1 2 3) +; sqrt/floor on exact integers +(sqrt 16) ==> 4 +(floor (sqrt 500)) ==> 22 +(floor 7) ==> 7 +; regression: a reported sieve program, a docstring body, vectors, do, when, named let +(define (sieve-of-eratosthenes n) "Return list of primes up to n." (if (< n 2) '() (let ((marked (make-vector (+ n 1) #t))) (vector-set! marked 0 #f) (vector-set! marked 1 #f) (do ((i 2 (+ i 1))) ((> i (floor (sqrt n)))) (when (vector-ref marked i) (do ((j (* i i) (+ j i))) ((> j n)) (vector-set! marked j #f)))) (let loop ((i 2) (primes '())) (if (> i n) (reverse primes) (loop (+ i 1) (if (vector-ref marked i) (cons i primes) primes))))))) ==> sieve-of-eratosthenes +(sieve-of-eratosthenes 500) ==> (2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499) +(length (sieve-of-eratosthenes 500)) ==> 95 +; regressions found by the chibi suite: list? must stop on a circular list; case accepts => +(let ((x (list 'a))) (set-cdr! x x) (list? x)) ==> #f +(case 5 ((2 3 5 7) => (lambda (p) (* p 10))) (else 'no)) ==> 50 +(case 'z ((a) 1) (else => (lambda (x) x))) ==> z +; 6.2 numbers: overflow is an error, not a silent wrap (regression) +(+ 1073741823 1) ==> overflow +(* 100000 100000) ==> overflow +(- -1073741824 1) ==> overflow +(* 32768 32768) ==> overflow +(+ 1073741822 1) ==> 1073741823 +; 6.2.6 exact rationals and / +(/ 6 4) ==> 3/2 +(/ 6 3) ==> 2 +(/ 3) ==> 1/3 +(/ 3 4 5) ==> 3/20 +(+ 1/2 1/3) ==> 5/6 +(* 2/3 3/2) ==> 1 +(- 1/2) ==> -1/2 +(- 1/2 1/3) ==> 1/6 +(= 1/2 2/4) ==> #t +(< 1/3 1/2) ==> #t +(exact? 1/2) ==> #t +(rational? 1/2) ==> #t +(integer? 1/2) ==> #f +(numerator (/ 6 4)) ==> 3 +(denominator (/ 6 4)) ==> 2 +(denominator 5) ==> 1 +(/ 1 0) ==> division by zero +; 6.2.6 inexact reals (single precision on the M4F FPU) +(+ 1.5 2.25) ==> 3.75 +(* 1.5 2) ==> 3.0 +-2.5 ==> -2.5 +1e3 ==> 1000.0 +(/ 1.0 4) ==> 0.25 +(< 0.3333 (/ 1 3.0) 0.3334) ==> #t +(+ 0.1 0.2) ==> 0.3 +(- 0.5) ==> -0.5 +(inexact 1/4) ==> 0.25 +(exact->inexact 1/2) ==> 0.5 +(exact 0.5) ==> 1/2 +(exact 3.0) ==> 3 +(inexact->exact 0.25) ==> 1/4 +(inexact? 1.0) ==> #t +(exact? 1.0) ==> #f +(integer? 3.0) ==> #t +(integer? 3.5) ==> #f +(exact-integer? 5) ==> #t +(exact-integer? 5.0) ==> #f +(= 1 1.0) ==> #t +(eqv? 1 1.0) ==> #f +(eqv? 1.5 1.5) ==> #t +(eqv? 1/2 (/ 2 4)) ==> #t +(< 1 1.5 2) ==> #t +(max 3 2.0) ==> 3.0 +(min 1 2.0) ==> 1.0 +(abs -2.5) ==> 2.5 +(/ 1.0 0) ==> +inf.0 +(- (/ 1.0 0)) ==> -inf.0 +(number? 1.5) ==> #t +(real? 1/2) ==> #t +; item 2: characters, strings with O(1) access, contiguous vectors, bytevectors +#\a ==> #\a +#\space ==> #\space +(char->integer #\A) ==> 65 +(integer->char 97) ==> #\a +(char? #\a) ==> #t +(char? "a") ==> #f +(char<? #\a #\b #\c) ==> #t +(char-upcase #\a) ==> #\A +(char-alphabetic? #\z) ==> #t +(char-numeric? #\5) ==> #t +(string->list "ab") ==> (#\a #\b) +(list->string (list #\h #\i)) ==> "hi" +(string-ref "abc" 1) ==> #\b +(substring "hello" 1 3) ==> "el" +(let ((s (make-string 3 #\x))) (string-set! s 1 #\y) s) ==> "xyx" +(string-append "ab" "cd" "e") ==> "abcde" +(string<? "abc" "abd") ==> #t +(string=? "ab" "ab" "ab") ==> #t +(string-copy "abc" 1) ==> "bc" +(symbol->string 'abc) ==> "abc" +(string->symbol "xyz") ==> xyz +(begin (write #\a) (display #\b) 'z) ==> #\abz +(vector-length #(1 2 3)) ==> 3 +(vector->list #(1 2 3)) ==> (1 2 3) +(let ((v (make-vector 2000 0))) (let loop ((i 0)) (if (< i 2000) (begin (vector-set! v i i) (loop (+ i 1))))) (vector-ref v 1999)) ==> 1999 +(equal? #(1 (2) "x") (vector 1 (list 2) "x")) ==> #t +(vector-ref #(1 2) 5) ==> index out of range +(bytevector 1 2 255) ==> #u8(1 2 255) +(bytevector-u8-ref #u8(5 6 7) 1) ==> 6 +(let ((b (make-bytevector 2 0))) (bytevector-u8-set! b 0 9) b) ==> #u8(9 0) +(bytevector-length (make-bytevector 10 0)) ==> 10 +(bytevector? #u8()) ==> #t +(utf8->string #u8(104 105)) ==> "hi" +(string->utf8 "AB") ==> #u8(65 66) +(let loop ((i 0) (s "")) (if (< i 3000) (loop (+ i 1) (string-append "ab" "cd")) (string-length s))) ==> 4 +(let ((v (make-vector 100 1))) (let loop ((i 0)) (if (< i 3000) (begin (make-string 10 #\a) (loop (+ i 1))))) (vector-ref v 99)) ==> 1 diff --git a/suite.lisp b/suite.lisp new file mode 100644 index 0000000..103496e --- /dev/null +++ b/suite.lisp @@ -0,0 +1,237 @@ +;;; suite.lisp -- run a vendored R7RS test suite (tests/r7rs/r7rs-tests.scm, chibi-scheme) +;;; on the chip. Loaded by host.lisp. +;;; +;;; The host splits the file into top-level forms and sends each one as a single line. +;;; tests/r7rs/shim.scm defines `test`, `test-assert`, test-begin and test-end on the chip +;;; as procedures that print <<pass>> or <<fail VALUE>>. tests/r7rs/skip.scm names what +;;; cannot run yet, with a reason. Every skipped test is counted. A form that fails before +;;; all of its tests have reported counts the missing ones as failures. + +(in-package :lfl) + +(defun split-forms (text) + "Top-level data of TEXT as strings. Understands ; #| |# #; comments, strings, #\\ chars, |sym|." + (let ((forms '()) (i 0) (n (length text))) + (labels ((peek (k) (if (< (+ i k) n) (char text (+ i k)) #\Nul)) + (delim-p (c) (or (member c '(#\Space #\Tab #\Newline #\Return #\( #\) #\" #\;)) (char= c #\Nul))) + (skip-ws () + (loop + (cond ((>= i n) (return)) + ((member (peek 0) '(#\Space #\Tab #\Newline #\Return #\Page)) (incf i)) + ((char= (peek 0) #\;) (loop until (or (>= i n) (char= (peek 0) #\Newline)) do (incf i))) + ((and (char= (peek 0) #\#) (char= (peek 1) #\|)) + (incf i 2) + (let ((depth 1)) + (loop while (and (< i n) (plusp depth)) + do (cond ((and (char= (peek 0) #\|) (char= (peek 1) #\#)) (decf depth) (incf i 2)) + ((and (char= (peek 0) #\#) (char= (peek 1) #\|)) (incf depth) (incf i 2)) + (t (incf i)))))) + ((and (char= (peek 0) #\#) (char= (peek 1) #\;)) (incf i 2) (skip-ws) (datum)) + (t (return))))) + (datum () + "Skip one datum starting at i." + (let ((c (peek 0))) + (cond ((member c '(#\' #\` #\,)) + (incf i) (when (char= (peek 0) #\@) (incf i)) (skip-ws) (datum)) + ((char= c #\() (incf i) + (loop (skip-ws) + (cond ((>= i n) (return)) + ((char= (peek 0) #\)) (incf i) (return)) + (t (datum))))) + ((char= c #\)) (incf i)) ; stray close: consume + ((char= c #\") (incf i) + (loop until (or (>= i n) (char= (peek 0) #\")) + do (incf i (if (char= (peek 0) #\\) 2 1))) + (incf i)) + ((char= c #\|) (incf i) + (loop until (or (>= i n) (char= (peek 0) #\|)) + do (incf i (if (char= (peek 0) #\\) 2 1))) + (incf i)) + ((and (char= c #\#) (char= (peek 1) #\\)) + (incf i 3) ; #\ plus at least one character + (loop until (delim-p (peek 0)) do (incf i))) + ((and (char= c #\#) (member (peek 1) '(#\( ))) + (incf i) (datum)) + ((and (char= c #\#) (char-equal (peek 1) #\u) (char= (peek 2) #\8) (char= (peek 3) #\()) + (incf i 3) (datum)) + (t (loop until (delim-p (peek 0)) do (incf i))))))) + (loop + (skip-ws) + (when (>= i n) (return)) + (let ((start i)) (datum) (push (subseq text start i) forms)))) + (nreverse forms))) + +(defun one-line (form) + "FORM on one line: newlines outside strings become spaces, inside strings \\n; comments dropped." + (with-output-to-string (o) + (let ((i 0) (n (length form)) (in-str nil) (prev-space nil)) + (loop while (< i n) do + (let ((c (char form i))) + (cond (in-str + (cond ((char= c #\\) (write-char c o) (incf i) (when (< i n) (write-char (char form i) o))) + ((char= c #\") (setf in-str nil) (write-char c o)) + ((char= c #\Newline) (write-string "\\n" o)) + (t (write-char c o)))) + ((and (char= c #\#) (< (1+ i) n) (char= (char form (1+ i)) #\\)) + (write-string "#\\" o) (incf i 2) (when (< i n) (write-char (char form i) o)) (setf prev-space nil)) + ((char= c #\") (setf in-str t) (write-char c o) (setf prev-space nil)) + ((char= c #\;) (loop while (and (< i n) (char/= (char form i) #\Newline)) do (incf i)) (decf i)) + ((member c '(#\Space #\Tab #\Newline #\Return)) + (unless prev-space (write-char #\Space o)) (setf prev-space t)) + (t (write-char c o) (setf prev-space nil)))) + (incf i))))) + +(defparameter *test-heads* '("test" "test-assert" "test-error" "test-values" "test-numeric-syntax" + "test-precision" "test-read-error" "test-write-syntax")) + +(defun form-head (form) + (let* ((s (string-left-trim "(" (string-trim '(#\Space #\Newline) form))) + (e (or (position-if (lambda (c) (member c '(#\Space #\Newline #\( #\)))) s) (length s)))) + (subseq s 0 e))) + +(defun nested-tests (form) + "Heads of the test calls inside FORM, in order." + (let ((heads '()) (start 0)) + (loop + (let ((p (search "(test" form :start2 start))) + (unless p (return (nreverse heads))) + (let ((h (form-head (subseq form p)))) + (when (member h *test-heads* :test #'string=) (push h heads))) + (setf start (1+ p)))))) + +(defun read-skips (path) + "skip.scm entries: (section NAME REASON) (head NAME REASON) (match SUBSTRING REASON) +(literal KIND REASON) (nonlatin1 \"\" REASON)." + (with-open-file (s path) + (let ((*read-eval* nil)) + (loop for e = (read s nil) while e + collect (list (intern (string-upcase (symbol-name (first e))) :keyword) (second e) (third e)))))) + +(defun tokens (form) + "Identifier-like tokens of FORM (a crude split on delimiters)." + (let ((out '()) (start nil)) + (loop for i from 0 to (length form) + for c = (if (< i (length form)) (char form i) #\Space) + do (if (member c '(#\Space #\Newline #\Tab #\( #\) #\' #\")) + (when start (push (subseq form start i) out) (setf start nil)) + (unless start (setf start i)))) + out)) + +(defun defined-names (form) + "Names a skipped setup form would have defined: the name after define / define-syntax, or +every token of a define-record-type." + (let ((head (form-head form)) (toks (reverse (tokens form)))) + (cond ((string= head "define-record-type") + ;; type, constructor, predicate, and each field's accessor/modifier -- not field names + (let ((f (handler-case (let ((*readtable* (copy-readtable nil)) (*read-eval* nil)) + (setf (readtable-case *readtable*) :preserve) + (read-from-string form)) + (error () nil)))) + (if (and (consp f) (>= (length f) 4)) + (mapcar #'princ-to-string + (remove-if-not #'symbolp + (append (list (second f) (if (consp (third f)) (first (third f)) (third f)) (fourth f)) + (loop for fld in (nthcdr 4 f) when (consp fld) append (cdr fld))))) + (cdr toks)))) + ((member head '("define" "define-syntax" "define-values") :test #'string=) + (list (string-left-trim "(" (second toks)))) + (t '())))) + +(defvar *skipped-names* '() "(name . reason) for definitions that were skipped.") + +(defun literal-kind (tok) + "Which number literal TOK is: :bignum (beyond 31 bits), :complex, :float, :ratio, :prefix, or NIL." + (let ((digits (some #'digit-char-p tok)) (n (length tok))) + (cond ((zerop n) nil) + ((and (every (lambda (c) (or (digit-char-p c) (find c "+-"))) tok) digits + (let ((v (ignore-errors (parse-integer tok)))) (and v (not (<= -1073741824 v 1073741823))))) + :bignum) + ((and (> n 1) (char= (char tok 0) #\#) (find (char-downcase (char tok 1)) "eixbod")) :prefix) + ((member tok '("+inf.0" "-inf.0" "+nan.0" "-nan.0") :test #'string=) :float) + ((and (char-equal (char tok (1- n)) #\i) (or digits (member tok '("+i" "-i") :test #'string=)) + (every (lambda (c) (or (digit-char-p c) (find (char-downcase c) "+-./eianf"))) tok)) + :complex) + ((and digits (every (lambda (c) (or (digit-char-p c) (find c "+-/"))) tok) (find #\/ tok) + (> (count-if #'digit-char-p tok) 1)) + :ratio) + ((and digits (every (lambda (c) (or (digit-char-p c) (find (char-downcase c) "+-.e"))) tok) + (or (find #\. tok) (find #\e tok)) (digit-char-p (char tok (if (find (char tok 0) "+-.") (min 1 (1- n)) 0)))) + :float) + ((and (> n 1) (char= (char tok 0) #\.) (digit-char-p (char tok 1))) :float)))) + +(defun skip-reason (skips section form heads) + (let ((toks (tokens form))) + (dolist (sn *skipped-names*) + (when (member (car sn) toks :test #'string=) + (return-from skip-reason (format nil "uses ~a, skipped: ~a" (car sn) (cdr sn)))))) + (dolist (e skips) + (destructuring-bind (kind what reason) e + (when (ecase kind + (:section (string= what section)) + (:head (or (string= what (form-head form)) (member what heads :test #'string=))) + (:match (search what form)) + (:nonlatin1 (some (lambda (c) (> (char-code c) 255)) form)) + (:literal (some (lambda (tk) (eq (literal-kind tk) (intern (string-upcase what) :keyword))) + (tokens form)))) + (return reason))))) + +(defun run-suite (dir) + "Run DIR/r7rs-tests.scm with DIR/shim.scm and DIR/skip.scm. Write DIR/results.txt." + (let* ((text (with-open-file (s (here (concatenate 'string dir "r7rs-tests.scm")) :external-format :utf-8) + (let ((str (make-string (file-length s)))) (subseq str 0 (read-sequence str s))))) + (forms (split-forms text)) + (skips (read-skips (here (concatenate 'string dir "skip.scm")))) + (section "") (pass 0) (fail 0) (skip 0) (setup-skipped 0) + (reasons (make-hash-table :test 'equal)) (failures '())) + (let ((*log* nil)) + (dolist (l (file-lines (concatenate 'string dir "shim.scm"))) (lisp-eval l))) + (dolist (form forms) + (let* ((head (form-head form)) (heads (nested-tests form)) (k (length heads))) + (when (string= head "test-begin") + (let ((q (position #\" form))) (when q (setf section (subseq form (1+ q) (position #\" form :start (1+ q))))))) + (let ((reason (skip-reason skips section form heads))) + (cond (reason + (when (zerop k) + (dolist (nm (defined-names form)) (push (cons nm reason) *skipped-names*))) + (if (zerop k) (incf setup-skipped) (incf skip k)) + (incf (gethash reason reasons 0) (max k 0))) + (t + (let* ((line (one-line form)) + (out (handler-case (lisp-eval line :timeout 60) + (error (e) (format nil "HOST ERROR ~a" e)))) + (p (count-substr "<<pass>>" out))) + (incf pass p) + (when (> k p) + (incf fail (- k p)) + (push (format nil "[~a] ~a~% => ~a" section + (subseq line 0 (min 160 (length line))) + (subseq out 0 (min 160 (length out)))) + failures)) + (when (search "HOST ERROR" out) + (let ((rest (reduce #'+ (mapcar (lambda (f) (length (nested-tests f))) + (cdr (member form forms)))))) + (incf fail rest) + (push (format nil "ABORTED: the chip stopped answering; ~d later tests counted as failed" rest) failures)) + (return)))))))) + (let ((total (+ pass fail skip))) + (with-open-file (o (here (concatenate 'string dir "results.txt")) :direction :output :if-exists :supersede) + (format o "r7rs suite: ~d passed, ~d failed, ~d skipped, ~d total~%" pass fail skip total) + (format o "setup forms skipped: ~d~%~%skipped tests by reason:~%" setup-skipped) + (maphash (lambda (r c) (format o " ~4d ~a~%" c r)) reasons) + (format o "~%failures:~%~{~a~%~}" (reverse failures))) + (format t "~&r7rs suite: ~d passed, ~d failed, ~d skipped, ~d total~%" pass fail skip total)))) + +(defun count-substr (sub s) + (loop with start = 0 for p = (search sub s :start2 start) while p count t do (setf start (1+ p)))) + +(defun analyze (path) + "Host only: list form heads and the longest one-line form." + (let* ((text (with-open-file (s path :external-format :utf-8) + (let ((str (make-string (file-length s)))) (subseq str 0 (read-sequence str s))))) + (forms (split-forms text)) (counts (make-hash-table :test 'equal)) (tests 0)) + (dolist (f forms) + (incf (gethash (form-head f) counts 0)) + (incf tests (length (nested-tests f)))) + (format t "~d top-level forms, ~d test calls, longest line ~d~%" (length forms) tests + (reduce #'max (mapcar (lambda (f) (length (one-line f))) forms))) + (maphash (lambda (h c) (format t " ~4d ~a~%" c h)) counts))) diff --git a/tests/r7rs/LICENSE b/tests/r7rs/LICENSE new file mode 100644 index 0000000..6290a58 --- /dev/null +++ b/tests/r7rs/LICENSE @@ -0,0 +1,29 @@ +This directory vendors tests/r7rs-tests.scm from chibi-scheme +https://github.com/ashinn/chibi-scheme/blob/master/tests/r7rs-tests.scm +(fetched 2026-10-04, unmodified). Its licence, chibi-scheme COPYING, follows. +shim.scm, skip.scm and results.txt are ours. + +Copyright (c) 2009-2021 Alex Shinn +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tests/r7rs/r7rs-tests.scm b/tests/r7rs/r7rs-tests.scm new file mode 100644 index 0000000..4e4615c --- /dev/null +++ b/tests/r7rs/r7rs-tests.scm @@ -0,0 +1,2523 @@ +;; -*- coding: utf-8 -*- + +(import (scheme base) (scheme char) (scheme lazy) + (scheme inexact) (scheme complex) (scheme time) + (scheme file) (scheme read) (scheme write) + (scheme eval) (scheme process-context) (scheme case-lambda) + (scheme r5rs) + (chibi test) ; or (srfi 64) + ) + +;; R7RS test suite. Covers all procedures and syntax in the small +;; language except `delete-file'. Currently assumes full-unicode +;; support, the full numeric tower and all standard libraries +;; provided. +;; +;; Uses the (chibi test) library which is written in portable R7RS. +;; This is mostly a subset of SRFI-64, providing test-begin, test-end +;; and test, which could be defined as something like: +;; +;; (define (test-begin . o) #f) +;; +;; (define (test-end . o) #f) +;; +;; (define-syntax test +;; (syntax-rules () +;; ((test expected expr) +;; (let ((res expr)) +;; (cond +;; ((not (equal? expr expected)) +;; (display "FAIL: ") +;; (write 'expr) +;; (display ": expected ") +;; (write expected) +;; (display " but got ") +;; (write res) +;; (newline))))))) +;; +;; however (chibi test) provides nicer output, timings, and +;; approximate equivalence for floating point numbers. + +(test-begin "R7RS") + +(test-begin "4.1 Primitive expression types") + +(let () + (define x 28) + (test 28 x)) + +(test 'a (quote a)) +(test #(a b c) (quote #(a b c))) +(test '(+ 1 2) (quote (+ 1 2))) + +(test 'a 'a) +(test #(a b c) '#(a b c)) +(test '() '()) +(test '(+ 1 2) '(+ 1 2)) +(test '(quote a) '(quote a)) +(test '(quote a) ''a) + +(test "abc" '"abc") +(test "abc" "abc") +(test 145932 '145932) +(test 145932 145932) +(test #t '#t) +(test #t #t) + +(test 7 (+ 3 4)) +(test 12 ((if #f + *) 3 4)) + +(test 8 ((lambda (x) (+ x x)) 4)) +(define reverse-subtract + (lambda (x y) (- y x))) +(test 3 (reverse-subtract 7 10)) +(define add4 + (let ((x 4)) + (lambda (y) (+ x y)))) +(test 10 (add4 6)) + +(test '(3 4 5 6) ((lambda x x) 3 4 5 6)) +(test '(5 6) ((lambda (x y . z) z) + 3 4 5 6)) + +(test 'yes (if (> 3 2) 'yes 'no)) +(test 'no (if (> 2 3) 'yes 'no)) +(test 1 (if (> 3 2) + (- 3 2) + (+ 3 2))) +(let () + (define x 2) + (test 3 (+ x 1))) + +(test-end) + +(test-begin "4.2 Derived expression types") + +(test 'greater + (cond ((> 3 2) 'greater) + ((< 3 2) 'less))) + +(test 'equal + (cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal))) + +(test 2 + (cond ((assv 'b '((a 1) (b 2))) => cadr) + (else #f))) + +(test 'composite + (case (* 2 3) + ((2 3 5 7) 'prime) + ((1 4 6 8 9) 'composite))) + +(test 'c + (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else => (lambda (x) x)))) + +(test '((other . z) (semivowel . y) (other . x) + (semivowel . w) (vowel . u)) + (map (lambda (x) + (case x + ((a e i o u) => (lambda (w) (cons 'vowel w))) + ((w y) (cons 'semivowel x)) + (else => (lambda (w) (cons 'other w))))) + '(z y x w u))) + +(test #t (and (= 2 2) (> 2 1))) +(test #f (and (= 2 2) (< 2 1))) +(test '(f g) (and 1 2 'c '(f g))) +(test #t (and)) + +(test #t (or (= 2 2) (> 2 1))) +(test #t (or (= 2 2) (< 2 1))) +(test #f (or #f #f #f)) +(test '(b c) (or (memq 'b '(a b c)) + (/ 3 0))) + +(test 6 (let ((x 2) (y 3)) + (* x y))) + +(test 35 (let ((x 2) (y 3)) + (let ((x 7) + (z (+ x y))) + (* z x)))) + +(test 70 (let ((x 2) (y 3)) + (let* ((x 7) + (z (+ x y))) + (* z x)))) + +(test #t + (letrec ((even? + (lambda (n) + (if (zero? n) + #t + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (zero? n) + #f + (even? (- n 1)))))) + (even? 88))) + +(test 5 + (letrec* ((p + (lambda (x) + (+ 1 (q (- x 1))))) + (q + (lambda (y) + (if (zero? y) + 0 + (+ 1 (p (- y 1)))))) + (x (p 5)) + (y x)) + y)) + +;; By Jussi Piitulainen <jpiitula@ling.helsinki.fi> +;; and John Cowan <cowan@mercury.ccil.org>: +;; http://lists.scheme-reports.org/pipermail/scheme-reports/2013-December/003876.html +(define (means ton) + (letrec* + ((mean + (lambda (f g) + (f (/ (sum g ton) n)))) + (sum + (lambda (g ton) + (if (null? ton) + (+) + (if (number? ton) + (g ton) + (+ (sum g (car ton)) + (sum g (cdr ton))))))) + (n (sum (lambda (x) 1) ton))) + (values (mean values values) + (mean exp log) + (mean / /)))) +(let*-values (((a b c) (means '(8 5 99 1 22)))) + (test 27 a) + (test 9.728 b) + (test 1800/497 c)) + +(let*-values (((root rem) (exact-integer-sqrt 32))) + (test 35 (* root rem))) + +(test '(1073741824 0) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 60)))) + (list root rem))) + +(test '(1518500249 3000631951) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 61)))) + (list root rem))) + +(test '(815238614083298888 443242361398135744) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 119)))) + (list root rem))) + +(test '(1152921504606846976 0) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 120)))) + (list root rem))) + +(test '(1630477228166597776 1772969445592542976) + (let*-values (((root rem) (exact-integer-sqrt (expt 2 121)))) + (list root rem))) + +(test '(31622776601683793319 62545769258890964239) + (let*-values (((root rem) (exact-integer-sqrt (expt 10 39)))) + (list root rem))) + +(let*-values (((root rem) (exact-integer-sqrt (expt 2 140)))) + (test 0 rem) + (test (expt 2 140) (square root))) + +(test '(x y x y) (let ((a 'a) (b 'b) (x 'x) (y 'y)) + (let*-values (((a b) (values x y)) + ((x y) (values a b))) + (list a b x y)))) + +(test 'ok (let-values () 'ok)) + +(test 1 (let ((x 1)) + (let*-values () + (define x 2) + #f) + x)) + +(let () + (define x 0) + (set! x 5) + (test 6 (+ x 1))) + +(test #(0 1 2 3 4) (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) + +(test 25 (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum)))) + +(test '((6 1 3) (-5 -2)) + (let loop ((numbers '(3 -2 1 6 -5)) + (nonneg '()) + (neg '())) + (cond ((null? numbers) (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) + (cons (car numbers) nonneg) + neg)) + ((< (car numbers) 0) + (loop (cdr numbers) + nonneg + (cons (car numbers) neg)))))) + +(test 3 (force (delay (+ 1 2)))) + +(test '(3 3) + (let ((p (delay (+ 1 2)))) + (list (force p) (force p)))) + +(define integers + (letrec ((next + (lambda (n) + (delay (cons n (next (+ n 1))))))) + (next 0))) +(define head + (lambda (stream) (car (force stream)))) +(define tail + (lambda (stream) (cdr (force stream)))) + +(test 2 (head (tail (tail integers)))) + +(define (stream-filter p? s) + (delay-force + (if (null? (force s)) + (delay '()) + (let ((h (car (force s))) + (t (cdr (force s)))) + (if (p? h) + (delay (cons h (stream-filter p? t))) + (stream-filter p? t)))))) + +(test 5 (head (tail (tail (stream-filter odd? integers))))) + +(let () + (define x 5) + (define count 0) + (define p + (delay (begin (set! count (+ count 1)) + (if (> count x) + count + (force p))))) + (test 6 (force p)) + (test 6 (begin (set! x 10) (force p)))) + +(test #t (promise? (delay (+ 2 2)))) +(test #t (promise? (make-promise (+ 2 2)))) +(test #t + (let ((x (delay (+ 2 2)))) + (force x) + (promise? x))) +(test #t + (let ((x (make-promise (+ 2 2)))) + (force x) + (promise? x))) +(test 4 (force (make-promise (+ 2 2)))) +(test 4 (force (make-promise (make-promise (+ 2 2))))) + +(define radix + (make-parameter + 10 + (lambda (x) + (if (and (integer? x) (<= 2 x 16)) + x + (error "invalid radix"))))) +(define (f n) (number->string n (radix))) +(test "12" (f 12)) +(test "1100" (parameterize ((radix 2)) + (f 12))) +(test "12" (f 12)) + +(test '(list 3 4) `(list ,(+ 1 2) 4)) +(let ((name 'a)) (test '(list a (quote a)) `(list ,name ',name))) +(test '(a 3 4 5 6 b) `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) +(test #(10 5 4 16 9 8) + `#(10 5 ,(square 2) ,@(map square '(4 3)) 8)) +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) ) +(let ((name1 'x) + (name2 'y)) + (test '(a `(b ,x ,'y d) e) `(a `(b ,,name1 ,',name2 d) e))) +(test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) ) +(test `(list ,(+ 1 2) 4) (quasiquote (list (unquote (+ 1 2)) 4))) + +(define any-arity + (case-lambda + (() 'zero) + ((x) x) + ((x y) (cons x y)) + ((x y z) (list x y z)) + (args (cons 'many args)))) + +(test 'zero (any-arity)) +(test 1 (any-arity 1)) +(test '(1 . 2) (any-arity 1 2)) +(test '(1 2 3) (any-arity 1 2 3)) +(test '(many 1 2 3 4) (any-arity 1 2 3 4)) + +(define rest-arity + (case-lambda + (() '(zero)) + ((x) (list 'one x)) + ((x y) (list 'two x y)) + ((x y . z) (list 'more x y z)))) + +(test '(zero) (rest-arity)) +(test '(one 1) (rest-arity 1)) +(test '(two 1 2) (rest-arity 1 2)) +(test '(more 1 2 (3)) (rest-arity 1 2 3)) + +(define dead-clause + (case-lambda + ((x . y) 'many) + (() 'none) + (foo 'unreachable))) + +(test 'none (dead-clause)) +(test 'many (dead-clause 1)) +(test 'many (dead-clause 1 2)) +(test 'many (dead-clause 1 2 3)) + +(test-end) + +(test-begin "4.3 Macros") + +(test 'now (let-syntax + ((when (syntax-rules () + ((when test stmt1 stmt2 ...) + (if test + (begin stmt1 + stmt2 ...)))))) + (let ((if #t)) + (when if (set! if 'now)) + if))) + +(test 'outer (let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (let ((x 'inner)) + (m))))) + +(test 7 (letrec-syntax + ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) + (if temp + temp + (my-or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (my-or x + (let temp) + (if y) + y)))) + +(define-syntax be-like-begin1 + (syntax-rules () + ((be-like-begin1 name) + (define-syntax name + (syntax-rules () + ((name expr (... ...)) + (begin expr (... ...)))))))) +(be-like-begin1 sequence1) +(test 3 (sequence1 0 1 2 3)) + +(define-syntax be-like-begin2 + (syntax-rules () + ((be-like-begin2 name) + (define-syntax name + (... (syntax-rules () + ((name expr ...) + (begin expr ...)))))))) +(be-like-begin2 sequence2) +(test 4 (sequence2 1 2 3 4)) + +(define-syntax be-like-begin3 + (syntax-rules () + ((be-like-begin3 name) + (define-syntax name + (syntax-rules dots () + ((name expr dots) + (begin expr dots))))))) +(be-like-begin3 sequence3) +(test 5 (sequence3 2 3 4 5)) + +;; ellipsis escape +(define-syntax elli-esc-1 + (syntax-rules () + ((_) + '(... ...)) + ((_ x) + '(... (x ...))) + ((_ x y) + '(... (... x y))))) + +(test '... (elli-esc-1)) +(test '(100 ...) (elli-esc-1 100)) +(test '(... 100 200) (elli-esc-1 100 200)) + +;; Syntax pattern with ellipsis in middle of proper list. +(define-syntax part-2 + (syntax-rules () + ((_ a b (m n) ... x y) + (vector (list a b) (list m ...) (list n ...) (list x y))) + ((_ . rest) 'error))) +(test '#((10 43) (31 41 51) (32 42 52) (63 77)) + (part-2 10 (+ 21 22) (31 32) (41 42) (51 52) (+ 61 2) 77)) +;; Syntax pattern with ellipsis in middle of improper list. +(define-syntax part-2x + (syntax-rules () + ((_ (a b (m n) ... x y . rest)) + (vector (list a b) (list m ...) (list n ...) (list x y) + (cons "rest:" 'rest))) + ((_ . rest) 'error))) +(test '#((10 43) (31 41 51) (32 42 52) (63 77) ("rest:")) + (part-2x (10 (+ 21 22) (31 32) (41 42) (51 52) (+ 61 2) 77))) +(test '#((10 43) (31 41 51) (32 42 52) (63 77) ("rest:" . "tail")) + (part-2x (10 (+ 21 22) (31 32) (41 42) (51 52) (+ 61 2) 77 . "tail"))) + +;; underscore +(define-syntax underscore + (syntax-rules () + ((foo _) '_))) +(test '_ (underscore foo)) + +(let () + (define-syntax underscore2 + (syntax-rules () + ((underscore2 (a _) ...) 42))) + (test 42 (underscore2 (1 2)))) + +(define-syntax count-to-2 + (syntax-rules () + ((_) 0) + ((_ _) 1) + ((_ _ _) 2) + ((_ . _) 'many))) +(test '(2 0 many) + (list (count-to-2 a b) (count-to-2) (count-to-2 a b c d))) + +(define-syntax count-to-2_ + (syntax-rules (_) + ((_) 0) + ((_ _) 1) + ((_ _ _) 2) + ((x . y) 'fail))) +(test '(2 0 fail fail) + (list (count-to-2_ _ _) (count-to-2_) + (count-to-2_ a b) (count-to-2_ a b c d))) + +(define-syntax jabberwocky + (syntax-rules () + ((_ hatter) + (begin + (define march-hare 42) + (define-syntax hatter + (syntax-rules () + ((_) march-hare))))))) +(jabberwocky mad-hatter) +(test 42 (mad-hatter)) + +(test 'ok (let ((=> #f)) (cond (#t => 'ok)))) + +(let () + (define x 1) + (let-syntax () + (define x 2) + #f) + (test 1 x)) + +(let () + (define-syntax foo + (syntax-rules () + ((foo bar y) + (define-syntax bar + (syntax-rules () + ((bar x) 'y)))))) + (foo bar x) + (test 'x (bar 1))) + +(begin + (define-syntax ffoo + (syntax-rules () + ((ffoo ff) + (begin + (define (ff x) + (gg x)) + (define (gg x) + (* x x)))))) + (ffoo ff) + (test 100 (ff 10))) + +(let-syntax ((vector-lit + (syntax-rules () + ((vector-lit) + '#(b))))) + (test '#(b) (vector-lit))) + +(let () + ;; forward hygienic refs + (define-syntax foo399 + (syntax-rules () ((foo399) (bar399)))) + (define (quux399) + (foo399)) + (define (bar399) + 42) + (test 42 (quux399))) + +(let-syntax + ((m (syntax-rules () + ((m x) (let-syntax + ((n (syntax-rules (k) + ((n x) 'bound-identifier=?) + ((n y) 'free-identifier=?)))) + (n z)))))) + (test 'bound-identifier=? (m k))) + +;; literal has priority to ellipsis (R7RS 4.3.2) +(let () + (define-syntax elli-lit-1 + (syntax-rules ... (...) + ((_ x) + '(x ...)))) + (test '(100 ...) (elli-lit-1 100))) + +;; bad ellipsis +#| +(test 'error + (guard (exn (else 'error)) + (eval + '(define-syntax bad-elli-1 + (syntax-rules () + ((_ ... x) + '(... x)))) + (interaction-environment)))) + +(test 'error + (guard (exn (else 'error)) + (eval + '(define-syntax bad-elli-2 + (syntax-rules () + ((_ (... x)) + '(... x)))) + (interaction-environment)))) +|# + +(test-end) + +(test-begin "5 Program structure") + +(define add3 + (lambda (x) (+ x 3))) +(test 6 (add3 3)) +(define first car) +(test 1 (first '(1 2))) + +(test 45 (let ((x 5)) + (define foo (lambda (y) (bar x y))) + (define bar (lambda (a b) (+ (* a b) a))) + (foo (+ x 3)))) + +(test 'ok + (let () + (define-values () (values)) + 'ok)) +(test 1 + (let () + (define-values (x) (values 1)) + x)) +(test 3 + (let () + (define-values x (values 1 2)) + (apply + x))) +(test 3 + (let () + (define-values (x y) (values 1 2)) + (+ x y))) +(test 6 + (let () + (define-values (x y z) (values 1 2 3)) + (+ x y z))) +(test 10 + (let () + (define-values (x y . z) (values 1 2 3 4)) + (+ x y (car z) (cadr z)))) + +(test '(2 1) (let ((x 1) (y 2)) + (define-syntax swap! + (syntax-rules () + ((swap! a b) + (let ((tmp a)) + (set! a b) + (set! b tmp))))) + (swap! x y) + (list x y))) + +;; Records + +(define-record-type <pare> + (kons x y) + pare? + (x kar set-kar!) + (y kdr)) + +(test #t (pare? (kons 1 2))) +(test #f (pare? (cons 1 2))) +(test 1 (kar (kons 1 2))) +(test 2 (kdr (kons 1 2))) +(test 3 (let ((k (kons 1 2))) + (set-kar! k 3) + (kar k))) + +(test-end) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 6 Standard Procedures + +(test-begin "6.1 Equivalence Predicates") + +(test #t (eqv? 'a 'a)) +(test #f (eqv? 'a 'b)) +(test #t (eqv? 2 2)) +(test #t (eqv? '() '())) +(test #t (eqv? 100000000 100000000)) +(test #f (eqv? (cons 1 2) (cons 1 2))) +(test #f (eqv? (lambda () 1) + (lambda () 2))) +(test #f (eqv? #f 'nil)) + +(define gen-counter + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) n)))) +(test #t + (let ((g (gen-counter))) + (eqv? g g))) +(test #f (eqv? (gen-counter) (gen-counter))) +(define gen-loser + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) 27)))) +(test #t (let ((g (gen-loser))) + (eqv? g g))) + +(test #f +(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) + (g (lambda () (if (eqv? f g) 'g 'both)))) + (eqv? f g))) + +(test #t + (let ((x '(a))) + (eqv? x x))) + +(test #t (eq? 'a 'a)) +(test #f (eq? (list 'a) (list 'a))) +(test #t (eq? '() '())) +(test #t + (let ((x '(a))) + (eq? x x))) +(test #t + (let ((x '#())) + (eq? x x))) +(test #t + (let ((p (lambda (x) x))) + (eq? p p))) + +(test #t (equal? 'a 'a)) +(test #t (equal? '(a) '(a))) +(test #t (equal? '(a (b) c) + '(a (b) c))) +(test #t (equal? "abc" "abc")) +(test #t (equal? 2 2)) +(test #t (equal? (make-vector 5 'a) + (make-vector 5 'a))) + +(test-end) + +(test-begin "6.2 Numbers") + +(test #t (complex? 3+4i)) +(test #t (complex? 3)) +(test #t (real? 3)) +(test #t (real? -2.5+0i)) +(test #f (real? -2.5+0.0i)) +(test #t (real? #e1e10)) +(test #t (real? +inf.0)) +(test #f (rational? -inf.0)) +(test #f (rational? +nan.0)) +(test #t (rational? 9007199254740991.0)) +(test #t (rational? 9007199254740992.0)) +(test #t (rational? 1.7976931348623157e308)) +(test #t (rational? 6/10)) +(test #t (rational? 6/3)) +(test #t (integer? 3+0i)) +(test #t (integer? 3.0)) +(test #t (integer? 8/4)) + +(test #f (exact? 3.0)) +(test #t (exact? #e3.0)) +(test #t (inexact? 3.)) + +(test #t (exact-integer? 32)) +(test #f (exact-integer? 32.0)) +(test #f (exact-integer? 32/5)) + +(test #t (finite? 3)) +(test #f (finite? +inf.0)) +(test #f (finite? 3.0+inf.0i)) + +(test #f (infinite? 3)) +(test #t (infinite? +inf.0)) +(test #f (infinite? +nan.0)) +(test #t (infinite? 3.0+inf.0i)) + +(test #t (nan? +nan.0)) +(test #f (nan? 32)) +(test #t (nan? +nan.0+5.0i)) +(test #t (nan? 1.0+nan.0i)) +(test #t (nan? +nan.0i)) +(test #t (nan? +nan.0+nan.0i)) +(test #t (nan? +nan.0+inf.0i)) +(test #t (nan? +inf.0+nan.0i)) +(test #f (nan? 1+2i)) + +(test #t (= 1 1.0 1.0+0.0i)) +(test #f (= 1.0 1.0+1.0i)) +(test #t (< 1 2 3)) +(test #f (< 1 1 2)) +(test #t (> 3.0 2.0 1.0)) +(test #f (> -3.0 2.0 1.0)) +(test #t (<= 1 1 2)) +(test #f (<= 1 2 1)) +(test #t (>= 2 1 1)) +(test #f (>= 1 2 1)) +(test #f (< +nan.0 0)) +(test #f (> +nan.0 0)) +(test #f (< +nan.0 0.0)) +(test #f (> +nan.0 0.0)) +(test '(#t #f) (list (<= 1 1 2) (<= 2 1 3))) +(test #f (= 9007199254740992.0 9007199254740993)) + +;; From R7RS 6.2.6 Numerical operations: +;; +;; These predicates are required to be transitive. +;; +;; _Note:_ The traditional implementations of these predicates in +;; Lisp-like languages, which involve converting all arguments to inexact +;; numbers if any argument is inexact, are not transitive. + +;; Example from Alan Bawden +(let ((a (- (expt 2 1000) 1)) + (b (inexact (expt 2 1000))) ; assuming > single-float-epsilon + (c (+ (expt 2 1000) 1))) + (test #t (if (and (= a b) (= b c)) + (= a c) + #t))) + +;; From CLtL 12.3. Comparisons on Numbers: +;; +;; Let _a_ be the result of (/ 10.0 single-float-epsilon), and let +;; _j_ be the result of (floor a). ..., all of (<= a j), (< j (+ j +;; 1)), and (<= (+ j 1) a) would be true; transitivity would then +;; imply that (< a a) ought to be true ... + +;; Transliteration from Jussi Piitulainen +(define single-float-epsilon + (do ((eps 1.0 (* eps 2.0))) + ((= eps (+ eps 1.0)) eps))) + +(let* ((a (/ 10.0 single-float-epsilon)) + (j (exact a))) + (test #t (if (and (<= a j) (< j (+ j 1))) + (not (<= (+ j 1) a)) + #t))) + +(test #t (zero? 0)) +(test #t (zero? 0.0)) +(test #t (zero? 0.0+0.0i)) +(test #f (zero? 1)) +(test #f (zero? -1)) + +(test #f (positive? 0)) +(test #f (positive? 0.0)) +(test #t (positive? 1)) +(test #t (positive? 1.0)) +(test #f (positive? -1)) +(test #f (positive? -1.0)) +(test #t (positive? +inf.0)) +(test #f (positive? -inf.0)) +(test #f (positive? +nan.0)) + +(test #f (negative? 0)) +(test #f (negative? 0.0)) +(test #f (negative? 1)) +(test #f (negative? 1.0)) +(test #t (negative? -1)) +(test #t (negative? -1.0)) +(test #f (negative? +inf.0)) +(test #t (negative? -inf.0)) +(test #f (negative? +nan.0)) + +(test #f (odd? 0)) +(test #t (odd? 1)) +(test #t (odd? -1)) +(test #f (odd? 102)) + +(test #t (even? 0)) +(test #f (even? 1)) +(test #t (even? -2)) +(test #t (even? 102)) + +(test 3 (max 3)) +(test 4 (max 3 4)) +(test 4.0 (max 3.9 4)) +(test 5.0 (max 5 3.9 4)) +(test +inf.0 (max 100 +inf.0)) +(test 3 (min 3)) +(test 3 (min 3 4)) +(test 3.0 (min 3 3.1)) +(test -inf.0 (min -inf.0 -100)) + +(test 7 (+ 3 4)) +(test 3 (+ 3)) +(test 0 (+)) +(test 4 (* 4)) +(test 1 (*)) + +(test -1 (- 3 4)) +(test -6 (- 3 4 5)) +(test -3 (- 3)) +(test -3/2 (- 3/2)) +(test -3/2-i (- 3/2+i)) +(test 3/20 (/ 3 4 5)) +(test 1/3 (/ 3)) + +(test 1073741824 (/ -1073741824 -1)) +(test 1073741824 (quotient -1073741824 -1)) +(test 0 (remainder -1073741824 -1)) +(test 4611686018427387904 (/ -4611686018427387904 -1)) +(test 4611686018427387904 (quotient -4611686018427387904 -1)) +(test 0 (remainder -4611686018427387904 -1)) + +(test 7 (abs -7)) +(test 7 (abs 7)) + +(test-values (values 2 1) (floor/ 5 2)) +(test-values (values -3 1) (floor/ -5 2)) +(test-values (values -3 -1) (floor/ 5 -2)) +(test-values (values 2 -1) (floor/ -5 -2)) +(test-values (values 2 1) (truncate/ 5 2)) +(test-values (values -2 -1) (truncate/ -5 2)) +(test-values (values -2 1) (truncate/ 5 -2)) +(test-values (values 2 -1) (truncate/ -5 -2)) +(test-values (values 2.0 -1.0) (truncate/ -5.0 -2)) + +(test 1 (modulo 13 4)) +(test 1 (remainder 13 4)) + +(test 3 (modulo -13 4)) +(test -1 (remainder -13 4)) + +(test -3 (modulo 13 -4)) +(test 1 (remainder 13 -4)) + +(test -1 (modulo -13 -4)) +(test -1 (remainder -13 -4)) + +(test -1.0 (remainder -13 -4.0)) + +(test 4 (gcd 32 -36)) +(test 0 (gcd)) +(test 288 (lcm 32 -36)) +(test 288.0 (lcm 32.0 -36)) +(test 1 (lcm)) + +(test 3 (numerator (/ 6 4))) +(test 2 (denominator (/ 6 4))) +(test 2.0 (denominator (inexact (/ 6 4)))) +(test 11.0 (numerator 5.5)) +(test 2.0 (denominator 5.5)) +(test 5.0 (numerator 5.0)) +(test 1.0 (denominator 5.0)) + +(test -5.0 (floor -4.3)) +(test -4.0 (ceiling -4.3)) +(test -4.0 (truncate -4.3)) +(test -4.0 (round -4.3)) + +(test 3.0 (floor 3.5)) +(test 4.0 (ceiling 3.5)) +(test 3.0 (truncate 3.5)) +(test 4.0 (round 3.5)) + +(test 4 (round 7/2)) +(test 7 (round 7)) +(test 1 (round 7/10)) +(test -4 (round -7/2)) +(test -7 (round -7)) +(test -1 (round -7/10)) + +(test 1/3 (rationalize (exact .3) 1/10)) +(test #i1/3 (rationalize .3 1/10)) + +(test 1.0 (inexact (exp 0))) ;; may return exact number +(test 20.0855369231877 (exp 3)) + +(test 0.0 (inexact (log 1))) ;; may return exact number +(test 1.0 (log (exp 1))) +(test 42.0 (log (exp 42))) +(test 2.0 (log 100 10)) +(test 12.0 (log 4096 2)) + +(test 0.0 (inexact (sin 0))) ;; may return exact number +(test 1.0 (sin 1.5707963267949)) +(test 1.0 (inexact (cos 0))) ;; may return exact number +(test -1.0 (cos 3.14159265358979)) +(test 0.0 (inexact (tan 0))) ;; may return exact number +(test 1.5574077246549 (tan 1)) + +(test 0.0 (inexact (asin 0))) ;; may return exact number +(test 1.5707963267949 (asin 1)) +(test 0.0 (inexact (acos 1))) ;; may return exact number +(test 3.14159265358979 (acos -1)) + +;; (test 0.0-0.0i (asin 0+0.0i)) +;; (test 1.5707963267948966+0.0i (acos 0+0.0i)) + +(test 0.0 (atan 0.0 1.0)) +(test -0.0 (atan -0.0 1.0)) +(test 0.785398163397448 (atan 1.0 1.0)) +(test 1.5707963267949 (atan 1.0 0.0)) +(test 2.35619449019234 (atan 1.0 -1.0)) +(test 3.14159265358979 (atan 0.0 -1.0)) +(test -3.14159265358979 (atan -0.0 -1.0)) ; +(test -2.35619449019234 (atan -1.0 -1.0)) +(test -1.5707963267949 (atan -1.0 0.0)) +(test -0.785398163397448 (atan -1.0 1.0)) +;; (test undefined (atan 0.0 0.0)) + +(test 1764 (square 42)) +(test 4 (square 2)) + +(test 3.0 (inexact (sqrt 9))) +(test 1.4142135623731 (sqrt 2)) +(test 0.0+1.0i (inexact (sqrt -1))) +(test 0.0+1.0i (sqrt -1.0-0.0i)) + +(test '(2 0) (call-with-values (lambda () (exact-integer-sqrt 4)) list)) +(test '(2 1) (call-with-values (lambda () (exact-integer-sqrt 5)) list)) + +(test 27 (expt 3 3)) +(test 1 (expt 0 0)) +(test 0 (expt 0 1)) +(test 1.0 (expt 0.0 0)) +(test 0.0 (expt 0 1.0)) +(test 1/1024 (expt 2 -10)) +(test 1/1180591620717411303424 (expt 2 -70)) + +(test 1+2i (make-rectangular 1 2)) + +(test 0.54030230586814+0.841470984807897i (make-polar 1 1)) + +(test 1 (real-part 1+2i)) + +(test 2 (imag-part 1+2i)) + +(test 2.23606797749979 (magnitude 1+2i)) + +(test 1.10714871779409 (angle 1+2i)) + +(test 1.0 (inexact 1)) +(test #t (inexact? (inexact 1))) +(test 1 (exact 1.0)) +(test #t (exact? (exact 1.0))) + +(test 100 (string->number "100")) +(test 256 (string->number "100" 16)) +(test 100.0 (string->number "1e2")) +(test #f (string->number "1 2")) + +(test-end) + +(test-begin "6.3 Booleans") + +(test #t #t) +(test #f #f) +(test #f '#f) + +(test #f (not #t)) +(test #f (not 3)) +(test #f (not (list 3))) +(test #t (not #f)) +(test #f (not '())) +(test #f (not (list))) +(test #f (not 'nil)) + +(test #t (boolean? #f)) +(test #f (boolean? 0)) +(test #f (boolean? '())) + +(test #t (boolean=? #t #t)) +(test #t (boolean=? #f #f)) +(test #f (boolean=? #t #f)) +(test #t (boolean=? #f #f #f)) +(test #f (boolean=? #t #t #f)) + +(test-end) + +(test-begin "6.4 Lists") + +(let* ((x (list 'a 'b 'c)) + (y x)) + (test '(a b c) (values y)) + (test #t (list? y)) + (set-cdr! x 4) + (test '(a . 4) (values x)) + (test #t (eqv? x y)) + (test #f (list? y)) + (set-cdr! x x) + (test #f (list? x))) + +(test #t (pair? '(a . b))) +(test #t (pair? '(a b c))) +(test #f (pair? '())) +(test #f (pair? '#(a b))) + +(test '(a) (cons 'a '())) +(test '((a) b c d) (cons '(a) '(b c d))) +(test '("a" b c) (cons "a" '(b c))) +(test '(a . 3) (cons 'a 3)) +(test '((a b) . c) (cons '(a b) 'c)) + +(test 'a (car '(a b c))) +(test '(a) (car '((a) b c d))) +(test 1 (car '(1 . 2))) + +(test '(b c d) (cdr '((a) b c d))) +(test 2 (cdr '(1 . 2))) +(define (g) '(constant-list)) + +(test #t (list? '(a b c))) +(test #t (list? '())) +(test #f (list? '(a . b))) +(test #f (let ((x (list 'a))) (set-cdr! x x) (list? x))) + +(test '(3 3) (make-list 2 3)) + +(test '(a 7 c) (list 'a (+ 3 4) 'c)) +(test '() (list)) + +(test 3 (length '(a b c))) +(test 3 (length '(a (b) (c d e)))) +(test 0 (length '())) + +(test '(x y) (append '(x) '(y))) +(test '(a b c d) (append '(a) '(b c d))) +(test '(a (b) (c)) (append '(a (b)) '((c)))) + +(test '(a b c . d) (append '(a b) '(c . d))) +(test 'a (append '() 'a)) + +(test '(c b a) (reverse '(a b c))) +(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) + +(test '(d e) (list-tail '(a b c d e) 3)) + +(test 'c (list-ref '(a b c d) 2)) +(test 'c (list-ref '(a b c d) + (exact (round 1.8)))) + +(test '(0 ("Sue" "Sue") "Anna") + (let ((lst (list 0 '(2 2 2 2) "Anna"))) + (list-set! lst 1 '("Sue" "Sue")) + lst)) + +(test '(a b c) (memq 'a '(a b c))) +(test '(b c) (memq 'b '(a b c))) +(test #f (memq 'a '(b c d))) +(test #f (memq (list 'a) '(b (a) c))) +(test '((a) c) (member (list 'a) '(b (a) c))) +(test '("b" "c") (member "B" '("a" "b" "c") string-ci=?)) +(test '(101 102) (memv 101 '(100 101 102))) + +(let () + (define e '((a 1) (b 2) (c 3))) + (test '(a 1) (assq 'a e)) + (test '(b 2) (assq 'b e)) + (test #f (assq 'd e))) + +(test #f (assq (list 'a) '(((a)) ((b)) ((c))))) +(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) +(test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =)) +(test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) + +(test '(1 2 3) (list-copy '(1 2 3))) +(test "foo" (list-copy "foo")) +(test '() (list-copy '())) +(test '(3 . 4) (list-copy '(3 . 4))) +(test '(6 7 8 . 9) (list-copy '(6 7 8 . 9))) +(let* ((l1 '((a b) (c d) e)) + (l2 (list-copy l1))) + (test l2 '((a b) (c d) e)) + (test #t (eq? (car l1) (car l2))) + (test #t (eq? (cadr l1) (cadr l2))) + (test #f (eq? (cdr l1) (cdr l2))) + (test #f (eq? (cddr l1) (cddr l2)))) + +(test-end) + +(test-begin "6.5 Symbols") + +(test #t (symbol? 'foo)) +(test #t (symbol? (car '(a b)))) +(test #f (symbol? "bar")) +(test #t (symbol? 'nil)) +(test #f (symbol? '())) +(test #f (symbol? #f)) + +(test #t (symbol=? 'a 'a)) +(test #f (symbol=? 'a 'A)) +(test #t (symbol=? 'a 'a 'a)) +(test #f (symbol=? 'a 'a 'A)) + +(test "flying-fish" +(symbol->string 'flying-fish)) +(test "Martin" (symbol->string 'Martin)) +(test "Malvina" (symbol->string (string->symbol "Malvina"))) + +(test 'mISSISSIppi (string->symbol "mISSISSIppi")) +(test #t (eq? 'bitBlt (string->symbol "bitBlt"))) +(test #t (eq? 'LollyPop (string->symbol (symbol->string 'LollyPop)))) +(test #t (string=? "K. Harper, M.D." + (symbol->string (string->symbol "K. Harper, M.D.")))) + +(test-end) + +(test-begin "6.6 Characters") + +(test #t (char? #\a)) +(test #f (char? "a")) +(test #f (char? 'a)) +(test #f (char? 0)) + +(test #t (char=? #\a #\a #\a)) +(test #f (char=? #\a #\A)) +(test #t (char<? #\a #\b #\c)) +(test #f (char<? #\a #\a)) +(test #f (char<? #\b #\a)) +(test #f (char>? #\a #\b)) +(test #f (char>? #\a #\a)) +(test #t (char>? #\c #\b #\a)) +(test #t (char<=? #\a #\b #\b)) +(test #t (char<=? #\a #\a)) +(test #f (char<=? #\b #\a)) +(test #f (char>=? #\a #\b)) +(test #t (char>=? #\a #\a)) +(test #t (char>=? #\b #\b #\a)) + +(test #t (char-ci=? #\a #\a)) +(test #t (char-ci=? #\a #\A #\a)) +(test #f (char-ci=? #\a #\b)) +(test #t (char-ci<? #\a #\B #\c)) +(test #f (char-ci<? #\A #\a)) +(test #f (char-ci<? #\b #\A)) +(test #f (char-ci>? #\A #\b)) +(test #f (char-ci>? #\a #\A)) +(test #t (char-ci>? #\c #\B #\a)) +(test #t (char-ci<=? #\a #\B #\b)) +(test #t (char-ci<=? #\A #\a)) +(test #f (char-ci<=? #\b #\A)) +(test #f (char-ci>=? #\A #\b)) +(test #t (char-ci>=? #\a #\A)) +(test #t (char-ci>=? #\b #\B #\a)) + +(test #t (char-alphabetic? #\a)) +(test #f (char-alphabetic? #\space)) +(test #t (char-numeric? #\0)) +(test #f (char-numeric? #\.)) +(test #f (char-numeric? #\a)) +(test #t (char-whitespace? #\space)) +(test #t (char-whitespace? #\tab)) +(test #t (char-whitespace? #\newline)) +(test #f (char-whitespace? #\_)) +(test #f (char-whitespace? #\a)) +(test #t (char-upper-case? #\A)) +(test #f (char-upper-case? #\a)) +(test #f (char-upper-case? #\3)) +(test #t (char-lower-case? #\a)) +(test #f (char-lower-case? #\A)) +(test #f (char-lower-case? #\3)) + +(test #t (char-alphabetic? #\Λ)) +(test #f (char-alphabetic? #\x0E50)) +(test #t (char-upper-case? #\Λ)) +(test #f (char-upper-case? #\λ)) +(test #f (char-lower-case? #\Λ)) +(test #t (char-lower-case? #\λ)) +(test #f (char-numeric? #\Λ)) +(test #t (char-numeric? #\x0E50)) +(test #t (char-whitespace? #\x1680)) + +(test 0 (digit-value #\0)) +(test 3 (digit-value #\3)) +(test 9 (digit-value #\9)) +(test 4 (digit-value #\x0664)) +(test 0 (digit-value #\x0AE6)) +(test #f (digit-value #\.)) +(test #f (digit-value #\-)) + +(test 97 (char->integer #\a)) +(test #\a (integer->char 97)) + +(test #\A (char-upcase #\a)) +(test #\A (char-upcase #\A)) +(test #\a (char-downcase #\a)) +(test #\a (char-downcase #\A)) +(test #\a (char-foldcase #\a)) +(test #\a (char-foldcase #\A)) + +(test #\Λ (char-upcase #\λ)) +(test #\Λ (char-upcase #\Λ)) +(test #\λ (char-downcase #\λ)) +(test #\λ (char-downcase #\Λ)) +(test #\λ (char-foldcase #\λ)) +(test #\λ (char-foldcase #\Λ)) + +(test-end) + +(test-begin "6.7 Strings") + +(test #t (string? "")) +(test #t (string? " ")) +(test #f (string? 'a)) +(test #f (string? #\a)) + +(test 3 (string-length (make-string 3))) +(test "---" (make-string 3 #\-)) + +(test "" (string)) +(test "---" (string #\- #\- #\-)) +(test "kitten" (string #\k #\i #\t #\t #\e #\n)) + +(test 0 (string-length "")) +(test 1 (string-length "a")) +(test 3 (string-length "abc")) + +(test #\a (string-ref "abc" 0)) +(test #\b (string-ref "abc" 1)) +(test #\c (string-ref "abc" 2)) + +(test "a-c" (let ((str (string #\a #\b #\c))) (string-set! str 1 #\-) str)) + +(test (string #\a #\x1F700 #\c) + (let ((s (string #\a #\b #\c))) + (string-set! s 1 #\x1F700) + s)) + +(test #t (string=? "" "")) +(test #t (string=? "abc" "abc" "abc")) +(test #f (string=? "" "abc")) +(test #f (string=? "abc" "aBc")) + +(test #f (string<? "" "")) +(test #f (string<? "abc" "abc")) +(test #t (string<? "abc" "abcd" "acd")) +(test #f (string<? "abcd" "abc")) +(test #t (string<? "abc" "bbc")) + +(test #f (string>? "" "")) +(test #f (string>? "abc" "abc")) +(test #f (string>? "abc" "abcd")) +(test #t (string>? "acd" "abcd" "abc")) +(test #f (string>? "abc" "bbc")) + +(test #t (string<=? "" "")) +(test #t (string<=? "abc" "abc")) +(test #t (string<=? "abc" "abcd" "abcd")) +(test #f (string<=? "abcd" "abc")) +(test #t (string<=? "abc" "bbc")) + +(test #t (string>=? "" "")) +(test #t (string>=? "abc" "abc")) +(test #f (string>=? "abc" "abcd")) +(test #t (string>=? "abcd" "abcd" "abc")) +(test #f (string>=? "abc" "bbc")) + +(test #t (string-ci=? "" "")) +(test #t (string-ci=? "abc" "abc")) +(test #f (string-ci=? "" "abc")) +(test #t (string-ci=? "abc" "aBc")) +(test #f (string-ci=? "abc" "aBcD")) + +(test #f (string-ci<? "abc" "aBc")) +(test #t (string-ci<? "abc" "aBcD")) +(test #f (string-ci<? "ABCd" "aBc")) + +(test #f (string-ci>? "abc" "aBc")) +(test #f (string-ci>? "abc" "aBcD")) +(test #t (string-ci>? "ABCd" "aBc")) + +(test #t (string-ci<=? "abc" "aBc")) +(test #t (string-ci<=? "abc" "aBcD")) +(test #f (string-ci<=? "ABCd" "aBc")) + +(test #t (string-ci>=? "abc" "aBc")) +(test #f (string-ci>=? "abc" "aBcD")) +(test #t (string-ci>=? "ABCd" "aBc")) + +(test #t (string-ci=? "ΑΒΓ" "αβγ" "αβγ")) +(test #f (string-ci<? "ΑΒΓ" "αβγ")) +(test #f (string-ci>? "ΑΒΓ" "αβγ")) +(test #t (string-ci<=? "ΑΒΓ" "αβγ")) +(test #t (string-ci>=? "ΑΒΓ" "αβγ")) + +;; latin +(test "ABC" (string-upcase "abc")) +(test "ABC" (string-upcase "ABC")) +(test "abc" (string-downcase "abc")) +(test "abc" (string-downcase "ABC")) +(test "abc" (string-foldcase "abc")) +(test "abc" (string-foldcase "ABC")) + +;; cyrillic +(test "ΑΒΓ" (string-upcase "αβγ")) +(test "ΑΒΓ" (string-upcase "ΑΒΓ")) +(test "αβγ" (string-downcase "αβγ")) +(test "αβγ" (string-downcase "ΑΒΓ")) +(test "αβγ" (string-foldcase "αβγ")) +(test "αβγ" (string-foldcase "ΑΒΓ")) + +;; special cases +(test "SSA" (string-upcase "ßa")) +(test "ßa" (string-downcase "ßa")) +(test "ssa" (string-downcase "SSA")) +(test "maß" (string-downcase "Maß")) +(test "mass" (string-foldcase "Maß")) +(test "İ" (string-upcase "İ")) +(test "i\x0307;" (string-downcase "İ")) +(test "i\x0307;" (string-foldcase "İ")) +(test "J̌" (string-upcase "ǰ")) +(test "ſ" (string-downcase "ſ")) +(test "s" (string-foldcase "ſ")) + +;; context-sensitive (final sigma) +(test "ΓΛΏΣΣΑ" (string-upcase "γλώσσα")) +(test "γλώσσα" (string-downcase "ΓΛΏΣΣΑ")) +(test "γλώσσα" (string-foldcase "ΓΛΏΣΣΑ")) +(test "ΜΈΛΟΣ" (string-upcase "μέλος")) +(test #t (and (member (string-downcase "ΜΈΛΟΣ") '("μέλος" "μέλοσ")) #t)) +(test "μέλοσ" (string-foldcase "ΜΈΛΟΣ")) +(test #t (and (member (string-downcase "ΜΈΛΟΣ ΕΝΌΣ") + '("μέλος ενός" "μέλοσ ενόσ")) + #t)) + +(test "" (substring "" 0 0)) +(test "" (substring "a" 0 0)) +(test "" (substring "abc" 1 1)) +(test "ab" (substring "abc" 0 2)) +(test "bc" (substring "abc" 1 3)) + +(test "" (string-append "")) +(test "" (string-append "" "")) +(test "abc" (string-append "" "abc")) +(test "abc" (string-append "abc" "")) +(test "abcde" (string-append "abc" "de")) +(test "abcdef" (string-append "abc" "de" "f")) + +(test '() (string->list "")) +(test '(#\a) (string->list "a")) +(test '(#\a #\b #\c) (string->list "abc")) +(test '(#\a #\b #\c) (string->list "abc" 0)) +(test '(#\b #\c) (string->list "abc" 1)) +(test '(#\b #\c) (string->list "abc" 1 3)) + +(test "" (list->string '())) +(test "abc" (list->string '(#\a #\b #\c))) + +(test "" (string-copy "")) +(test "" (string-copy "" 0)) +(test "" (string-copy "" 0 0)) +(test "abc" (string-copy "abc")) +(test "abc" (string-copy "abc" 0)) +(test "bc" (string-copy "abc" 1)) +(test "b" (string-copy "abc" 1 2)) +(test "bc" (string-copy "abc" 1 3)) + +(test "-----" + (let ((str (make-string 5 #\x))) (string-fill! str #\-) str)) +(test "xx---" + (let ((str (make-string 5 #\x))) (string-fill! str #\- 2) str)) +(test "xx-xx" + (let ((str (make-string 5 #\x))) (string-fill! str #\- 2 3) str)) + +(test "a12de" + (let ((str (string-copy "abcde"))) (string-copy! str 1 "12345" 0 2) str)) +(test "-----" + (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----") str)) +(test "---xx" + (let ((str (make-string 5 #\x))) (string-copy! str 0 "-----" 2) str)) +(test "xx---" + (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 0 3) str)) +(test "xx-xx" + (let ((str (make-string 5 #\x))) (string-copy! str 2 "-----" 2 3) str)) + +;; same source and dest +(test "aabde" + (let ((str (string-copy "abcde"))) (string-copy! str 1 str 0 2) str)) +(test "abcab" + (let ((str (string-copy "abcde"))) (string-copy! str 3 str 0 2) str)) + +(test-end) + +(test-begin "6.8 Vectors") + +(test #t (vector? #())) +(test #t (vector? #(1 2 3))) +(test #t (vector? '#(1 2 3))) + +(test 0 (vector-length (make-vector 0))) +(test 1000 (vector-length (make-vector 1000))) + +(test #(0 (2 2 2 2) "Anna") '#(0 (2 2 2 2) "Anna")) + +(test #(a b c) (vector 'a 'b 'c)) + +(test 8 (vector-ref '#(1 1 2 3 5 8 13 21) 5)) +(test 13 (vector-ref '#(1 1 2 3 5 8 13 21) + (let ((i (round (* 2 (acos -1))))) + (if (inexact? i) + (exact i) + i)))) + +(test #(0 ("Sue" "Sue") "Anna") (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) + +(test '(dah dah didah) (vector->list '#(dah dah didah))) +(test '(dah didah) (vector->list '#(dah dah didah) 1)) +(test '(dah) (vector->list '#(dah dah didah) 1 2)) +(test #(dididit dah) (list->vector '(dididit dah))) + +(test #() (string->vector "")) +(test #(#\A #\B #\C) (string->vector "ABC")) +(test #(#\B #\C) (string->vector "ABC" 1)) +(test #(#\B) (string->vector "ABC" 1 2)) + +(test "" (vector->string #())) +(test "123" (vector->string #(#\1 #\2 #\3))) +(test "23" (vector->string #(#\1 #\2 #\3) 1)) +(test "2" (vector->string #(#\1 #\2 #\3) 1 2)) + +(test #() (vector-copy #())) +(test #(a b c) (vector-copy #(a b c))) +(test #(b c) (vector-copy #(a b c) 1)) +(test #(b) (vector-copy #(a b c) 1 2)) + +(test #() (vector-append #())) +(test #() (vector-append #() #())) +(test #(a b c) (vector-append #() #(a b c))) +(test #(a b c) (vector-append #(a b c) #())) +(test #(a b c d e) (vector-append #(a b c) #(d e))) +(test #(a b c d e f) (vector-append #(a b c) #(d e) #(f))) + +(test #(1 2 smash smash 5) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'smash 2 4) vec)) +(test #(x x x x x) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x) vec)) +(test #(1 2 x x x) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2) vec)) +(test #(1 2 x 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-fill! vec 'x 2 3) vec)) + +(test #(1 a b 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 #(a b c d e) 0 2) vec)) +(test #(a b c d e) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e)) vec)) +(test #(c d e 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 0 #(a b c d e) 2) vec)) +(test #(1 2 a b c) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 0 3) vec)) +(test #(1 2 c 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 2 #(a b c d e) 2 3) vec)) + +;; same source and dest +(test #(1 1 2 4 5) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 1 vec 0 2) vec)) +(test #(1 2 3 1 2) + (let ((vec (vector 1 2 3 4 5))) (vector-copy! vec 3 vec 0 2) vec)) + +(test-end) + +(test-begin "6.9 Bytevectors") + +(test #t (bytevector? #u8())) +(test #t (bytevector? #u8(0 1 2))) +(test #f (bytevector? #())) +(test #f (bytevector? #(0 1 2))) +(test #f (bytevector? '())) +(test #t (bytevector? (make-bytevector 0))) + +(test 0 (bytevector-length (make-bytevector 0))) +(test 1024 (bytevector-length (make-bytevector 1024))) +(test 1024 (bytevector-length (make-bytevector 1024 255))) + +(test 3 (bytevector-length (bytevector 0 1 2))) + +(test 0 (bytevector-u8-ref (bytevector 0 1 2) 0)) +(test 1 (bytevector-u8-ref (bytevector 0 1 2) 1)) +(test 2 (bytevector-u8-ref (bytevector 0 1 2) 2)) + +(test #u8(0 255 2) + (let ((bv (bytevector 0 1 2))) (bytevector-u8-set! bv 1 255) bv)) + +(test #u8() (bytevector-copy #u8())) +(test #u8(0 1 2) (bytevector-copy #u8(0 1 2))) +(test #u8(1 2) (bytevector-copy #u8(0 1 2) 1)) +(test #u8(1) (bytevector-copy #u8(0 1 2) 1 2)) + +(test #u8(1 6 7 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 1 #u8(6 7 8 9 10) 0 2) + bv)) +(test #u8(6 7 8 9 10) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 0 #u8(6 7 8 9 10)) + bv)) +(test #u8(8 9 10 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 0 #u8(6 7 8 9 10) 2) + bv)) +(test #u8(1 2 6 7 8) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 2 #u8(6 7 8 9 10) 0 3) + bv)) +(test #u8(1 2 8 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 2 #u8(6 7 8 9 10) 2 3) + bv)) + +;; same source and dest +(test #u8(1 1 2 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 1 bv 0 2) + bv)) +(test #u8(1 2 3 1 2) + (let ((bv (bytevector 1 2 3 4 5))) + (bytevector-copy! bv 3 bv 0 2) + bv)) + +(test #u8() (bytevector-append #u8())) +(test #u8() (bytevector-append #u8() #u8())) +(test #u8(0 1 2) (bytevector-append #u8() #u8(0 1 2))) +(test #u8(0 1 2) (bytevector-append #u8(0 1 2) #u8())) +(test #u8(0 1 2 3 4) (bytevector-append #u8(0 1 2) #u8(3 4))) +(test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1 2) #u8(3 4) #u8(5))) + +(test "ABC" (utf8->string #u8(#x41 #x42 #x43))) +(test "ABC" (utf8->string #u8(0 #x41 #x42 #x43) 1)) +(test "ABC" (utf8->string #u8(0 #x41 #x42 #x43 0) 1 4)) +(test "λ" (utf8->string #u8(0 #xCE #xBB 0) 1 3)) +(test #u8(#x41 #x42 #x43) (string->utf8 "ABC")) +(test #u8(#x42 #x43) (string->utf8 "ABC" 1)) +(test #u8(#x42) (string->utf8 "ABC" 1 2)) +(test #u8(#xCE #xBB) (string->utf8 "λ")) + +(test-end) + +(test-begin "6.10 Control Features") + +(test #t (procedure? car)) +(test #f (procedure? 'car)) +(test #t (procedure? (lambda (x) (* x x)))) +(test #f (procedure? '(lambda (x) (* x x)))) +(test #t (call-with-current-continuation procedure?)) + +(test 7 (apply + (list 3 4))) +(test 7 (apply + 3 4 (list))) +(test-error (apply +)) ;; not enough args +(test-error (apply + 3)) ;; final arg not a list +(test-error (apply + 3 4)) ;; final arg not a list +(test-error (apply + '(2 3 . 4))) ;; final arg is improper + + +(define compose + (lambda (f g) + (lambda args + (f (apply g args))))) +(test '(30 0) + (call-with-values (lambda () ((compose exact-integer-sqrt *) 12 75)) + list)) + +(test '(b e h) (map cadr '((a b) (d e) (g h)))) + +(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) + +(test '(5 7 9) (map + '(1 2 3) '(4 5 6 7))) + +(test #t + (let ((res (let ((count 0)) + (map (lambda (ignored) + (set! count (+ count 1)) + count) + '(a b))))) + (or (equal? res '(1 2)) + (equal? res '(2 1))))) + +(test '(10 200 3000 40 500 6000) + (let ((ls1 (list 10 100 1000)) + (ls2 (list 1 2 3 4 5 6))) + (set-cdr! (cddr ls1) ls1) + (map * ls1 ls2))) + +(test "abdegh" (string-map char-foldcase "AbdEgH")) + +(test "IBM" (string-map + (lambda (c) + (integer->char (+ 1 (char->integer c)))) + "HAL")) + +(test "StUdLyCaPs" + (string-map + (lambda (c k) (if (eqv? k #\u) (char-upcase c) (char-downcase c))) + "studlycaps xxx" + "ululululul")) + +(test #(b e h) (vector-map cadr '#((a b) (d e) (g h)))) + +(test #(1 4 27 256 3125) + (vector-map (lambda (n) (expt n n)) + '#(1 2 3 4 5))) + +(test #(5 7 9) (vector-map + '#(1 2 3) '#(4 5 6 7))) + +(test #t + (let ((res (let ((count 0)) + (vector-map + (lambda (ignored) + (set! count (+ count 1)) + count) + '#(a b))))) + (or (equal? res #(1 2)) + (equal? res #(2 1))))) + +(test #(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each (lambda (i) + (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(test 9750 + (let ((ls1 (list 10 100 1000)) + (ls2 (list 1 2 3 4 5 6)) + (count 0)) + (set-cdr! (cddr ls1) ls1) + (for-each (lambda (x y) (set! count (+ count (* x y)))) ls2 ls1) + count)) + +(test '(101 100 99 98 97) + (let ((v '())) + (string-for-each + (lambda (c) (set! v (cons (char->integer c) v))) + "abcde") + v)) + +(test '(0 1 4 9 16) (let ((v (make-list 5))) + (vector-for-each + (lambda (i) (list-set! v i (* i i))) + '#(0 1 2 3 4)) + v)) + +(test -3 (call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t))) +(define list-length + (lambda (obj) + (call-with-current-continuation + (lambda (return) + (letrec ((r + (lambda (obj) + (cond ((null? obj) 0) + ((pair? obj) + (+ (r (cdr obj)) 1)) + (else (return #f)))))) + (r obj)))))) + +(test 4 (list-length '(1 2 3 4))) + +(test #f (list-length '(a b . c))) + +(test 5 + (call-with-values (lambda () (values 4 5)) + (lambda (a b) b))) + +(test -1 (call-with-values * -)) + +(test '(connect talk1 disconnect + connect talk2 disconnect) + (let ((path '()) + (c #f)) + (let ((add (lambda (s) + (set! path (cons s path))))) + (dynamic-wind + (lambda () (add 'connect)) + (lambda () + (add (call-with-current-continuation + (lambda (c0) + (set! c c0) + 'talk1)))) + (lambda () (add 'disconnect))) + (if (< (length path) 4) + (c 'talk2) + (reverse path))))) + +(test-end) + +(test-begin "6.11 Exceptions") + +(test 65 + (with-exception-handler + (lambda (con) 42) + (lambda () + (+ (raise-continuable "should be a number") + 23)))) + +(test #t + (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) +(test "BOOM!" + (error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) +(test '(1 2 3) + (error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3)))) + +(test #f + (file-error? (guard (exn (else exn)) (error "BOOM!")))) +(test #t + (file-error? (guard (exn (else exn)) (open-input-file " no such file ")))) + +(test #f + (read-error? (guard (exn (else exn)) (error "BOOM!")))) +(test #t + (read-error? (guard (exn (else exn)) (read (open-input-string ")"))))) +(test #t + (read-error? (guard (exn (else exn)) (read (open-input-string "\""))))) + +(define something-went-wrong #f) +(define (test-exception-handler-1 v) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) + (set! something-went-wrong (list "condition: " x)) + (k 'exception)) + (lambda () + (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))) +(test 106 (test-exception-handler-1 5)) +(test #f something-went-wrong) +(test 'exception (test-exception-handler-1 -1)) +(test '("condition: " an-error) something-went-wrong) + +(set! something-went-wrong #f) +(define (test-exception-handler-2 v) + (guard (ex (else 'caught-another-exception)) + (with-exception-handler + (lambda (x) + (set! something-went-wrong #t) + (list "exception:" x)) + (lambda () + (+ 1 (if (> v 0) (+ v 100) (raise 'an-error))))))) +(test 106 (test-exception-handler-2 5)) +(test #f something-went-wrong) +(test 'caught-another-exception (test-exception-handler-2 -1)) +(test #t something-went-wrong) + +;; Based on an example from R6RS-lib section 7.1 Exceptions. +;; R7RS section 6.11 Exceptions has a simplified version. +(let* ((out (open-output-string)) + (value (with-exception-handler + (lambda (con) + (cond + ((not (list? con)) + (raise con)) + ((list? con) + (display (car con) out)) + (else + (display "a warning has been issued" out))) + 42) + (lambda () + (+ (raise-continuable + (list "should be a number")) + 23))))) + (test "should be a number" (get-output-string out)) + (test 65 value)) + +;; From SRFI-34 "Examples" section - #3 +(define (test-exception-handler-3 v out) + (guard (condition + (else + (display "condition: " out) + (write condition out) + (display #\! out) + 'exception)) + (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v))))) +(let* ((out (open-output-string)) + (value (test-exception-handler-3 0 out))) + (test 'exception value) + (test "condition: an-error!" (get-output-string out))) + +(define (test-exception-handler-4 v out) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (x) + (display "reraised " out) + (write x out) (display #\! out) + (k 'zero)) + (lambda () + (guard (condition + ((positive? condition) + 'positive) + ((negative? condition) + 'negative)) + (raise v))))))) + +;; From SRFI-34 "Examples" section - #5 +(let* ((out (open-output-string)) + (value (test-exception-handler-4 1 out))) + (test "" (get-output-string out)) + (test 'positive value)) +;; From SRFI-34 "Examples" section - #6 +(let* ((out (open-output-string)) + (value (test-exception-handler-4 -1 out))) + (test "" (get-output-string out)) + (test 'negative value)) +;; From SRFI-34 "Examples" section - #7 +(let* ((out (open-output-string)) + (value (test-exception-handler-4 0 out))) + (test "reraised 0!" (get-output-string out)) + (test 'zero value)) + +;; From SRFI-34 "Examples" section - #8 +(test 42 + (guard (condition + ((assq 'a condition) => cdr) + ((assq 'b condition))) + (raise (list (cons 'a 42))))) + +;; From SRFI-34 "Examples" section - #9 +(test '(b . 23) + (guard (condition + ((assq 'a condition) => cdr) + ((assq 'b condition))) + (raise (list (cons 'b 23))))) + +(test 'caught-d + (guard (condition + ((assq 'c condition) 'caught-c) + ((assq 'd condition) 'caught-d)) + (list + (sqrt 8) + (guard (condition + ((assq 'a condition) => cdr) + ((assq 'b condition))) + (raise (list (cons 'd 24))))))) + +(test-end) + +(test-begin "6.12 Environments and evaluation") + +;; (test 21 (eval '(* 7 3) (scheme-report-environment 5))) + +(test 20 + (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5)))) + (f + 10))) + +(test 1024 (eval '(expt 2 10) (environment '(scheme base)))) +;; (sin 0) may return exact number +(test 0.0 (inexact (eval '(sin 0) (environment '(scheme inexact))))) +;; ditto +(test 1024.0 (eval '(+ (expt 2 10) (inexact (sin 0))) + (environment '(scheme base) '(scheme inexact)))) + +(test-end) + +(test-begin "6.13 Input and output") + +(test #t (port? (current-input-port))) +(test #t (input-port? (current-input-port))) +(test #t (output-port? (current-output-port))) +(test #t (output-port? (current-error-port))) +(test #t (input-port? (open-input-string "abc"))) +(test #t (output-port? (open-output-string))) + +(test #t (textual-port? (open-input-string "abc"))) +(test #t (textual-port? (open-output-string))) +(test #t (binary-port? (open-input-bytevector #u8(0 1 2)))) +(test #t (binary-port? (open-output-bytevector))) + +(test #t (input-port-open? (open-input-string "abc"))) +(test #t (output-port-open? (open-output-string))) + +(test #f + (let ((in (open-input-string "abc"))) + (close-input-port in) + (input-port-open? in))) + +(test #f + (let ((out (open-output-string))) + (close-output-port out) + (output-port-open? out))) + +(test #f + (let ((out (open-output-string))) + (close-port out) + (output-port-open? out))) + +(test 'error + (let ((in (open-input-string "abc"))) + (close-input-port in) + (guard (exn (else 'error)) (read-char in)))) + +(test 'error + (let ((out (open-output-string))) + (close-output-port out) + (guard (exn (else 'error)) (write-char #\c out)))) + +(test #t (eof-object? (eof-object))) +(test #t (eof-object? (read (open-input-string "")))) +(test #t (char-ready? (open-input-string "42"))) +(test 42 (read (open-input-string " 42 "))) + +(test #t (eof-object? (read-char (open-input-string "")))) +(test #\a (read-char (open-input-string "abc"))) + +(test #t (eof-object? (read-line (open-input-string "")))) +(test "abc" (read-line (open-input-string "abc"))) +(test "abc" (read-line (open-input-string "abc\ndef\n"))) + +(test #t (eof-object? (read-string 3 (open-input-string "")))) +(test "abc" (read-string 3 (open-input-string "abcd"))) +(test "abc" (read-string 3 (open-input-string "abc\ndef\n"))) + +(let ((in (open-input-string (string #\x10F700 #\x10F701 #\x10F702)))) + (let* ((c0 (peek-char in)) + (c1 (read-char in)) + (c2 (read-char in)) + (c3 (read-char in))) + (test #\x10F700 c0) + (test #\x10F700 c1) + (test #\x10F701 c2) + (test #\x10F702 c3))) + +(test (string #\x10F700) + (let ((out (open-output-string))) + (write-char #\x10F700 out) + (get-output-string out))) + +(test "abc" + (let ((out (open-output-string))) + (write 'abc out) + (get-output-string out))) + +(test "abc def" + (let ((out (open-output-string))) + (display "abc def" out) + (get-output-string out))) + +(test "abc" + (let ((out (open-output-string))) + (display #\a out) + (display "b" out) + (display #\c out) + (get-output-string out))) + +(test #t + (let* ((out (open-output-string)) + (r (begin (newline out) (get-output-string out)))) + (or (equal? r "\n") (equal? r "\r\n")))) + +(test "abc def" + (let ((out (open-output-string))) + (write-string "abc def" out) + (get-output-string out))) + +(test "def" + (let ((out (open-output-string))) + (write-string "abc def" out 4) + (get-output-string out))) + +(test "c d" + (let ((out (open-output-string))) + (write-string "abc def" out 2 5) + (get-output-string out))) + +(test "" + (let ((out (open-output-string))) + (flush-output-port out) + (get-output-string out))) + +(test #t (eof-object? (read-u8 (open-input-bytevector #u8())))) +(test 1 (read-u8 (open-input-bytevector #u8(1 2 3)))) + +(test #t (eof-object? (read-bytevector 3 (open-input-bytevector #u8())))) +(test #t (u8-ready? (open-input-bytevector #u8(1)))) +(test #u8(1) (read-bytevector 3 (open-input-bytevector #u8(1)))) +(test #u8(1 2) (read-bytevector 3 (open-input-bytevector #u8(1 2)))) +(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3)))) +(test #u8(1 2 3) (read-bytevector 3 (open-input-bytevector #u8(1 2 3 4)))) + +(test #t + (let ((bv (bytevector 1 2 3 4 5))) + (eof-object? (read-bytevector! bv (open-input-bytevector #u8()))))) + +(test #u8(6 7 8 9 10) + (let ((bv (bytevector 1 2 3 4 5))) + (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 5) + bv)) + +(test #u8(6 7 8 4 5) + (let ((bv (bytevector 1 2 3 4 5))) + (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 0 3) + bv)) + +(test #u8(1 2 3 6 5) + (let ((bv (bytevector 1 2 3 4 5))) + (read-bytevector! bv (open-input-bytevector #u8(6 7 8 9 10)) 3 4) + bv)) + +(test #u8(1 2 3) + (let ((out (open-output-bytevector))) + (write-u8 1 out) + (write-u8 2 out) + (write-u8 3 out) + (get-output-bytevector out))) + +(test #u8(1 2 3 4 5) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out) + (get-output-bytevector out))) + +(test #u8(3 4 5) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out 2) + (get-output-bytevector out))) + +(test #u8(3 4) + (let ((out (open-output-bytevector))) + (write-bytevector #u8(1 2 3 4 5) out 2 4) + (get-output-bytevector out))) + +(test #u8() + (let ((out (open-output-bytevector))) + (flush-output-port out) + (get-output-bytevector out))) + +(test #t + (and (member + (let ((out (open-output-string)) + (x (list 1))) + (set-cdr! x x) + (write x out) + (get-output-string out)) + ;; labels not guaranteed to be 0 indexed, spacing may differ + '("#0=(1 . #0#)" "#1=(1 . #1#)")) + #t)) + +(test "((1 2 3) (1 2 3))" + (let ((out (open-output-string)) + (x (list 1 2 3))) + (write (list x x) out) + (get-output-string out))) + +(test "((1 2 3) (1 2 3))" + (let ((out (open-output-string)) + (x (list 1 2 3))) + (write-simple (list x x) out) + (get-output-string out))) + +(test #t + (and (member (let ((out (open-output-string)) + (x (list 1 2 3))) + (write-shared (list x x) out) + (get-output-string out)) + '("(#0=(1 2 3) #0#)" "(#1=(1 2 3) #1#)")) + #t)) + +(test-begin "Read syntax") + +;; check reading boolean followed by eof +(test #t (read (open-input-string "#t"))) +(test #t (read (open-input-string "#true"))) +(test #f (read (open-input-string "#f"))) +(test #f (read (open-input-string "#false"))) +(define (read2 port) + (let* ((o1 (read port)) (o2 (read port))) + (cons o1 o2))) +;; check reading boolean followed by delimiter +(test '(#t . (5)) (read2 (open-input-string "#t(5)"))) +(test '(#t . 6) (read2 (open-input-string "#true 6 "))) +(test '(#f . 7) (read2 (open-input-string "#f 7"))) +(test '(#f . "8") (read2 (open-input-string "#false\"8\""))) + +(test '() (read (open-input-string "()"))) +(test '(1 2) (read (open-input-string "(1 2)"))) +(test '(1 . 2) (read (open-input-string "(1 . 2)"))) +(test '(1 2) (read (open-input-string "(1 . (2))"))) +(test '(1 2 3 4 5) (read (open-input-string "(1 . (2 3 4 . (5)))"))) +(test '1 (cadr (read (open-input-string "#0=(1 . #0#)")))) +(test '(1 2 3) (cadr (read (open-input-string "(#0=(1 2 3) #0#)")))) + +(test '(quote (1 2)) (read (open-input-string "'(1 2)"))) +(test '(quote (1 (unquote 2))) (read (open-input-string "'(1 ,2)"))) +(test '(quote (1 (unquote-splicing 2))) (read (open-input-string "'(1 ,@2)"))) +(test '(quasiquote (1 (unquote 2))) (read (open-input-string "`(1 ,2)"))) + +(test #() (read (open-input-string "#()"))) +(test #(a b) (read (open-input-string "#(a b)"))) + +(test #u8() (read (open-input-string "#u8()"))) +(test #u8(0 1) (read (open-input-string "#u8(0 1)"))) + +(test 'abc (read (open-input-string "abc"))) +(test 'abc (read (open-input-string "abc def"))) +(test 'ABC (read (open-input-string "ABC"))) +(test 'Hello (read (open-input-string "|H\\x65;llo|"))) + +(test 'abc (read (open-input-string "#!fold-case ABC"))) +(test 'ABC (read (open-input-string "#!fold-case #!no-fold-case ABC"))) + +(test 'def (read (open-input-string "#; abc def"))) +(test 'def (read (open-input-string "; abc \ndef"))) +(test 'def (read (open-input-string "#| abc |# def"))) +(test 'ghi (read (open-input-string "#| abc #| def |# |# ghi"))) +(test 'ghi (read (open-input-string "#; ; abc\n def ghi"))) +(test '(abs -16) (read (open-input-string "(#;sqrt abs -16)"))) +(test '(a d) (read (open-input-string "(a #; #;b c d)"))) +(test '(a e) (read (open-input-string "(a #;(b #;c d) e)"))) +(test '(a . c) (read (open-input-string "(a . #;b c)"))) +(test '(a . b) (read (open-input-string "(a . b #;c)"))) + +(define (test-read-error str) + (test-assert str + (guard (exn (else #t)) + (read (open-input-string str)) + #f))) + +(test-read-error "(#;a . b)") +(test-read-error "(a . #;b)") +(test-read-error "(a #;. b)") +(test-read-error "(#;x #;y . z)") +(test-read-error "(#; #;x #;y . z)") +(test-read-error "(#; #;x . z)") + +(test #\a (read (open-input-string "#\\a"))) +(test #\space (read (open-input-string "#\\space"))) +(test 0 (char->integer (read (open-input-string "#\\null")))) +(test 7 (char->integer (read (open-input-string "#\\alarm")))) +(test 8 (char->integer (read (open-input-string "#\\backspace")))) +(test 9 (char->integer (read (open-input-string "#\\tab")))) +(test 10 (char->integer (read (open-input-string "#\\newline")))) +(test 13 (char->integer (read (open-input-string "#\\return")))) +(test #x7F (char->integer (read (open-input-string "#\\delete")))) +(test #x1B (char->integer (read (open-input-string "#\\escape")))) +(test #x03BB (char->integer (read (open-input-string "#\\λ")))) +(test #x03BB (char->integer (read (open-input-string "#\\x03BB")))) + +(test "abc" (read (open-input-string "\"abc\""))) +(test "abc" (read (open-input-string "\"abc\" \"def\""))) +(test "ABC" (read (open-input-string "\"ABC\""))) +(test "Hello" (read (open-input-string "\"H\\x65;llo\""))) +(test 7 (char->integer (string-ref (read (open-input-string "\"\\a\"")) 0))) +(test 8 (char->integer (string-ref (read (open-input-string "\"\\b\"")) 0))) +(test 9 (char->integer (string-ref (read (open-input-string "\"\\t\"")) 0))) +(test 10 (char->integer (string-ref (read (open-input-string "\"\\n\"")) 0))) +(test 13 (char->integer (string-ref (read (open-input-string "\"\\r\"")) 0))) +(test #x22 (char->integer (string-ref (read (open-input-string "\"\\\"\"")) 0))) +(test #x7C (char->integer (string-ref (read (open-input-string "\"\\|\"")) 0))) +(test "line 1\nline 2\n" (read (open-input-string "\"line 1\nline 2\n\""))) +(test "line 1continued\n" (read (open-input-string "\"line 1\\\ncontinued\n\""))) +(test "line 1continued\n" (read (open-input-string "\"line 1\\ \ncontinued\n\""))) +(test "line 1continued\n" (read (open-input-string "\"line 1\\\n continued\n\""))) +(test "line 1continued\n" (read (open-input-string "\"line 1\\ \t \n \t continued\n\""))) +(test "line 1\n\nline 3\n" (read (open-input-string "\"line 1\\ \t \n \t \n\nline 3\n\""))) +(test #x03BB (char->integer (string-ref (read (open-input-string "\"\\x03BB;\"")) 0))) + +(define-syntax test-write-syntax + (syntax-rules () + ((test-write-syntax expect-str obj-expr) + (let ((out (open-output-string))) + (write obj-expr out) + (test expect-str (get-output-string out)))))) + +(test-write-syntax "|.|" '|.|) +(test-write-syntax "|a b|" '|a b|) +(test-write-syntax "|,a|" '|,a|) +(test-write-syntax "|\"|" '|\"|) +(test-write-syntax "|\\||" '|\||) +(test-write-syntax "||" '||) +(test-write-syntax "|\\\\123|" '|\\123|) +(test-write-syntax "a" '|a|) +;; (test-write-syntax "a.b" '|a.b|) +(test-write-syntax "|2|" '|2|) +(test-write-syntax "|+3|" '|+3|) +(test-write-syntax "|-.4|" '|-.4|) +(test-write-syntax "|+i|" '|+i|) +(test-write-syntax "|-i|" '|-i|) +(test-write-syntax "|+inf.0|" '|+inf.0|) +(test-write-syntax "|-inf.0|" '|-inf.0|) +(test-write-syntax "|+nan.0|" '|+nan.0|) +(test-write-syntax "|+NaN.0|" '|+NaN.0|) +(test-write-syntax "|+NaN.0abc|" '|+NaN.0abc|) + +(test-end) + +(test-begin "Numeric syntax") + +;; Numeric syntax adapted from Peter Bex's tests. +;; +;; These are updated to R7RS, using string ports instead of +;; string->number, and "error" tests removed because implementations +;; are free to provide their own numeric extensions. Currently all +;; tests are run by default - need to cond-expand and test for +;; infinities and -0.0. + +(define-syntax test-numeric-syntax + (syntax-rules () + ((test-numeric-syntax str expect strs ...) + (let* ((z (read (open-input-string str))) + (out (open-output-string)) + (z-str (begin (write z out) (get-output-string out)))) + (test expect (values z)) + (test #t (and (member z-str '(str strs ...)) #t)))))) + +;; Each test is of the form: +;; +;; (test-numeric-syntax input-str expected-value expected-write-values ...) +;; +;; where the input should be eqv? to the expected-value, and the +;; written output the same as any of the expected-write-values. The +;; form +;; +;; (test-numeric-syntax input-str expected-value) +;; +;; is a shorthand for +;; +;; (test-numeric-syntax input-str expected-value (input-str)) + +;; Simple +(test-numeric-syntax "1" 1) +(test-numeric-syntax "+1" 1 "1") +(test-numeric-syntax "-1" -1) +(test-numeric-syntax "#i1" 1.0 "1.0" "1.") +(test-numeric-syntax "#I1" 1.0 "1.0" "1.") +(test-numeric-syntax "#i-1" -1.0 "-1.0" "-1.") +;; Decimal +(test-numeric-syntax "1.0" 1.0 "1.0" "1.") +(test-numeric-syntax "1." 1.0 "1.0" "1.") +(test-numeric-syntax ".1" 0.1 "0.1" "100.0e-3") +(test-numeric-syntax "-.1" -0.1 "-0.1" "-100.0e-3") +;; Some Schemes don't allow negative zero. This is okay with the standard +(test-numeric-syntax "-.0" -0.0 "-0." "-0.0" "0.0" "0." ".0") +(test-numeric-syntax "-0." -0.0 "-.0" "-0.0" "0.0" "0." ".0") +(test-numeric-syntax "#i1.0" 1.0 "1.0" "1.") +(test-numeric-syntax "#e1.0" 1 "1") +(test-numeric-syntax "#e-.0" 0 "0") +(test-numeric-syntax "#e-0." 0 "0") +;; Decimal notation with suffix +(test-numeric-syntax "1e2" 100.0 "100.0" "100.") +(test-numeric-syntax "1E2" 100.0 "100.0" "100.") +(test-numeric-syntax "1s2" 100.0 "100.0" "100.") +(test-numeric-syntax "1S2" 100.0 "100.0" "100.") +(test-numeric-syntax "1f2" 100.0 "100.0" "100.") +(test-numeric-syntax "1F2" 100.0 "100.0" "100.") +(test-numeric-syntax "1d2" 100.0 "100.0" "100.") +(test-numeric-syntax "1D2" 100.0 "100.0" "100.") +(test-numeric-syntax "1l2" 100.0 "100.0" "100.") +(test-numeric-syntax "1L2" 100.0 "100.0" "100.") +;; NaN, Inf +(test-numeric-syntax "+nan.0" +nan.0 "+nan.0" "+NaN.0") +(test-numeric-syntax "+NAN.0" +nan.0 "+nan.0" "+NaN.0") +(test-numeric-syntax "+inf.0" +inf.0 "+inf.0" "+Inf.0") +(test-numeric-syntax "+InF.0" +inf.0 "+inf.0" "+Inf.0") +(test-numeric-syntax "-inf.0" -inf.0 "-inf.0" "-Inf.0") +(test-numeric-syntax "-iNF.0" -inf.0 "-inf.0" "-Inf.0") +(test-numeric-syntax "#i+nan.0" +nan.0 "+nan.0" "+NaN.0") +(test-numeric-syntax "#i+inf.0" +inf.0 "+inf.0" "+Inf.0") +(test-numeric-syntax "#i-inf.0" -inf.0 "-inf.0" "-Inf.0") +;; Exact ratios +(test-numeric-syntax "1/2" (/ 1 2)) +(test-numeric-syntax "#e1/2" (/ 1 2) "1/2") +(test-numeric-syntax "10/2" 5 "5") +(test-numeric-syntax "-1/2" (- (/ 1 2))) +(test-numeric-syntax "0/10" 0 "0") +(test-numeric-syntax "#e0/10" 0 "0") +(test-numeric-syntax "#i3/2" (/ 3.0 2.0) "1.5") +;; Exact complex +(test-numeric-syntax "1+2i" (make-rectangular 1 2)) +(test-numeric-syntax "1+2I" (make-rectangular 1 2) "1+2i") +(test-numeric-syntax "1-2i" (make-rectangular 1 -2)) +(test-numeric-syntax "-1+2i" (make-rectangular -1 2)) +(test-numeric-syntax "-1-2i" (make-rectangular -1 -2)) +(test-numeric-syntax "+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i") +(test-numeric-syntax "0+i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i") +(test-numeric-syntax "0+1i" (make-rectangular 0 1) "+i" "+1i" "0+i" "0+1i") +(test-numeric-syntax "-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i") +(test-numeric-syntax "0-i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i") +(test-numeric-syntax "0-1i" (make-rectangular 0 -1) "-i" "-1i" "0-i" "0-1i") +(test-numeric-syntax "+2i" (make-rectangular 0 2) "2i" "+2i" "0+2i") +(test-numeric-syntax "-2i" (make-rectangular 0 -2) "-2i" "0-2i") +;; Decimal-notation complex numbers (rectangular notation) +(test-numeric-syntax "1.0+2i" (make-rectangular 1.0 2) "1.0+2.0i" "1.0+2i" "1.+2i" "1.+2.i") +(test-numeric-syntax "1+2.0i" (make-rectangular 1 2.0) "1.0+2.0i" "1+2.0i" "1.+2.i" "1+2.i") +(test-numeric-syntax "1e2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i") +(test-numeric-syntax "1s2+1.0i" (make-rectangular 100.0 1.0) "100.0+1.0i" "100.+1.i") +(test-numeric-syntax "1.0+1e2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i") +(test-numeric-syntax "1.0+1s2i" (make-rectangular 1.0 100.0) "1.0+100.0i" "1.+100.i") +;; Fractional complex numbers (rectangular notation) +(test-numeric-syntax "1/2+3/4i" (make-rectangular (/ 1 2) (/ 3 4))) +;; Mixed fractional/decimal notation complex numbers (rectangular notation) +(test-numeric-syntax "0.5+3/4i" (make-rectangular 0.5 (/ 3 4)) + "0.5+0.75i" ".5+.75i" "0.5+3/4i" ".5+3/4i" "500.0e-3+750.0e-3i") +;; Complex NaN, Inf (rectangular notation) +;;(test-numeric-syntax "+nan.0+nan.0i" (make-rectangular the-nan the-nan) "+NaN.0+NaN.0i") +(test-numeric-syntax "+inf.0+inf.0i" (make-rectangular +inf.0 +inf.0) "+Inf.0+Inf.0i") +(test-numeric-syntax "-inf.0+inf.0i" (make-rectangular -inf.0 +inf.0) "-Inf.0+Inf.0i") +(test-numeric-syntax "-inf.0-inf.0i" (make-rectangular -inf.0 -inf.0) "-Inf.0-Inf.0i") +(test-numeric-syntax "+inf.0-inf.0i" (make-rectangular +inf.0 -inf.0) "+Inf.0-Inf.0i") +;; Complex numbers (polar notation) +;; Need to account for imprecision in write output. +;;(test-numeric-syntax "1@2" -0.416146836547142+0.909297426825682i "-0.416146836547142+0.909297426825682i") +;; Base prefixes +(test-numeric-syntax "#x11" 17 "17") +(test-numeric-syntax "#X11" 17 "17") +(test-numeric-syntax "#d11" 11 "11") +(test-numeric-syntax "#D11" 11 "11") +(test-numeric-syntax "#o11" 9 "9") +(test-numeric-syntax "#O11" 9 "9") +(test-numeric-syntax "#b11" 3 "3") +(test-numeric-syntax "#B11" 3 "3") +(test-numeric-syntax "#o7" 7 "7") +(test-numeric-syntax "#xa" 10 "10") +(test-numeric-syntax "#xA" 10 "10") +(test-numeric-syntax "#xf" 15 "15") +(test-numeric-syntax "#x-10" -16 "-16") +(test-numeric-syntax "#d-10" -10 "-10") +(test-numeric-syntax "#o-10" -8 "-8") +(test-numeric-syntax "#b-10" -2 "-2") +;; Combination of prefixes +(test-numeric-syntax "#e#x10" 16 "16") +(test-numeric-syntax "#i#x10" 16.0 "16.0" "16.") +(test-numeric-syntax "#x#i10" 16.0 "16.0" "16.") +(test-numeric-syntax "#i#x1/10" 0.0625 "0.0625") +(test-numeric-syntax "#x#i1/10" 0.0625 "0.0625") +;; (Attempted) decimal notation with base prefixes +(test-numeric-syntax "#d1." 1.0 "1.0" "1.") +(test-numeric-syntax "#d.1" 0.1 "0.1" ".1" "100.0e-3") +(test-numeric-syntax "#x1e2" 482 "482") +(test-numeric-syntax "#d1e2" 100.0 "100.0" "100.") +;; Fractions with prefixes +(test-numeric-syntax "#x10/2" 8 "8") +(test-numeric-syntax "#x11/2" (/ 17 2) "17/2") +(test-numeric-syntax "#d11/2" (/ 11 2) "11/2") +(test-numeric-syntax "#o11/2" (/ 9 2) "9/2") +(test-numeric-syntax "#b11/10" (/ 3 2) "3/2") +;; Complex numbers with prefixes +;;(test-numeric-syntax "#x10+11i" (make-rectangular 16 17) "16+17i") +(test-numeric-syntax "#d1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i") +(test-numeric-syntax "#d10+11i" (make-rectangular 10 11) "10+11i") +;;(test-numeric-syntax "#o10+11i" (make-rectangular 8 9) "8+9i") +;;(test-numeric-syntax "#b10+11i" (make-rectangular 2 3) "2+3i") +;;(test-numeric-syntax "#e1.0+1.0i" (make-rectangular 1 1) "1+1i" "1+i") +;;(test-numeric-syntax "#i1.0+1.0i" (make-rectangular 1.0 1.0) "1.0+1.0i" "1.+1.i") + +(define-syntax test-precision + (syntax-rules () + ((test-round-trip str alt ...) + (let* ((n (string->number str)) + (str2 (number->string n)) + (accepted (list str alt ...)) + (ls (member str2 accepted))) + (test-assert (string-append "(member? " str2 " " + (let ((out (open-output-string))) + (write accepted out) + (get-output-string out)) + ")") + (pair? ls)) + (when (pair? ls) + (test-assert (string-append "(eqv?: " str " " str2 ")") + (eqv? n (string->number (car ls))))))))) + +(test-precision "-1.7976931348623157e+308" "-inf.0") +(test-precision "4.940656458412465e-324" "4.94065645841247e-324" "5.0e-324" "0.0") +(test-precision "9.881312916824931e-324" "9.88131291682493e-324" "1.0e-323" "0.0") +(test-precision "1.48219693752374e-323" "1.5e-323" "0.0") +(test-precision "1.976262583364986e-323" "1.97626258336499e-323" "2.0e-323" "0.0") +(test-precision "2.470328229206233e-323" "2.47032822920623e-323" "2.5e-323" "0.0") +(test-precision "2.420921664622108e-322" "2.42092166462211e-322" "2.4e-322" "0.0") +(test-precision "2.420921664622108e-320" "2.42092166462211e-320" "2.421e-320" "0.0") +(test-precision "1.4489974452386991" "1.4489975") +(test-precision "0.14285714285714282" "0.14285714285714288" "0.14285715") +(test-precision "1.7976931348623157e+308" "+inf.0") + +(test-end) + +(test-end) + +(test-begin "6.14 System interface") + +;; 6.14 System interface + +;; (test "/usr/local/bin:/usr/bin:/bin" (get-environment-variable "PATH")) + +(test #t (string? (get-environment-variable "PATH"))) + +;; (test '(("USER" . "root") ("HOME" . "/")) (get-environment-variables)) + +(let ((env (get-environment-variables))) + (define (env-pair? x) + (and (pair? x) (string? (car x)) (string? (cdr x)))) + (define (all? pred ls) + (or (null? ls) (and (pred (car ls)) (all? pred (cdr ls))))) + (test #t (list? env)) + (test #t (all? env-pair? env))) + +(test #t (list? (command-line))) + +(test #t (real? (current-second))) +(test #t (inexact? (current-second))) +(test #t (exact? (current-jiffy))) +(test #t (exact? (jiffies-per-second))) + +(test #t (list? (features))) +(test #t (and (memq 'r7rs (features)) #t)) + +(test #t (file-exists? ".")) +(test #f (file-exists? " no such file ")) + +(test #t (file-error? + (guard (exn (else exn)) + (delete-file " no such file ")))) + +(test-end) + +(test-end) diff --git a/tests/r7rs/results.txt b/tests/r7rs/results.txt new file mode 100644 index 0000000..e0a7fd4 --- /dev/null +++ b/tests/r7rs/results.txt @@ -0,0 +1,306 @@ +r7rs suite: 486 passed, 123 failed, 523 skipped, 1132 total +setup forms skipped: 48 + +skipped tests by reason: + 0 no libraries: (import ...) not supported + 37 no multiple values + 3 uses means, skipped: no multiple values + 10 no delay/force + 1 uses integers, skipped: no delay/force + 1 uses stream-filter, skipped: no delay/force + 0 no parameters + 0 uses radix, skipped: no parameters + 9 uses f, skipped: uses radix, skipped: no parameters + 6 no quasiquote + 0 no case-lambda + 5 uses any-arity, skipped: no case-lambda + 4 uses rest-arity, skipped: no case-lambda + 4 uses dead-clause, skipped: no case-lambda + 16 no define-syntax / syntax-rules + 0 uses be-like-begin1, skipped: no define-syntax / syntax-rules + 0 uses be-like-begin2, skipped: no define-syntax / syntax-rules + 0 uses be-like-begin3, skipped: no d [diff truncated]