├── .github ├── scripts │ └── msvcprep.bat └── workflows │ └── zuo-cflags.yml ├── .gitignore ├── LICENSE.txt ├── Makefile.in ├── README.md ├── build.zuo ├── configure ├── configure.ac ├── lib └── zuo │ ├── base.zuo │ ├── bounce.zuo │ ├── build.zuo │ ├── c.zuo │ ├── cmdline.zuo │ ├── config.zuo │ ├── datum.zuo │ ├── dry-run.zuo │ ├── glob.zuo │ ├── hygienic.zuo │ ├── jobserver.zuo │ ├── main.zuo │ ├── private │ ├── base-common │ │ ├── and-or.zuo │ │ ├── bind-struct.zuo │ │ ├── bind.zuo │ │ ├── check-dups.zuo │ │ ├── define-help.zuo │ │ ├── define.zuo │ │ ├── dynamic.zuo │ │ ├── entry.zuo │ │ ├── free-id-eq.zuo │ │ ├── let.zuo │ │ ├── lib.zuo │ │ ├── main.zuo │ │ ├── more-syntax.zuo │ │ ├── opt-lambda.zuo │ │ ├── parse-lib.zuo │ │ ├── parse.zuo │ │ ├── quasiquote.zuo │ │ ├── state.zuo │ │ ├── struct.zuo │ │ └── syntax-error.zuo │ ├── base-hygienic.zuo │ ├── base-hygienic │ │ ├── and-or.zuo │ │ ├── check-dups.zuo │ │ ├── define-help.zuo │ │ ├── define.zuo │ │ ├── let.zuo │ │ ├── main.zuo │ │ ├── more-syntax.zuo │ │ ├── opt-lambda.zuo │ │ ├── quasiquote.zuo │ │ ├── struct.zuo │ │ ├── syntax-error.zuo │ │ └── syntax.zuo │ ├── base.zuo │ ├── base │ │ ├── and-or.zuo │ │ ├── check-dups.zuo │ │ ├── define-help.zuo │ │ ├── define.zuo │ │ ├── let.zuo │ │ ├── main.zuo │ │ ├── more-syntax.zuo │ │ ├── opt-lambda.zuo │ │ ├── quasiquote.zuo │ │ ├── s-exp.zuo │ │ ├── struct.zuo │ │ └── syntax-error.zuo │ ├── build-db.zuo │ ├── cmdline-run.zuo │ ├── jobserver-manager.zuo │ ├── list.zuo │ ├── looper.zuo │ ├── main-hygienic.zuo │ ├── main.zuo │ ├── more.zuo │ ├── pair.zuo │ └── stitcher.zuo │ ├── shell.zuo │ └── thread.zuo ├── local ├── hello.zuo ├── image.zuo ├── repl.zuo └── tree.zuo ├── main.zuo ├── main.zuo.in ├── tests ├── build-cycle.zuo ├── build.zuo ├── c.zuo ├── cleanable.zuo ├── config.zuo ├── cycle.zuo ├── equal.zuo ├── example-common.zuo ├── example-hygienic.zuo ├── example.zuo ├── fib-common.zuo ├── fib-hygienic.zuo ├── fib.zuo ├── file-handle.zuo ├── filesystem.zuo ├── form-common.zuo ├── form-hygienic.zuo ├── form.zuo ├── glob.zuo ├── harness-common.zuo ├── harness-hygienic.zuo ├── harness.zuo ├── hash.zuo ├── image.zuo ├── integer.zuo ├── kernel.zuo ├── macro-common.zuo ├── macro-hygienic.zuo ├── macro.zuo ├── main.zuo ├── module-path.zuo ├── opaque.zuo ├── pair.zuo ├── path.zuo ├── procedure.zuo ├── process.zuo ├── read+print.zuo ├── shell.zuo ├── string.zuo ├── symbol.zuo ├── syntax-hygienic.zuo ├── syntax.zuo ├── thread.zuo └── variable.zuo ├── zuo-doc ├── defzuomodule.rkt ├── fake-kernel.rkt ├── fake-zuo-hygienic.rkt ├── fake-zuo.rkt ├── info.rkt ├── lang-zuo-datum.scrbl ├── lang-zuo-hygienic.scrbl ├── lang-zuo-kernel.scrbl ├── lang-zuo.scrbl ├── overview.scrbl ├── reader.scrbl ├── real-racket.rkt ├── zuo-build.scrbl ├── zuo-lib.scrbl └── zuo.scrbl ├── zuo.c └── zuo.h /.github/scripts/msvcprep.bat: -------------------------------------------------------------------------------- 1 | 2 | REM Find Visual Studio [Express] in one of the usual places. 3 | REM Expects something like "x86", "amd64", or "x86_amd64" as an argument. 4 | 5 | set VCMODE=%1 6 | 7 | REM For 2022 and later, look in "Program Files" 8 | set Applications=%ProgramFiles% 9 | 10 | set VCVARBAT=%Applications%\Microsoft Visual Studio\2022\Community\VC\Auxiliary\Build\vcvarsall.bat 11 | 12 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2022\Enterprise\VC\Auxiliary\Build\vcvarsall.bat 13 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2022\Professional\VC\Auxiliary\Build\vcvarsall.bat 14 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2022\BuildTools\VC\Auxiliary\Build\vcvarsall.bat 15 | 16 | REM For 2019 and earlier, look in "Program Files (x86)" 17 | set Applications=%ProgramFiles(x86)% 18 | if "%Applications%" == "" set Applications=%ProgramFiles% 19 | 20 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2019\Enterprise\VC\Auxiliary\Build\vcvarsall.bat 21 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2019\Professional\VC\Auxiliary\Build\vcvarsall.bat 22 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build\vcvarsall.bat 23 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2019\BuildTools\VC\Auxiliary\Build\vcvarsall.bat 24 | 25 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2017\Enterprise\VC\Auxiliary\Build\vcvarsall.bat 26 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2017\Professional\VC\Auxiliary\Build\vcvarsall.bat 27 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build\vcvarsall.bat 28 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio\2017\BuildTools\VC\Auxiliary\Build\vcvarsall.bat 29 | 30 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio 14.0\vc\vcvarsall.bat 31 | 32 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio 13.0\vc\vcvarsall.bat 33 | 34 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio 12.0\vc\vcvarsall.bat 35 | 36 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio 11.0\vc\vcvarsall.bat 37 | 38 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio 10.0\vc\vcvarsall.bat 39 | 40 | if not exist "%VCVARBAT%" set VCVARBAT=%Applications%\Microsoft Visual Studio 9.0\vc\vcvarsall.bat 41 | 42 | "%VCVARBAT%" %VCMODE% 43 | -------------------------------------------------------------------------------- /.github/workflows/zuo-cflags.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Zuo with Strict Compiler Flags 3 | 4 | # yamllint disable-line rule:truthy 5 | on: [push, pull_request] 6 | 7 | jobs: 8 | build-gcc: 9 | runs-on: ubuntu-22.04 10 | 11 | env: 12 | CFLAGS: "-Werror -Wall -Wextra -Wstrict-prototypes -Wold-style-definition -Wshadow -Wpointer-arith -Wcast-qual -pedantic -O2 -std=c11 -D_POSIX_C_SOURCE=200809L" 13 | 14 | steps: 15 | - uses: actions/checkout@v4 16 | with: 17 | fetch-depth: 100 18 | - name: Compile 19 | run: | 20 | gcc -c $CFLAGS -DZUO_EMBEDDED zuo.c -o zuo_embed.o 21 | gcc $CFLAGS zuo.c -o zuo 22 | - name: Check 23 | run: ./zuo build.zuo check 24 | 25 | build-msvc: 26 | runs-on: windows-2022 27 | 28 | env: 29 | CFLAGS: "/W1 /WX" 30 | 31 | steps: 32 | - uses: actions/checkout@v4 33 | with: 34 | fetch-depth: 100 35 | - name: Compile 36 | shell: cmd 37 | run: | 38 | call .github\scripts\msvcprep.bat x86_amd64 39 | cl /c %CFLAGS% /DZUO_EMBEDDED /Fo:zuo_embed.obj zuo.c 40 | cl %CFLAGS% zuo.c -o zuo 41 | - name: Check 42 | shell: cmd 43 | run: | 44 | call .github\scripts\msvcprep.bat x86_amd64 45 | zuo build.zuo check 46 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /zuo 2 | /zuo.dSYM 3 | /zuo.exe 4 | /zuo.obj 5 | /zuo.o 6 | 7 | /build 8 | 9 | compiled/ 10 | 11 | # common backups, autosaves, lock files, OS meta-files 12 | *~ 13 | \#* 14 | .#* 15 | .DS_Store 16 | *.bak 17 | TAGS 18 | *.swn 19 | *.swo 20 | *.swp 21 | .gdb_history 22 | /.vscode/ 23 | 24 | # generated by patch 25 | *.orig 26 | *.rej 27 | 28 | # coredumps 29 | *.core 30 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright 2022-2023 Zuo Developers 2 | 3 | Copyrights in the Zuo implementation are retained by their contributors. 4 | No copyright assignment is required to contribute to Zuo. 5 | 6 | This component of Racket is distributed under the under the Apache 2.0 7 | and MIT licenses. The user can choose the license under which they 8 | will be using the software. There may be other licenses within the 9 | distribution with which the user must also comply. 10 | 11 | See the files 12 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 13 | and 14 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 15 | for the full text of the licenses. 16 | 17 | The SHA-256 implementation is from mbed TLS. mbed TLS is licensed 18 | under the Apache v2.0 License. 19 | -------------------------------------------------------------------------------- /Makefile.in: -------------------------------------------------------------------------------- 1 | # @PACKAGE_NAME@ @configure_input@ 2 | @SET_MAKE@ 3 | 4 | srcdir = @srcdir@ 5 | 6 | prefix = @prefix@ 7 | exec_prefix = @exec_prefix@ 8 | datarootdir = @datarootdir@ 9 | datadir = @datadir@ 10 | 11 | bindir = @bindir@ 12 | pkgdatadir = @datadir@/@PACKAGE_TARNAME@ 13 | 14 | CC = @CC@ 15 | CFLAGS = @CFLAGS@ 16 | CPPFLAGS = @CPPFLAGS@ 17 | LDFLAGS = @LDFLAGS@ 18 | LIBS = @LIBS@ 19 | 20 | CC_FOR_BUILD = @CC_FOR_BUILD@ 21 | CFLAGS_FOR_BUILD = @CFLAGS_FOR_BUILD@ 22 | CPPFLAGS_FOR_BUILD = @CPPFLAGS_FOR_BUILD@ 23 | LDFLAGS_FOR_BUILD = @LDFLAGS_FOR_BUILD@ 24 | LIBS_FOR_BUILD = @LIBS_FOR_BUILD@ 25 | 26 | EMBED_LIBS = @EMBED_LIBS@ 27 | 28 | .PHONY: zuos-to-run-and-install 29 | zuos-to-run-and-install: zuo 30 | ./zuo . zuos-to-run-and-install 31 | 32 | zuo: $(srcdir)/zuo.c 33 | $(CC_FOR_BUILD) $(CFLAGS_FOR_BUILD) $(CPPFLAGS_FOR_BUILD) -DZUO_LIB_PATH='"'"$(srcdir)/lib"'"' -o zuo $(srcdir)/zuo.c $(LDFLAGS_FOR_BUILD) $(LIBS_FOR_BUILD) 34 | 35 | .PHONY: check 36 | check: zuo 37 | ./zuo . to-run/zuo 38 | to-run/zuo . check 39 | 40 | .PHONY: install 41 | install: zuo 42 | ./zuo . install DESTDIR="$(DESTDIR)" 43 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This is a mirror of the Zuo sources in the `racket/src/zuo` directory of 2 | [the Racket repository](https://github.com/racket/racket). 3 | 4 | Zuo: A Tiny Racket for Scripting 5 | ================================ 6 | 7 | You should use Racket to write scripts. But what if you need something 8 | much smaller than Racket for some reason — or what if you're trying 9 | to script a build of Racket itself? Zuo is a tiny Racket with 10 | primitives for dealing with files and running processes, and it comes 11 | with a `make`-like embedded DSL. 12 | 13 | Zuo is a Racket variant in the sense that program files start with 14 | `#lang`, and the module path after `#lang` determines the parsing and 15 | expansion of the file content. That's how the `make`-like DSL is 16 | defined, and even the base Zuo language is defined by layers of 17 | `#lang`s. One of the early layers implements macros. 18 | 19 | 20 | Some Example Scripts 21 | -------------------- 22 | 23 | See [`local/hello.zuo`](local/hello.zuo), 24 | [`local/tree.zuo`](local/tree.zuo), 25 | [`local/image.zuo`](local/image.zuo), and 26 | [`build.zuo`](build.zuo). 27 | 28 | 29 | Building and Running Zuo 30 | ------------------------ 31 | 32 | Compile `zuo.c` with a C compiler. No additional files are needed, 33 | other than system and C library headers. No compiler flags should be 34 | needed, although flags like `-o zuo` or `-O2` are a good idea. 35 | 36 | You can also use `configure`, `make`, and `make install`, where `make` 37 | targets mostly invoke a Zuo script after compiling `zuo.c`. If you 38 | don't use `configure` but compile to `zuo` in the current directory, 39 | then `./zuo build.zuo` and `./zuo build.zuo install` (omit the `./` on Windows) 40 | will do the same thing as `make` and `make install` with a default 41 | configuration. 42 | 43 | The Zuo executable runs only modules. If you run Zuo with no 44 | command-line arguments, then it loads `main.zuo`. Use the `-c` 45 | flag to provide module text as an argument. Otherwise, the first 46 | argument to Zuo is a file to run or a directory containing a 47 | `main.zuo` to run, and additional arguments are delivered to that Zuo 48 | program via the `runtime-env` procedure. Running the command 49 | `./zuo build install`, for example, runs the `build/main.zuo` program 50 | with the argument `install`. Whatever initial script is run, if it has 51 | a `main` submodule, that submodule is also run. 52 | 53 | 54 | Library Modules and Startup Performance 55 | --------------------------------------- 56 | 57 | Except for the built-in `zuo/kernel` language module, Zuo finds 58 | languages and modules through a collection of libraries. By default, 59 | Zuo looks for a directory `lib` relative to the executable as the root 60 | of the library-collection tree. You can supply an alternate collection 61 | path with the `-X` command-line flag. 62 | 63 | You can also create an instance of Zuo with a set of libraries 64 | embedded as a heap image. Embedding a heap image has two advantages: 65 | 66 | * No extra directory of library modules is necessary. 67 | 68 | * Zuo can start especially quickly, competitive with the fastest 69 | command-line programs. 70 | 71 | The `local/image.zuo` script generates a `.c` file that is a copy of 72 | `zuo.c` plus embedded modules. By default, the `zuo` module and its 73 | dependencies are included, but you can specify others with `++lib`. In 74 | addition, the default collection-root path is disabled in the 75 | generated copy, unless you supply `--keep-collects` to 76 | `local/image.zuo`. 77 | 78 | When you use `configure` and `make` or `./zuo build.zuo`, the default 79 | build target creates a `to-run/zuo` that embeds the `zuo` library, as 80 | well as a `to-install/zuo` that has the right internal path to find 81 | other libraries after `make install` or `./zuo build.zuo install`. 82 | 83 | You can use heap images without embedding. The `dump-heap-and-exit` 84 | Zuo kernel primitive creates a heap image, and a `-B` or `--boot` 85 | command-line flag for Zuo uses the given boot image on startup. You 86 | can also embed an image created with `dump-image-and-exit` by using 87 | `local/image.zuo` with the `--image` flag. 88 | 89 | A boot image is machine-independent, whether in a stand-alone file or 90 | embedded in `.c` source. 91 | 92 | 93 | Cross Compiling 94 | --------------- 95 | 96 | If you use `./configure --host=...` to cross compile, then you will 97 | also need to add something like `CC_FOR_BUILD=cc` as a `./configure` 98 | argument to specify the compiler for a `zuo` to use on the build 99 | machine. If necessary, you can also specify `CFLAGS_FOR_BUILD`, 100 | `LDFLAGS_FOR_BUILD`, and/or `LIBS_FOR_BUILD`. 101 | 102 | 103 | Embedding Zuo in Another Application 104 | ------------------------------------ 105 | 106 | Zuo can be embedded in a larger application, with or without an 107 | embedded boot image. To support embedding, compile `zuo.c` or the 108 | output of `local/image.zuo` with the `ZUO_EMBEDDED` preprocessor macro 109 | defined (to anything); the `zuo.h` header will be used in that case, 110 | and `zuo.h` should also be used by the embedding application. 111 | Documentation for the embedding API is provided as comments within 112 | `zuo.h`. 113 | 114 | 115 | More Information 116 | ---------------- 117 | 118 | Install the `zuo-doc` directory as a package in Racket to render the 119 | documentation there, or see 120 | [docs.racket-lang.org](https://docs.racket-lang.org/zuo/index.html). 121 | -------------------------------------------------------------------------------- /build.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | (require "local/image.zuo") 3 | 4 | ;; Exports `targets` and also defines a `main` submodule 5 | ;; that handles command-line arguments and builds a target 6 | ;; in a `make`-like way 7 | (provide-targets targets-at) 8 | 9 | ;; The `targets-at` function generates targets, and `to-dir` determines 10 | ;; the build directory --- so these targets could be used by another 11 | ;; build script that wants the output in a subdirectory, for example 12 | (define (targets-at at-dir [vars (hash)]) 13 | ;; The `configure` script writes configuration info to "Makefile", so 14 | ;; use that if it's available, or use defaults otherwise 15 | (define Makefile (at-dir "Makefile")) 16 | (define config-in 17 | (cond 18 | [(file-exists? Makefile) (config-file->hash Makefile)] 19 | ;; no `configure`-generated `Makefile`, so use defaults 20 | [(eq? (system-type) 'unix) 21 | (hash 'prefix "/usr/local" 22 | 'CC "cc" 23 | 'CFLAGS "-O2")] 24 | [else 25 | (hash 'prefix "C:\\Program Files\\Zuo" 26 | 'CC "cl.exe" 27 | 'CFLAGS "/O2")])) 28 | (define config (foldl (lambda (key config) 29 | (hash-set config key (hash-ref vars key))) 30 | config-in 31 | (hash-keys vars))) 32 | 33 | (define install-prefix (hash-ref config 'prefix)) 34 | (define pkgdatadir (shell-subst (hash-ref config 'pkgdatadir (build-path install-prefix "lib" "zuo")) 35 | config)) 36 | 37 | ;; Get a target for "image_zuo.c" from `image.zuo` 38 | (define image_zuo.c 39 | (image-target (hash 'output (at-dir "image_zuo.c") 40 | 'libs (map string->symbol (string-split (hash-ref config 'EMBED_LIBS "zuo"))) 41 | 'keep-collects? #t))) 42 | 43 | ;; We'll build two executables; they are the same except for the 44 | ;; embedded libary path, so we have a target maker parameterized 45 | ;; over that choice 46 | (define (exe-target name lib-path) 47 | (target (at-dir (add-exe name)) 48 | (lambda (path token) 49 | (rule (list image_zuo.c 50 | (input-data-target 'config (cons 51 | lib-path 52 | (map (lambda (key) (hash-ref config key #f)) 53 | '(CC CPPFLAGS CFLAGS LDFLAGS LIBS)))) 54 | (quote-module-path)) 55 | (lambda () 56 | (define l (split-path path)) 57 | (when (car l) (mkdir-p (car l))) 58 | (c-compile path 59 | (list (target-path image_zuo.c)) 60 | (config-merge config 61 | 'CPPFLAGS 62 | (string->shell (~a "-DZUO_LIB_PATH=" lib-path))))))))) 63 | 64 | (define (add-exe name) 65 | (if (eq? (hash-ref (runtime-env) 'system-type) 'windows) 66 | (~a name ".exe") 67 | name)) 68 | 69 | ;; The library path gets used as a C string constant, which isn't 70 | ;; trivial because there are likely to be backslashes on Windows 71 | (define (as-c-string path) (~s path)) ; probably a good enough approximation 72 | 73 | ;; The two executable targets 74 | (define zuo-to-run (exe-target "to-run/zuo" (as-c-string (find-relative-path "to-run" 75 | (at-source "lib"))))) 76 | (define zuo-to-install (exe-target "to-install/zuo" (as-c-string (build-path pkgdatadir "..")))) 77 | 78 | ;; A phony target to build both executables, which we'll list first 79 | ;; so it's used as the default target 80 | (define zuos-to-run-and-install 81 | (target 'zuos-to-run-and-install 82 | (lambda (token) 83 | (phony-rule (list zuo-to-run zuo-to-install) 84 | void)))) 85 | 86 | ;; A phony target to run the test suite 87 | (define check 88 | (target 'check 89 | (lambda (token) 90 | (phony-rule (list zuo-to-run) 91 | (lambda () 92 | (unless (= 0 (process-status 93 | (thread-process-wait 94 | (hash-ref (process (.exe "to-run/zuo") 95 | (at-source "tests/main.zuo")) 96 | 'process)))) 97 | (error "check failed"))))))) 98 | 99 | ;; A phony target to install 100 | (define install 101 | (target 'install 102 | (lambda (token) 103 | (phony-rule (list zuo-to-install) 104 | (lambda () 105 | (define (at-destdir p) 106 | (define destdir (hash-ref config 'DESTDIR "")) 107 | (if (equal? destdir "") 108 | p 109 | (apply build-path 110 | (cons destdir 111 | (cdr (explode-path (path->complete-path p))))))) 112 | (define (say-copy cp a b) 113 | (displayln (~a "copying " a " to " b)) 114 | (cp a b)) 115 | (define bindir (at-destdir 116 | (shell-subst (hash-ref config 'bindir (build-path install-prefix "bin")) 117 | config))) 118 | (mkdir-p (at-destdir install-prefix)) 119 | (mkdir-p bindir) 120 | (define dest-exe (build-path bindir "zuo")) 121 | (when (file-exists? dest-exe) (rm dest-exe)) ; needed for macOS 122 | (say-copy cp (target-name zuo-to-install) dest-exe) 123 | (mkdir-p (at-destdir pkgdatadir)) 124 | (say-copy cp* 125 | (at-source "lib" "zuo") 126 | (at-destdir (build-path pkgdatadir)))))))) 127 | 128 | ;; Return all the targets 129 | (list zuos-to-run-and-install 130 | image_zuo.c 131 | zuo-to-run 132 | zuo-to-install 133 | check 134 | install)) 135 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # Process this file with autoconf to produce a configure script. 2 | AC_INIT([Zuo], 3 | [1.0], 4 | [https://github.com/racket/racket/issues], 5 | [], 6 | [https://github.com/racket/zuo]) 7 | AC_CONFIG_SRCDIR(zuo.c) 8 | 9 | AC_ARG_ENABLE(embed, 10 | [AS_HELP_STRING([--enable-embed=], 11 | [embed ; defaults to "zuo"])], 12 | [] 13 | [: m4_divert_text([DEFAULTS], [enable_embed="zuo"])]) 14 | AC_ARG_ENABLE(big,[AS_HELP_STRING([--enable-big], 15 | [embed "zuo/hygienic" as well as "zuo"])]) 16 | 17 | EMBED_LIBS="zuo" 18 | AS_IF([test "x$enable_embed" = xno], 19 | [EMBED_LIBS=""], 20 | [test "x$enable_big" = xyes], 21 | [EMBED_LIBS="zuo zuo/hygienic"], 22 | [test "x$enable_embed" != xyes], 23 | [EMBED_LIBS="${enable_embed}"]) 24 | 25 | AC_PROG_MAKE_SET() 26 | AC_PROG_CC 27 | 28 | if test "${CC_FOR_BUILD}" = ""; then 29 | CC_FOR_BUILD='$(CC) -O2' 30 | CPPFLAGS_FOR_BUILD='$(CPPFLAGS)' 31 | CFLAGS_FOR_BUILD='$(CFLAGS)' 32 | LDFLAGS_FOR_BUILD='$(LDFLAGS)' 33 | LIBS_FOR_BUILD='$(LIBS)' 34 | fi 35 | AC_ARG_VAR(CC_FOR_BUILD,[build system C compiler command]) 36 | AC_ARG_VAR(CFLAGS_FOR_BUILD,[build system C compiler flags]) 37 | AC_ARG_VAR(LDFLAGS_FOR_BUILD,[build system linker flags]) 38 | AC_ARG_VAR(LIBS_FOR_BUILD,[build system libraries for linker]) 39 | AC_ARG_VAR(CPPFLAGS_FOR_BUILD,[build system preprocessor flags]) 40 | 41 | AC_SUBST(EMBED_LIBS) 42 | AC_MSG_NOTICE([zuo libraries to embed: "${EMBED_LIBS}"]) 43 | 44 | AC_CONFIG_FILES([Makefile main.zuo]) 45 | AC_OUTPUT() 46 | -------------------------------------------------------------------------------- /lib/zuo/base.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/kernel 2 | 3 | (let ([maker (hash-ref (module->hash 'zuo/private/base) 'make-language #f)]) 4 | (maker 'zuo/private/base/main)) 5 | -------------------------------------------------------------------------------- /lib/zuo/bounce.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | 3 | -------------------------------------------------------------------------------- /lib/zuo/c.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | (require "shell.zuo") 3 | 4 | (provide c-compile 5 | c-link 6 | c-ar 7 | 8 | .c->.o 9 | .exe 10 | .a 11 | 12 | config-include 13 | config-define 14 | config-merge) 15 | 16 | (define (c-compile .o .c config) 17 | (unless (path-string? .o) (arg-error 'c-compile "path string" .o)) 18 | (unless (or (path-string? .c) 19 | (and (list? .c) (andmap path-string? .c))) 20 | (arg-error 'c-compile "path string or list of paths strings" .c)) 21 | (unless (hash? config) (arg-error 'c-compile "hash table" config)) 22 | (define windows? (eq? (hash-ref (runtime-env) 'toolchain-type) 'windows)) 23 | (define lookup (make-lookup config)) 24 | (define command 25 | (build-shell (or (lookup 'CC) 26 | (if windows? 27 | "cl.exe" 28 | "cc")) 29 | (or (lookup 'CPPFLAGS) "") 30 | (or (lookup 'CFLAGS) "") 31 | (if windows? (if (path-string? .c) "/Fo:" "/Fe:") "-o") (string->shell .o) 32 | (if (string? .c) 33 | (build-shell "-c" (string->shell .c)) 34 | (apply build-shell (map string->shell .c))) 35 | (if (string? .c) 36 | "" 37 | (build-shell (or (lookup 'LDFLAGS) "") 38 | (or (lookup 'LIBS) ""))))) 39 | (shell/wait command (hash 'desc "compile"))) 40 | 41 | (define (c-link .exe ins config) 42 | (unless (path-string? .exe) (arg-error 'c-link "path string" .exe)) 43 | (unless (and (list? ins) (andmap path-string? ins)) (arg-error 'c-link "list of path strings" ins)) 44 | (unless (hash? config) (arg-error 'c-link "hash table" config)) 45 | (define windows? (eq? (hash-ref (runtime-env) 'toolchain-type) 'windows)) 46 | (define lookup (make-lookup config)) 47 | (define command 48 | (build-shell (or (lookup 'CC) 49 | (if windows? 50 | "cl.exe" 51 | "cc")) 52 | (or (lookup 'CFLAGS) "") 53 | (if windows? "/Fe:" "-o") (string->shell .exe) 54 | (string-join (map string->shell ins)) 55 | (or (lookup 'LDFLAGS) "") 56 | (or (lookup 'LIBS) ""))) 57 | (shell/wait command (hash 'desc "link"))) 58 | 59 | (define (c-ar .a ins config) 60 | (unless (path-string? .a) (arg-error 'c-ar "path string" .exe)) 61 | (unless (and (list? ins) (andmap path-string? ins)) (arg-error 'c-ar "list of path strings" ins)) 62 | (unless (hash? config) (arg-error 'c-ar "hash table" config)) 63 | (define windows? (eq? (hash-ref (runtime-env) 'toolchain-type) 'windows)) 64 | (define lookup (make-lookup config)) 65 | (shell/wait 66 | (build-shell (or (lookup 'AR) 67 | (if windows? 68 | "lib.exe" 69 | "ar")) 70 | (or (lookup 'ARFLAGS) "") 71 | (string->shell (if windows? (~a "/OUT:" .a) .a)) 72 | (string-join (map string->shell ins))) 73 | (hash 'desc 74 | "library creation"))) 75 | 76 | (define (make-lookup config) 77 | (lambda (key) (hash-ref config key #f))) 78 | 79 | (define (.c->.o .c) 80 | (unless (path-string? .c) (arg-error '.c->.o "path string" .c)) 81 | (path-replace-extension .c (if (eq? (hash-ref (runtime-env) 'toolchain-type) 'windows) 82 | ".obj" 83 | ".o"))) 84 | 85 | (define (.exe name) 86 | (unless (path-string? name) (arg-error '.exe "string" name)) 87 | (if (eq? (hash-ref (runtime-env) 'system-type) 'windows) 88 | (~a name ".exe") 89 | name)) 90 | 91 | (define (.a name) 92 | (unless (path-string? name) (arg-error '.a "string" name)) 93 | (if (eq? (hash-ref (runtime-env) 'toolchain-type) 'windows) 94 | (~a name ".lib") 95 | (let ([l (split-path name)]) 96 | (build-path (or (car l) ".") (~a "lib" (cdr l) ".a"))))) 97 | 98 | (define (config-include config . paths) 99 | (unless (hash? config) (arg-error 'config-include "hash table" config)) 100 | (foldl (lambda (path config) 101 | (unless (path-string? path) (arg-error 'config-include "path string" path)) 102 | (do-config-merge config 'CPPFLAGS (~a "-I" (string->shell path)))) 103 | config 104 | paths)) 105 | 106 | (define (config-define config . defs) 107 | (unless (hash? config) (arg-error 'config-define "hash table" config)) 108 | (foldl (lambda (def config) 109 | (unless (string? def) (arg-error 'config-define "string" def)) 110 | (do-config-merge config 'CPPFLAGS (~a "-D" (string->shell def)))) 111 | config 112 | defs)) 113 | 114 | (define (config-merge config key shell-str) 115 | (unless (hash? config) (arg-error 'config-merge "hash table" config)) 116 | (unless (symbol? key) (arg-error 'config-merge "symbol" key)) 117 | (unless (string? shell-str) (arg-error 'config-merge "string" shell-str)) 118 | (do-config-merge config key shell-str)) 119 | 120 | (define (do-config-merge config key shell-str) 121 | (define now-str (hash-ref config key "")) 122 | (hash-set config key (build-shell now-str shell-str))) 123 | -------------------------------------------------------------------------------- /lib/zuo/config.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | 3 | (provide config-file->hash) 4 | 5 | (define (config-file->hash path [vars (hash)]) 6 | (unless (path-string? path) (arg-error 'config->hash "path string" path)) 7 | (unless (hash? vars) (arg-error 'config->hash "hash table" vars)) 8 | (define content (file->string path)) 9 | (define no-cr-content (string-join (string-split content "\r") "")) 10 | (define lines (string-split (string-join (string-split no-cr-content "\\\n") "") "\n")) 11 | (define config 12 | (foldl (lambda (line accum) 13 | (define positions ; (list var-start var-end =-pos) or #f 14 | (let loop ([i 0] [start #f] [end #f]) 15 | (cond 16 | [(= i (string-length line)) #f] 17 | [else 18 | (let ([c (string-ref line i)]) 19 | (cond 20 | [(= (char "=") c) (and start (list start (or end i) i))] 21 | [(or (= (char "_") c) 22 | (and (<= (char "a") c) 23 | (<= c (char "z"))) 24 | (and (<= (char "A") c) 25 | (<= c (char "Z"))) 26 | (and (<= (char "0") c) 27 | (<= c (char "9")))) 28 | (and (not end) 29 | (loop (+ i 1) (or start i) #f))] 30 | [(= (char " ") c) 31 | (if start 32 | (loop (+ i 1) start (or end i)) 33 | (loop (+ i 1) #f #f))] 34 | [else #f]))]))) 35 | (cond 36 | [positions 37 | (define var (string->symbol (substring line (car positions) (cadr positions)))) 38 | (define rhs (substring line (+ (list-ref positions 2) 1) (string-length line))) 39 | (hash-set accum var (string-trim (remove-makefile-comment rhs)))] 40 | [else accum])) 41 | (hash) 42 | lines)) 43 | (foldl (lambda (key config) 44 | (hash-set config key (hash-ref vars key) )) 45 | config 46 | (hash-keys vars))) 47 | 48 | (define (remove-makefile-comment s) 49 | (define l (string-split s "#")) 50 | (cond 51 | [(= (length l) 1) s] 52 | [else 53 | ;; A `\` just before `#` escapes the `#` 54 | (let loop ([l l]) 55 | (cond 56 | [(null? l) ""] 57 | [else 58 | (let* ([s (car l)] 59 | [len (string-length s)]) 60 | (cond 61 | [(= len 0) ""] 62 | [(= (char "\\") (string-ref s (- len 1))) 63 | (~a (substring s 0 (- len 1)) 64 | "#" 65 | (loop (cdr l)))] 66 | [else s]))]))])) 67 | -------------------------------------------------------------------------------- /lib/zuo/datum.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/kernel 2 | 3 | ;; `#lang zuo/datum` creates a module that just exports S-expressions, 4 | ;; which can useful with `include` for building `zuo` and `zuo/hygienic` 5 | ;; from a shared source 6 | 7 | (hash 'read-and-eval 8 | (lambda (str start mod-path) 9 | (let ([es (string-read str start mod-path)]) 10 | (hash 'datums es)))) 11 | -------------------------------------------------------------------------------- /lib/zuo/dry-run.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | 3 | (provide maybe-dry-run-mode) 4 | 5 | (define (maybe-dry-run-mode) 6 | (define a (and (eq? 'unix (system-type)) 7 | (assoc "MAKEFLAGS" (hash-ref (runtime-env) 'env)))) 8 | (define (new-mode mode sym) 9 | (when (and mode (not (eq? mode sym))) 10 | (error (~a "`MAKEFLAGS` specified both " mode " and " sym " modes"))) 11 | sym) 12 | (define (no-touch mode) 13 | (when (eq? mode 'touch) 14 | (error "`MAKEFLAGS` indicates touch mode, which is not supported")) 15 | mode) 16 | (and a 17 | (let loop ([l (shell->strings (cdr a))]) 18 | (and (pair? l) 19 | (or 20 | ;; If the first argument has only letters, then we 21 | ;; assume it represents single-letter flags: 22 | (let ([s (car l)]) 23 | (let loop ([i 0] [mode #f]) 24 | (cond 25 | [(= i (string-length s)) 26 | (no-touch mode)] 27 | [(equal? (char "n") (string-ref s i)) 28 | (loop (+ i 1) (new-mode mode 'dry-run))] 29 | [(equal? (char "q") (string-ref s i)) 30 | (loop (+ i 1) (new-mode mode 'question))] 31 | [(equal? (char "t") (string-ref s i)) 32 | (loop (+ i 1) (new-mode mode 'touch))] 33 | [(and (or (stringhash 'zuo/private/base-hygienic) 'make-language #f)]) 4 | ;; `zuo/hygenic` is analogous to `zuo/base`, not `zuo` 5 | (maker 'zuo/private/base-hygienic/main)) 6 | -------------------------------------------------------------------------------- /lib/zuo/jobserver.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | (require "thread.zuo" 3 | "glob.zuo") 4 | 5 | (provide maybe-jobserver-jobs 6 | maybe-jobserver-client) 7 | 8 | (define (maybe-jobserver-jobs) 9 | (try-jobserver-client poll-jobserver-client)) 10 | 11 | (define (maybe-jobserver-client) 12 | (try-jobserver-client create-jobserver-client)) 13 | 14 | (define (try-jobserver-client create-jobserver-client) 15 | (define a (and (eq? 'unix (system-type)) 16 | (assoc "MAKEFLAGS" (hash-ref (runtime-env) 'env)))) 17 | (and a 18 | (let ([args (shell->strings (cdr a))]) 19 | (and (ormap (glob->matcher "-j*") args) 20 | (ormap (let ([match? (let ([fds? (glob->matcher "--jobserver-fds=*")] 21 | [auth? (glob->matcher "--jobserver-auth=*")]) 22 | (lambda (s) (or (fds? s) (auth? s))))]) 23 | (lambda (arg) 24 | (and (match? arg) 25 | (let ([fds (map string->integer 26 | (string-split (cadr (string-split arg "=")) ","))]) 27 | (and (= (length fds) 2) 28 | (andmap integer? fds) 29 | ;; read in all available job tokens, then give them back up, 30 | ;; just so we can infer the number of tokens that would be available 31 | (let ([in-no (car fds)] 32 | [out-no (cadr fds)]) 33 | (let ([in (fd-open-input in-no)] 34 | [out (fd-open-output out-no)]) 35 | (and (fd-valid? in) 36 | (fd-valid? out) 37 | (create-jobserver-client in out in-no out-no))))))))) 38 | args))))) 39 | 40 | (define (poll-jobserver-client in out in-no/ignored out-no/ignored) 41 | (let ([s (fd-read in 'avail)]) 42 | (and (string? s) 43 | (begin 44 | (fd-write out s) 45 | (+ 1 (string-length s)))))) 46 | 47 | (define (create-jobserver-client in/ignored out/ignored in-no out-no) 48 | (define msg-ch (channel)) 49 | (define manager-in+out (launch-manager in-no out-no)) 50 | (thread (lambda () 51 | (let loop ([reader? #f] 52 | [held 0] 53 | [queue '()]) 54 | (cond 55 | [(and (pair? queue) 56 | (not reader?)) 57 | (launch-reader manager-in+out msg-ch) 58 | (loop #t held queue)] 59 | [else 60 | (define msg+ (channel-get msg-ch)) 61 | (define msg (car msg+)) 62 | (cond 63 | [(eq? msg 'get) 64 | (define reply-ch (cdr msg+)) 65 | (loop reader? held (append queue (list reply-ch)))] 66 | [(eq? msg 'avail) 67 | (cond 68 | [(pair? queue) 69 | (channel-put (car queue) 'go) 70 | (loop #f (+ 1 held) (cdr queue))] 71 | [else 72 | ;; no one is waiting anymore, so release back to the jobserver 73 | (fd-write (cdr manager-in+out) "-") 74 | (loop #f held queue)])] 75 | [(eq? msg 'put) 76 | (define reply-ch (cdr msg+)) 77 | (cond 78 | [(pair? queue) 79 | (channel-put (car queue) 'go) 80 | (channel-put reply-ch 'done) 81 | (loop reader? held (cdr queue))] 82 | [else 83 | (fd-write (cdr manager-in+out) "-") 84 | (channel-put reply-ch 'done) 85 | (loop reader? (- held 1) queue)])] 86 | [else 87 | (error "unrecognized jobserver-manager message" msg)])])))) 88 | (lambda (msg) 89 | (unless (or (eq? msg 'get) (eq? msg 'put)) 90 | (error "jobserver-client: bad message" msg)) 91 | (define reply-ch (channel)) 92 | (channel-put msg-ch (cons msg reply-ch)) 93 | (channel-get reply-ch) 94 | (void))) 95 | 96 | (define jobserver-manager 97 | (hash-ref (module->hash 'zuo/private/jobserver-manager) 'datums)) 98 | 99 | (define (launch-manager in-no out-no) 100 | ;; The job of the manager process is just to survive at a point where 101 | ;; the enclosing process is trying to exit, possibly due to an error. 102 | ;; It will notice that the stdin pipe is closed and clean up. 103 | (define p (process (hash-ref (runtime-env) 'exe) 104 | "-c" 105 | (~a (car jobserver-manager) "\n" 106 | (string-join (map ~s (cdr jobserver-manager)))) 107 | (~a in-no) 108 | (~a out-no) 109 | (hash 'stdin 'pipe 110 | 'stdout 'pipe))) 111 | (cons (hash-ref p 'stdout) 112 | (hash-ref p 'stdin))) 113 | 114 | (define (launch-reader in+out msg-ch) 115 | ;; The job of a reader process is to read one byte of input and 116 | ;; then exit, because we can wait on process exiting. 117 | (define p (process (hash-ref (runtime-env) 'exe) 118 | "-c" 119 | (~a "#lang zuo/kernel\n" 120 | "(exit (if (eq? eof (fd-read (fd-open-input 'stdin) 1)) 1 0))") 121 | (hash 'stdin (car in+out) 122 | 'cleanable? #f))) 123 | (fd-write (cdr in+out) "+") 124 | (thread (lambda () 125 | (thread-process-wait (hash-ref p 'process)) 126 | (channel-put msg-ch '(avail))))) 127 | -------------------------------------------------------------------------------- /lib/zuo/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/kernel 2 | 3 | (let ([maker (hash-ref (module->hash 'zuo/private/base) 'make-language #f)]) 4 | (maker 'zuo/private/main)) 5 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/and-or.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "syntax-error.zuo") 5 | 6 | (provide or 7 | and 8 | cond else 9 | when 10 | unless) 11 | 12 | (define-syntax or 13 | (lambda (stx) 14 | (if (list? stx) 15 | (if (null? (cdr stx)) 16 | #f 17 | (if (null? (cddr stx)) 18 | (cadr stx) 19 | (list (quote-syntax let) (list (list 'tmp (cadr stx))) 20 | (list (quote-syntax if) 'tmp 21 | 'tmp 22 | (cons (quote-syntax or) (cddr stx)))))) 23 | (bad-syntax stx)))) 24 | 25 | (define-syntax and 26 | (lambda (stx) 27 | (if (list? stx) 28 | (if (null? (cdr stx)) 29 | #t 30 | (if (null? (cddr stx)) 31 | (cadr stx) 32 | (list (quote-syntax if) (cadr stx) 33 | (cons (quote-syntax and) (cddr stx)) 34 | #f))) 35 | (bad-syntax stx)))) 36 | 37 | (define-syntax else misplaced-syntax) 38 | 39 | (define-syntax cond 40 | (context-consumer 41 | (lambda (stx free-id=? name) 42 | (if (and (list? stx) 43 | (letrec ([ok-clauses? 44 | (lambda (l) 45 | (or (null? l) 46 | (let ([cl (car l)]) 47 | (and (list? cl) 48 | (>= (length cl) 2) 49 | (ok-clauses? (cdr l))))))]) 50 | (ok-clauses? (cdr stx)))) 51 | (if (null? (cdr stx)) 52 | (list (quote-syntax void)) 53 | (let ([cl1 (cadr stx)] 54 | [cls (cddr stx)]) 55 | (list 'if (if (and (null? cls) 56 | (identifier? (car cl1)) 57 | (free-id=? 'else (car cl1))) 58 | #t 59 | (car cl1)) 60 | (cons (quote-syntax let) (cons '() (cdr cl1))) 61 | (if (null? cls) 62 | '(void) 63 | (cons (quote-syntax cond) cls))))) 64 | (bad-syntax stx))))) 65 | 66 | (define-syntax when 67 | (lambda (stx) 68 | (if (and (list? stx) 69 | (>= (length stx) 3)) 70 | (list 'if (cadr stx) 71 | (cons (quote-syntax let) (cons '() (cddr stx))) 72 | '(void)) 73 | (bad-syntax stx)))) 74 | 75 | (define-syntax unless 76 | (lambda (stx) 77 | (if (and (list? stx) 78 | (>= (length stx) 3)) 79 | (list 'if (cadr stx) 80 | '(void) 81 | (cons (quote-syntax let) (cons '() (cddr stx)))) 82 | (bad-syntax stx)))) 83 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/bind-struct.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; simple transparent structs 4 | (define (make-maker tag) (lambda (v) (cons tag v))) 5 | (define (make-? tag) (lambda (v) (and (pair? v) (eq? tag (car v))))) 6 | (define (make-?? tag1 tag2) (lambda (v) (and (pair? v) (or (eq? tag1 (car v)) 7 | (eq? tag2 (car v)))))) 8 | (define any-ref cdr) ; not bothering to check a tag 9 | 10 | ;; A binding that's a core form recognized by the expander 11 | (define make-core-form (make-maker 'core-form)) 12 | (define core-form? (make-? 'core-form)) 13 | (define form-id any-ref) 14 | 15 | ;; A binding for a local variable 16 | (define make-local (make-maker 'local)) 17 | (define local? (make-? 'local)) 18 | (define local-id any-ref) 19 | 20 | ;; A binding for a definition 21 | (define make-defined (make-maker 'defined)) 22 | (define defined? (make-? 'defined)) 23 | 24 | ;; A `letrec` bindind or an imported definition 25 | (define make-local-variable (make-maker 'local-variable)) 26 | 27 | ;; A `variable` is a definition or `letrec` 28 | (define variable? (make-?? 'local-variable 'defined)) 29 | (define variable-var any-ref) 30 | 31 | ;; A macro is specifically an imported macro: 32 | (define make-macro (make-maker macro-protocol)) 33 | (define macro-implementation any-ref) 34 | 35 | ;; A macro defined in the current moddule: 36 | (define make-defined-macro (make-maker 'defined-macro)) 37 | (define defined-macro? (make-? 'defined-macro)) 38 | (define defined-macro-proc any-ref) 39 | 40 | ;; Imported or current-module macro 41 | (define macro? (make-?? macro-protocol 'defined-macro)) 42 | 43 | ;; A `literal` wrapper is needed for a pair as a value; any 44 | ;; other kind of value is distinct from our "record"s 45 | (define make-literal (make-maker 'literal)) 46 | (define literal? (make-? 'literal)) 47 | (define literal-val any-ref) 48 | 49 | ;; Wraps a binding to indicate that's from the initial import, 50 | ;; so it's shadowable by `require` 51 | (define make-initial-import (make-maker 'initial)) 52 | (define initial-import? (make-? 'initial)) 53 | (define initial-import-bind any-ref) 54 | 55 | ;; Wraps a binding to give it an identity that persists across 56 | ;; imports 57 | (define make-specific (make-maker 'specific)) 58 | (define specific? (make-? 'specific)) 59 | (define (specific-label s) (cdr (any-ref s))) 60 | 61 | (define (unwrap-specific v) 62 | (if (specific? v) 63 | (car (any-ref v)) 64 | v)) 65 | 66 | (define (as-specific v) 67 | (make-specific (cons v (string->uninterned-symbol "u")))) 68 | 69 | (define (specific=? a b) 70 | (if (specific? a) 71 | (if (specific? b) 72 | (eq? (specific-label a) (specific-label b)) 73 | #f) 74 | (eq? a b))) 75 | 76 | ;; bubbles `specific` outside `initial-import` 77 | (define (initial-import bind) 78 | (let* ([label (and (specific? bind) 79 | (specific-label bind))] 80 | [bind (unwrap-specific bind)] 81 | [bind (make-initial-import bind)]) 82 | (if label 83 | (make-specific (cons bind label)) 84 | bind))) 85 | 86 | (define context-consumer-key (string->uninterned-symbol "ctxer")) 87 | (define (context-consumer proc) 88 | (unless (procedure? proc) (error "context-consumer: not a procedure" proc)) 89 | (opaque context-consumer-key proc)) 90 | (define (context-consumer? v) (and (opaque-ref context-consumer-key v #f) #t)) 91 | (define (context-consumer-procedure v) (opaque-ref context-consumer-key v #f)) 92 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/bind.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; Creation of the initial bindings and managing imports/exports 4 | 5 | ;; A binding can be any non-pair value or one of the record 6 | ;; types described in "struct.zuo" 7 | 8 | (define (make-core-initial-bind bind) 9 | (as-specific (make-initial-import bind))) 10 | 11 | ;; Start with kernel-supplied primitives 12 | (define kernel-provides 13 | (let* ([ht (kernel-env)]) 14 | (foldl (lambda (sym provides) 15 | (hash-set provides sym (make-core-initial-bind (hash-ref ht sym #f)))) 16 | (hash) 17 | (hash-keys ht)))) 18 | 19 | ;; Add expander-defined syntactic forms 20 | (define top-form-provides 21 | (foldl (lambda (sym provides) 22 | (hash-set provides sym (make-core-initial-bind (make-core-form sym)))) 23 | kernel-provides 24 | '(lambda let letrec quote if begin 25 | define define-syntax require provide module+ 26 | quote-syntax quote-module-path 27 | include))) 28 | 29 | ;; Add some functions/constants defined in the expander 30 | (define top-provides 31 | (let* ([provides top-form-provides] 32 | [add (lambda (provides name val) (hash-set provides name (make-core-initial-bind val)))] 33 | [provides (add provides 'identifier? identifier?)] 34 | [provides (add provides 'syntax-e checked-syntax-e)] 35 | [provides (add provides 'syntax->datum checked-syntax->datum)] 36 | [provides (add provides 'datum->syntax checked-datum->syntax)] 37 | [provides (add provides 'bound-identifier=? bound-identifier=?)] 38 | [provides (add provides 'context-consumer context-consumer)] 39 | [provides (add provides 'context-consumer? context-consumer?)] 40 | [provides (add provides 'dynamic-require dynamic-require)]) 41 | provides)) 42 | 43 | ;; Used to convert a local binding into one that goes in a provides 44 | ;; table, so suitable to import into another module 45 | (define (export-bind bind ctx binds) 46 | (let* ([label (and (specific? bind) 47 | (specific-label bind))] 48 | [bind (unwrap-specific bind)] 49 | [bind (if (initial-import? bind) 50 | (initial-import-bind bind) 51 | bind)] 52 | [bind (cond 53 | [(defined? bind) 54 | (make-local-variable (variable-var bind))] 55 | [(defined-macro? bind) 56 | (make-exported-macro (defined-macro-proc bind) ctx)] 57 | [else bind])]) 58 | (if label 59 | (make-specific (cons bind label)) 60 | bind))) 61 | 62 | ;; in case `all-from-out` is used on the initial import, 63 | ;; adds all the current ids in `binds` as nominally imported 64 | (define (initial-nominals mod-path provides) 65 | (list (cons mod-path 66 | (map (lambda (sym) (cons sym (hash-ref provides sym #f))) 67 | (hash-keys provides))))) 68 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/check-dups.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "and-or.zuo" 4 | "syntax-error.zuo" 5 | "../list.zuo") 6 | 7 | (provide check-duplicates) 8 | 9 | (define check-duplicates 10 | (lambda (args) 11 | (foldl (lambda (id seen) 12 | (when (ormap (lambda (seen-id) 13 | (bound-identifier=? id seen-id)) 14 | seen) 15 | (duplicate-identifier id)) 16 | (cons id seen)) 17 | '() 18 | args))) 19 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/define-help.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "and-or.zuo" 5 | "syntax-error.zuo" 6 | "../list.zuo" 7 | "let.zuo" 8 | "check-dups.zuo") 9 | 10 | (provide check-args 11 | make-define) 12 | 13 | (define check-args 14 | (lambda (stx args) 15 | (let ([arg-names 16 | (let loop ([args args] [must-opt? #f]) 17 | (cond 18 | [(identifier? args) ; rest arg 19 | (list args)] 20 | [(pair? args) 21 | (cond 22 | [(and (identifier? (car args)) 23 | (not must-opt?)) 24 | (cons (car args) (loop (cdr args) #f))] 25 | [(and (list? (car args)) 26 | (= 2 (length (car args))) 27 | (identifier? (caar args))) 28 | (cons (caar args) (loop (cdr args) #t))] 29 | [else 30 | (syntax-error (~a (syntax-e (car stx)) ": bad syntax at argument") 31 | (car args))])] 32 | [(null? args) '()] 33 | [else (bad-syntax stx)]))]) 34 | (check-duplicates arg-names) 35 | arg-names))) 36 | 37 | (define make-define 38 | (lambda (orig-define opt-lambda) 39 | (lambda (stx) 40 | (unless (and (list? stx) (>= (length stx) 3)) (bad-syntax stx)) 41 | (let ([head (cadr stx)]) 42 | (cond 43 | [(identifier? head) 44 | ;; regular define 45 | (cons orig-define (cdr stx))] 46 | [(and (pair? head) 47 | (identifier? (car head))) 48 | ;; procedure shorthand 49 | (let* ([name (car head)] 50 | [args (cdr head)]) 51 | (check-args stx args) 52 | (list orig-define name (list* opt-lambda args (cddr stx))))] 53 | [else (bad-syntax stx)]))))) 54 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/define.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "define-help.zuo" 4 | "opt-lambda.zuo") 5 | 6 | (provide (rename-out [define-var-or-proc define] 7 | [define-syntax-var-or-proc define-syntax])) 8 | 9 | (define-syntax define-var-or-proc 10 | (make-define (quote-syntax define) (quote-syntax lambda))) 11 | 12 | (define-syntax define-syntax-var-or-proc 13 | (make-define (quote-syntax define-syntax) (quote-syntax lambda))) 14 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/dynamic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (define (dynamic-require mod-path sym) 4 | (unless (module-path? mod-path) (arg-error 'dynamic-require "module-path" mod-path)) 5 | (unless (symbol? sym) (arg-error 'dynamic-require "symbol" sym)) 6 | (let* ([ht (module->hash mod-path)] 7 | [provides (hash-ref ht 'macromod-provides #f)]) 8 | (unless provides 9 | (error "dynamic-require: not a compatible module" mod-path)) 10 | (let* ([bind (hash-ref provides sym #f)]) 11 | (unless bind (error "dynamic-require: no such provide" sym)) 12 | (let ([bind (unwrap-specific bind)]) 13 | (cond 14 | [(variable? bind) (variable-ref (variable-var bind))] 15 | [(literal? bind) (literal-val bind)] 16 | [else bind]))))) 17 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/entry.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; The `read-and-eval` entry point for a language using the expander 4 | 5 | (define (make-read-and-eval make-initial-state) 6 | (lambda (str start mod-path) 7 | (let* ([es (string-read str start mod-path)] 8 | [ctx (make-module-context mod-path)] 9 | [es (map (lambda (e) (datum->syntax ctx e)) es)] 10 | [parse (make-parse ctx mod-path)] 11 | [initial-state (make-initial-state ctx)] 12 | [es+state+modtop (expand-sequence es initial-state empty-modtop mod-path ctx parse)] 13 | [es (car es+state+modtop)] 14 | [state (cadr es+state+modtop)] 15 | [modtop (cadr (cdr es+state+modtop))] 16 | [outs (resolve-provides (modtop-provides modtop) state ctx mod-path)] 17 | [body (map (lambda (e) (add-print (parse e #f state))) es)] 18 | [submods (parse-submodules (modtop-modules modtop) state mod-path ctx parse)]) 19 | (kernel-eval (cons 'begin (cons '(void) body))) 20 | (hash 'macromod-provides outs 21 | 'submodules submods 22 | merge-bindings-export-key (make-export-merge-binds ctx (state-binds state)) 23 | ;; for getting into this module world from the `zuo/kernel` module world: 24 | 'dynamic-require dynamic-require)))) 25 | 26 | (hash 27 | ;; makes `#lang zuo/private/base[-hygienic] work: 28 | 'read-and-eval (make-read-and-eval (lambda (ctx) 29 | (make-state (binds-create top-provides ctx) 30 | (initial-nominals language-mod-path top-provides)))) 31 | ;; makes `(require zuo/private/base[-hygienic])` work: 32 | 'macromod-provides top-provides 33 | ;; for making a new `#lang` with initial imports from `mod-path`: 34 | 'make-language 35 | (lambda (mod-path) 36 | (let* ([mod (module->hash mod-path)] 37 | [provides (hash-ref mod 'macromod-provides #f)] 38 | [m-binds (hash-ref mod merge-bindings-export-key #f)]) 39 | (unless provides 40 | (syntax-error "not a compatible module for initial imports" mod-path)) 41 | (hash 'read-and-eval 42 | (make-read-and-eval 43 | (lambda (ctx) 44 | (merge-binds (make-state (binds-create provides ctx) 45 | (initial-nominals mod-path provides)) 46 | m-binds))) 47 | 'macromod-provides (hash-ref (module->hash mod-path) 'macromod-provides #f) 48 | 'dynamic-require dynamic-require)))) 49 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/free-id-eq.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (define free-id=? 4 | (lambda (binds id1 id2) 5 | (let* ([bind1 (resolve* binds id1 #f)] 6 | [bind2 (resolve* binds id2 #f)]) 7 | (or (specific=? bind1 bind2) 8 | (and (not bind1) 9 | (not bind2) 10 | (eq? (syntax-e id1) (syntax-e id2))))))) 11 | 12 | (define (apply-macro* proc s name free-id=?) 13 | (let ([c-proc (context-consumer-procedure proc)]) 14 | (if c-proc 15 | (c-proc s free-id=? (and name (symbol->string (syntax-e name)))) 16 | (proc s)))) 17 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/let.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "and-or.zuo" 5 | "syntax-error.zuo" 6 | "../list.zuo" 7 | "check-dups.zuo") 8 | 9 | (provide (rename-out [let-or-named-let let]) 10 | let*) 11 | 12 | (define-syntax let-or-named-let 13 | (lambda (stx) 14 | (cond 15 | [(not (pair? stx)) (bad-syntax stx)] 16 | [(and (pair? (cdr stx)) 17 | (identifier? (cadr stx))) 18 | ;; named `let` 19 | (unless (and (list? stx) 20 | (>= (length stx) 4)) 21 | (bad-syntax stx)) 22 | (let ([name (cadr stx)] 23 | [bindings (cadr (cdr stx))]) 24 | (for-each (lambda (binding) 25 | (unless (and (list? binding) 26 | (= 2 (length binding)) 27 | (identifier? (car binding))) 28 | (syntax-error "named let: bad syntax at binding" binding))) 29 | bindings) 30 | (let ([args (map car bindings)] 31 | [inits (map cadr bindings)]) 32 | (check-duplicates args) 33 | (cons (list (quote-syntax letrec) 34 | (list (list name 35 | (list* (quote-syntax lambda) 36 | args 37 | (cddr (cdr stx))))) 38 | name) 39 | inits)))] 40 | [else (cons (quote-syntax let) (cdr stx))]))) 41 | 42 | (define-syntax let* 43 | (lambda (stx) 44 | (unless (and (list? stx) (>= (length stx) 3)) 45 | (bad-syntax stx)) 46 | (let ([bindings (cadr stx)]) 47 | (unless (list? bindings) (bad-syntax stx)) 48 | (for-each (lambda (binding) 49 | (unless (and (list? binding) 50 | (= 2 (length binding)) 51 | (identifier? (car binding))) 52 | (syntax-error "let*: bad syntax at binding" binding))) 53 | bindings) 54 | (letrec ([nest-bindings 55 | (lambda (bindings) 56 | (if (null? bindings) 57 | (cons (quote-syntax begin) (cddr stx)) 58 | (list (quote-syntax let) (list (car bindings)) 59 | (nest-bindings (cdr bindings)))))]) 60 | (nest-bindings bindings))))) 61 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/lib.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (define (caar p) (car (car p))) 4 | (define (cadr p) (car (cdr p))) 5 | (define (cdar p) (cdr (car p))) 6 | (define (cddr p) (cdr (cdr p))) 7 | 8 | (define map 9 | (letrec ([map (lambda (f vs) 10 | (if (null? vs) 11 | '() 12 | (cons (f (car vs)) (map f (cdr vs)))))]) 13 | map)) 14 | 15 | (define map2 16 | (letrec ([map2 (lambda (f vs v2s) 17 | (if (null? vs) 18 | '() 19 | (cons (f (car vs) (car v2s)) 20 | (map2 f (cdr vs) (cdr v2s)))))]) 21 | map2)) 22 | 23 | (define (foldl f init vs) 24 | (letrec ([fold (lambda (vs accum) 25 | (if (null? vs) 26 | accum 27 | (fold (cdr vs) (f (car vs) accum))))]) 28 | (fold vs init))) 29 | 30 | (define (ormap f vs) 31 | (letrec ([ormap (lambda (vs) 32 | (if (null? vs) 33 | #f 34 | (or (f (car vs)) (ormap (cdr vs)))))]) 35 | (ormap vs))) 36 | 37 | (define (mod-path=? a b) 38 | (if (or (symbol? a) (symbol? b)) 39 | (eq? a b) 40 | (string=? a b))) 41 | 42 | (define (gensym sym) 43 | (string->uninterned-symbol (symbol->string sym))) 44 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "and-or.zuo" 4 | "syntax-error.zuo" 5 | "../pair.zuo" 6 | "../list.zuo" 7 | "let.zuo" 8 | "define.zuo" 9 | "opt-lambda.zuo" 10 | "quasiquote.zuo" 11 | "more-syntax.zuo" 12 | "../more.zuo" 13 | "struct.zuo") 14 | 15 | (provide (all-from-out "and-or.zuo" 16 | "syntax-error.zuo" 17 | "../pair.zuo" 18 | "../list.zuo" 19 | "let.zuo" 20 | "define.zuo" 21 | "opt-lambda.zuo" 22 | "quasiquote.zuo" 23 | "more-syntax.zuo" 24 | "../more.zuo" 25 | "struct.zuo")) 26 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/more-syntax.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "and-or.zuo" 4 | "../pair.zuo" 5 | "../list.zuo" 6 | "define.zuo" 7 | "syntax-error.zuo") 8 | 9 | (provide char 10 | at-source) 11 | 12 | (define-syntax (char stx) 13 | (if (and (list? stx) 14 | (= 2 (length stx)) 15 | (string? (cadr stx)) 16 | (= 1 (string-length (cadr stx)))) 17 | (string-ref (cadr stx) 0) 18 | (bad-syntax stx))) 19 | 20 | (define (combine-path base) 21 | (lambda paths 22 | (cond 23 | [(pair? paths) 24 | (unless (path-string? (car paths)) 25 | (arg-error 'at-source "path string" (car paths))) 26 | (for-each (lambda (path) 27 | (unless (and (path-string? path) 28 | (relative-path? path)) 29 | (arg-error 'at-source "relative path string" path))) 30 | (cdr paths)) 31 | (if (relative-path? (car paths)) 32 | (apply build-path (cons (or (car (split-path base)) ".") paths)) 33 | (apply build-path paths))] 34 | [else 35 | (or (car (split-path base)) ".")]))) 36 | 37 | (define-syntax (at-source stx) 38 | (if (list? stx) 39 | (cons (quote-syntax (combine-path (quote-module-path))) 40 | (cdr stx)) 41 | (if (identifier? stx) 42 | (quote-syntax (combine-path (quote-module-path))) 43 | (bad-syntax stx)))) 44 | 45 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/opt-lambda.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "and-or.zuo" 5 | "syntax-error.zuo" 6 | "define-help.zuo" 7 | "let.zuo") 8 | 9 | (provide (rename-out [opt-lambda lambda])) 10 | 11 | (define-syntax opt-lambda 12 | (context-consumer 13 | (lambda (stx free=? name) 14 | (unless (and (list? stx) (>= (length stx) 3)) (bad-syntax stx)) 15 | (let* ([args (cadr stx)] 16 | [plain? (let loop ([args args]) 17 | (cond 18 | [(null? args) #t] 19 | [(identifier? args) #t] 20 | [else (and (pair? args) 21 | (identifier? (car args)) 22 | (loop (cdr args)))]))]) 23 | (cond 24 | [plain? 25 | (cons (quote-syntax lambda) (cdr stx))] 26 | [else 27 | (let ([all-args (check-args stx args)]) 28 | (let loop ([args args] [rev-plain-args '()]) 29 | (cond 30 | [(identifier? (car args)) 31 | (loop (cdr args) (cons (car args) rev-plain-args))] 32 | [else 33 | (let* ([args-id (string->uninterned-symbol "args")]) 34 | (list (quote-syntax lambda) 35 | (append (reverse rev-plain-args) args-id) 36 | (let loop ([args args]) 37 | (cond 38 | [(null? args) 39 | (list (quote-syntax if) (list (quote-syntax null?) args-id) 40 | (cons (quote-syntax let) (cons (list) (cddr stx))) 41 | (list (quote-syntax opt-arity-error) 42 | (list (quote-syntax quote) name) 43 | (cons (quote-syntax list) 44 | all-args) 45 | args-id))] 46 | [(identifier? args) 47 | (cons (quote-syntax let) 48 | (cons (list (list args args-id)) 49 | (cddr stx)))] 50 | [else 51 | (list (quote-syntax let) 52 | (list (list (caar args) 53 | (list (quote-syntax if) 54 | (list (quote-syntax null?) args-id) 55 | (car (cdar args)) 56 | (list (quote-syntax car) args-id)))) 57 | (list (quote-syntax let) 58 | (list (list args-id 59 | (list (quote-syntax if) 60 | (list (quote-syntax null?) args-id) 61 | (quote-syntax '()) 62 | (list (quote-syntax cdr) args-id)))) 63 | (loop (cdr args))))]))))])))]))))) 64 | 65 | (define opt-arity-error 66 | (lambda (name base-args extra-args) 67 | (arity-error name (append base-args extra-args)))) 68 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/parse-lib.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; Helpers for "parse.zuo" that depends on the implementation of 4 | ;; syntax objects 5 | 6 | (define (name-lambda name form) 7 | (if name 8 | ;; `zuo/kernel` recognizes this pattern to name the form 9 | (cons 'lambda (cons (cadr form) (cons (symbol->string (syntax-e name)) (cddr form)))) 10 | form)) 11 | 12 | (define (syntax-error msg s) 13 | (error (~a msg ": " (~s (syntax->datum s))))) 14 | 15 | (define (bad-syntax s) 16 | (syntax-error "bad syntax" s)) 17 | 18 | (define (duplicate-identifier id s) 19 | (error "duplicate identifier:" (syntax-e id) (syntax->datum s))) 20 | 21 | (define (id-sym-eq? id sym) 22 | (and (identifier? id) 23 | (eq? (syntax-e id) sym))) 24 | 25 | (define (unwrap-mod-path mod-path) 26 | (if (identifier? mod-path) 27 | (syntax-e mod-path) 28 | mod-path)) 29 | 30 | (define (add-binding state id binding) 31 | (state-set-binds state (add-binding* (state-binds state) id binding))) 32 | 33 | (define (resolve state id same-defn-ctx?) 34 | (let* ([bind (resolve* (state-binds state) id same-defn-ctx?)] 35 | [bind (unwrap-specific bind)]) 36 | (if (initial-import? bind) 37 | (initial-import-bind bind) 38 | bind))) 39 | 40 | (define (merge-binds state m-binds) 41 | (if m-binds 42 | (state-set-binds state (merge-binds* (state-binds state) m-binds)) 43 | state)) 44 | 45 | (define (new-defn-context state) 46 | (state-set-binds state (new-defn-context* (state-binds state)))) 47 | 48 | (define (nest-bindings new-cls body) 49 | (letrec ([nest-bindings (lambda (new-cls) 50 | (if (null? new-cls) 51 | body 52 | (list 'let (list (car new-cls)) 53 | (nest-bindings (cdr new-cls)))))]) 54 | (nest-bindings (reverse new-cls)))) 55 | 56 | ;; Use to communicate a `variable-set!` form from `define` to `parse`: 57 | (define set-var-tag (string->uninterned-symbol "setvar")) 58 | 59 | (define (print-result v) 60 | (unless (eq? v (void)) 61 | (alert (~v v)))) 62 | 63 | (define (add-print s) 64 | (list print-result s)) 65 | (define (no-wrap s) s) 66 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/quasiquote.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "and-or.zuo" 5 | "syntax-error.zuo" 6 | "../list.zuo" 7 | "let.zuo") 8 | 9 | (provide quasiquote 10 | unquote 11 | unquote-splicing) 12 | 13 | (define-syntax quasiquote 14 | (context-consumer 15 | (lambda (stx free-id=? name) 16 | (unless (and (list? stx) (= (length stx) 2)) 17 | (bad-syntax stx)) 18 | (let ([quot (quote-syntax quote)]) 19 | (let loop ([s (cadr stx)] [depth 0]) 20 | (let ([loop-pair (lambda (combine combine-name a d depth) 21 | (let ([a (loop a depth)] 22 | [d (loop d depth)]) 23 | (if (and (pair? a) 24 | (eq? (car a) quot) 25 | (pair? d) 26 | (eq? (car d) quot)) 27 | (list quot (combine (cadr a) (cadr d))) 28 | (list combine-name a d))))]) 29 | (cond 30 | [(pair? s) 31 | (let ([a (car s)]) 32 | (cond 33 | [(and (identifier? a) 34 | (free-id=? (syntax-e a) 'unquote)) 35 | (unless (= (length s) 2) 36 | (bad-syntax s)) 37 | (if (= depth 0) 38 | (cadr s) 39 | (loop-pair list (quote-syntax list) a (cadr s) (- depth 1)))] 40 | [(and (identifier? a) 41 | (free-id=? (syntax-e a) 'unquote-splicing)) 42 | (syntax-error "misplaced splicing unquote" s)] 43 | [(and (pair? a) 44 | (identifier? (car a)) 45 | (free-id=? (syntax-e (car a)) 'unquote-splicing)) 46 | (unless (= (length a) 2) 47 | (bad-syntax a)) 48 | (if (= depth 0) 49 | (if (null? (cdr s)) 50 | (cadr a) 51 | (list (quote-syntax append) (cadr a) (loop (cdr s) depth))) 52 | (loop-pair cons (quote-syntax cons) a (cdr s) depth))] 53 | [(and (identifier? a) 54 | (free-id=? (syntax-e a) 'quasiquote)) 55 | (unless (= (length s) 2) 56 | (bad-syntax s)) 57 | (loop-pair list (quote-syntax list) a (cadr s) (+ depth 1))] 58 | [else 59 | (loop-pair cons (quote-syntax cons) a (cdr s) depth)]))] 60 | [else (list quot s)]))))))) 61 | 62 | (define-syntax unquote misplaced-syntax) 63 | (define-syntax unquote-splicing misplaced-syntax) 64 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/state.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; The state of expansion is a combinion of 4 | ;; * bindings 5 | ;; * defined variables being lifted, or #f for a module top 6 | ;; * "nominals", which is information about `require`s that is 7 | ;; used to implement `(provide (all-from-out ....))` 8 | 9 | (define make-state (lambda (binds nominals) (cons binds (cons #f nominals)))) 10 | (define state-binds car) 11 | (define state-variables cadr) 12 | (define state-nominals cddr) 13 | (define (state-set-binds state binds) (cons binds (cdr state))) 14 | (define (state-set-nominals state nominals) (cons (car state) (cons (cadr state) nominals))) 15 | (define (state-set-variables state variables) (cons (car state) (cons variables (cddr state)))) 16 | 17 | ;; helper to lookup or update nominals: 18 | (define (call-with-nominal state mod-path default-ids k) 19 | (let* ([fronted 20 | (letrec ([assoc-to-front 21 | (lambda (l) 22 | (cond 23 | [(null? l) (list (cons mod-path default-ids))] 24 | [(mod-path=? mod-path (caar l)) l] 25 | [else (let ([new-l (assoc-to-front (cdr l))]) 26 | (cons (car new-l) (cons (car l) (cdr new-l))))]))]) 27 | (assoc-to-front (state-nominals state)))]) 28 | (k (cdar fronted) 29 | (lambda (new-sym+bs) 30 | (let* ([new-noms (cons (cons (caar fronted) new-sym+bs) 31 | (cdr fronted))]) 32 | (state-set-nominals state new-noms)))))) 33 | 34 | (define (init-nominal state mod-path) 35 | (call-with-nominal state mod-path '() 36 | (lambda (sym+binds install) 37 | (install sym+binds)))) 38 | 39 | (define (record-nominal state mod-path sym bind) 40 | (call-with-nominal state mod-path '() 41 | (lambda (sym+binds install) 42 | (install (cons (cons sym bind) sym+binds))))) 43 | 44 | (define (lookup-nominal state mod-path) 45 | (call-with-nominal state mod-path #f 46 | (lambda (sym+binds install) 47 | sym+binds))) 48 | 49 | ;; in case `all-from-out` is used on the initial import, 50 | ;; adds all the current ids in `binds` as nominally imported 51 | (define (initial-nominals mod-path sym+bs) 52 | (list (cons mod-path sym+bs))) 53 | 54 | ;; Module top-level state contains provides and submodules 55 | (define empty-modtop (cons '() '())) 56 | (define modtop-provides car) 57 | (define modtop-modules cdr) 58 | (define (modtop-set-provides modtop provides) (cons provides (cdr modtop))) 59 | (define (modtop-set-modules modtop modules) (cons (car modtop) modules)) 60 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/struct.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | (require "and-or.zuo" 3 | "syntax-error.zuo" 4 | "../pair.zuo" 5 | "../list.zuo" 6 | "define.zuo" 7 | "let.zuo" 8 | "quasiquote.zuo" 9 | "../more.zuo") 10 | 11 | (provide struct) 12 | 13 | (define-syntax struct 14 | (lambda (stx) 15 | (unless (and (list? stx) 16 | (= (length stx) 3) 17 | (identifier? (cadr stx))) 18 | (bad-syntax stx)) 19 | (define name (cadr stx)) 20 | (define fields (cadr (cdr stx))) 21 | (unless (and (list? fields) 22 | (andmap identifier? fields)) 23 | (bad-syntax stx)) 24 | (define key `(,(quote-syntax quote) 25 | ,(string->uninterned-symbol (symbol->string (syntax-e name))))) 26 | (define name? (string->symbol (datum->syntax name (~a (syntax-e name) "?")))) 27 | `(,(quote-syntax begin) 28 | (,(quote-syntax define) ,name 29 | (,(quote-syntax lambda) 30 | ,fields 31 | (,(quote-syntax opaque) ,key 32 | (,(quote-syntax list) ,@fields)))) 33 | (,(quote-syntax define) (,name? v) (,(quote-syntax and) 34 | (,(quote-syntax opaque-ref) ,key v #f) 35 | #t)) 36 | ,@(let loop ([fields fields] [index 0]) 37 | (cond 38 | [(null? fields) '()] 39 | [else 40 | (let ([field (car fields)]) 41 | (let ([ref (datum->syntax field (string->symbol (~a (syntax-e name) 42 | "-" 43 | (syntax-e field))))] 44 | [set (datum->syntax field (string->symbol (~a (syntax-e name) 45 | "-set-" 46 | (syntax-e field))))]) 47 | (define mk 48 | (lambda (head res) 49 | `(,(quote-syntax define) ,head 50 | (,(quote-syntax let) 51 | ([c (,(quote-syntax opaque-ref) ,key v #f)]) 52 | (,(quote-syntax if) 53 | c 54 | ,res 55 | (,(quote-syntax arg-error) 56 | (,(quote-syntax quote) ,(car head)) 57 | ,(symbol->string (syntax-e name)) 58 | v)))))) 59 | (cons 60 | `(,(quote-syntax begin) 61 | ,(mk `(,ref v) `(,(quote-syntax list-ref) c ,index)) 62 | ,(mk `(,set v a) `(,(quote-syntax opaque) ,key (,(quote-syntax list-set) c ,index a)))) 63 | (loop (cdr fields) 64 | (+ index 1)))))]))))) 65 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/syntax-error.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (provide syntax-error 4 | bad-syntax 5 | misplaced-syntax 6 | duplicate-identifier) 7 | 8 | (define syntax-error 9 | (lambda (msg stx) 10 | (error (~a msg ": " (~s (syntax->datum stx)))))) 11 | 12 | (define bad-syntax 13 | (lambda (stx) 14 | (syntax-error "bad syntax" stx))) 15 | 16 | (define misplaced-syntax 17 | (lambda (stx) 18 | (syntax-error "misplaced syntax" stx))) 19 | 20 | (define duplicate-identifier 21 | (lambda (stx) 22 | (syntax-error "duplicate identifier" stx))) 23 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/stitcher 2 | 3 | ;; Instantiates the expander for hygienic, set-of-scopes macros 4 | 5 | (define macro-protocol 'scope-sets) 6 | (define merge-bindings-export-key 'scope-sets-bindings) 7 | (define language-mod-path 'zuo/private/base-hygienic) 8 | 9 | (include "base-common/lib.zuo") 10 | (include "base-common/bind-struct.zuo") 11 | (include "base-common/state.zuo") 12 | 13 | (include "base-hygienic/syntax.zuo") 14 | 15 | (include "base-common/dynamic.zuo") 16 | (include "base-common/bind.zuo") 17 | (include "base-common/parse.zuo") 18 | (include "base-common/entry.zuo") 19 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/and-or.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/and-or.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/check-dups.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/check-dups.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/define-help.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/define-help.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/define.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/define.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/let.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/let.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (provide (all-from-out zuo/private/base-hygienic)) 4 | 5 | (include "../base-common/main.zuo") 6 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/more-syntax.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/more-syntax.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/opt-lambda.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/opt-lambda.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/quasiquote.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/quasiquote.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/struct.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/struct.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/syntax-error.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/syntax-error.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/stitcher 2 | 3 | ;; Instantiates the expander for non-hygenic-by-default macros 4 | 5 | (define macro-protocol 'defmacro) 6 | (define merge-bindings-export-key 'defmacro-bindings) 7 | (define language-mod-path 'zuo/private/base) 8 | 9 | (include "base-common/lib.zuo") 10 | (include "base-common/bind-struct.zuo") 11 | (include "base-common/state.zuo") 12 | 13 | (include "base/s-exp.zuo") 14 | 15 | (include "base-common/dynamic.zuo") 16 | (include "base-common/bind.zuo") 17 | (include "base-common/parse.zuo") 18 | (include "base-common/entry.zuo") 19 | -------------------------------------------------------------------------------- /lib/zuo/private/base/and-or.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/and-or.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/check-dups.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/check-dups.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/define-help.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/define-help.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/define.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/define.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/let.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/let.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (provide (all-from-out zuo/private/base)) 4 | 5 | (include "../base-common/main.zuo") 6 | -------------------------------------------------------------------------------- /lib/zuo/private/base/more-syntax.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/more-syntax.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/opt-lambda.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/opt-lambda.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/quasiquote.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/quasiquote.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/s-exp.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; A context is just a distinct identity used in binding tables 4 | (define (make-module-context mod-path) 5 | (string->uninterned-symbol "module")) 6 | 7 | ;; A syntactic-closure syntax object pairs a symbol with a context 8 | (define syntactic-closure-tag (string->uninterned-symbol "identifier")) 9 | (define (syntactic-closure sym ctx) (opaque syntactic-closure-tag (cons sym ctx))) 10 | (define (syntactic-closure? v) (and (opaque-ref syntactic-closure-tag v #f) #t)) 11 | (define (syntactic-closure-sym sc) (car (opaque-ref syntactic-closure-tag sc #f))) 12 | (define (syntactic-closure-ctx sc) (cdr (opaque-ref syntactic-closure-tag sc #f))) 13 | 14 | (define (identifier? v) 15 | (or (symbol? v) 16 | (syntactic-closure? v))) 17 | (define (syntax-e x) 18 | (if (symbol? x) 19 | x 20 | (syntactic-closure-sym x))) 21 | 22 | (define (datum->syntax ctx d) d) 23 | (define syntax->datum 24 | (letrec ([syntax->datum 25 | (lambda (stx) 26 | (cond 27 | [(pair? stx) (cons (syntax->datum (car stx)) 28 | (syntax->datum (cdr stx)))] 29 | [(identifier? stx) (syntax-e stx)] 30 | [else stx]))]) 31 | syntax->datum)) 32 | 33 | (define checked-syntax-e 34 | (let ([syntax-e (lambda (x) 35 | (unless (identifier? x) (arg-error 'syntax-e "syntax object" x)) 36 | (syntax-e x))]) 37 | syntax-e)) 38 | (define checked-datum->syntax 39 | (let ([datum->syntax (lambda (ctx d) 40 | (unless (identifier? ctx) (arg-error 'datum->syntax "syntax object" ctx)) 41 | d)]) 42 | datum->syntax)) 43 | (define checked-syntax->datum syntax->datum) 44 | 45 | ;; Binding information has three parts: 46 | ;; * ctx : the current binding context 47 | ;; * sym -> ctx : the per-symbol default context for plain symbols 48 | ;; * ctx -> sym -> bind : the binding table 49 | (define (make-binds ctx sym-hash ctx-hash) (cons ctx (cons sym-hash ctx-hash))) 50 | (define binds-ctx car) 51 | (define binds-sym-hash cadr) 52 | (define binds-ctx-hash cddr) 53 | (define (binds-set-ctx binds ctx) (cons ctx (cdr binds))) 54 | (define (binds-set-ctx-hash binds ctx-hash) (cons (car binds) (cons (cadr binds) ctx-hash))) 55 | 56 | (define (binds-create ht ctx) 57 | (make-binds ctx 58 | (foldl (lambda (sym sym-hash) 59 | (hash-set sym-hash sym ctx)) 60 | (hash) 61 | (hash-keys ht)) 62 | (hash ctx ht))) 63 | 64 | ;; We don't need scopes, but these functions are here to line 65 | ;; up with the set-of-scopes API 66 | (define (make-scope name) #f) 67 | (define (add-scope e scope) e) 68 | 69 | ;; Install a new binding 70 | (define (add-binding-at binds sym ctx bind) 71 | (let* ([sym-hash (binds-sym-hash binds)] 72 | [ctx-hash (binds-ctx-hash binds)]) 73 | (make-binds (binds-ctx binds) 74 | (hash-set sym-hash sym ctx) 75 | (hash-set ctx-hash ctx (hash-set (hash-ref ctx-hash ctx (hash)) sym bind))))) 76 | (define (add-binding* binds id bind) 77 | (if (symbol? id) 78 | (add-binding-at binds 79 | id (binds-ctx binds) 80 | bind) 81 | (add-binding-at binds 82 | (syntactic-closure-sym id) (syntactic-closure-ctx id) 83 | bind))) 84 | 85 | ;; Find the binding for an identifier 86 | (define (resolve-at binds sym ctx same-defn-ctx?) 87 | (and (or (not same-defn-ctx?) 88 | (eq? ctx (binds-ctx binds))) 89 | (hash-ref (hash-ref (binds-ctx-hash binds) ctx (hash)) sym #f))) 90 | (define (resolve* binds id same-defn-ctx?) 91 | (if (symbol? id) 92 | (resolve-at binds 93 | id (hash-ref (binds-sym-hash binds) id (binds-ctx binds)) 94 | same-defn-ctx?) 95 | (resolve-at binds 96 | (syntactic-closure-sym id) (syntactic-closure-ctx id) 97 | same-defn-ctx?))) 98 | 99 | (define (new-defn-context* binds) 100 | (binds-set-ctx binds (string->uninterned-symbol "def"))) 101 | 102 | ;; When we require a module, we need to pull in binding information 103 | ;; from the macro's module; the separate module contexts keep different binding 104 | ;; information from getting mixed up 105 | (define (merge-binds* binds ctx+m-binds) 106 | (let* ([ctx-hash (binds-ctx-hash binds)] 107 | [ctx (car ctx+m-binds)]) 108 | (if (hash-ref ctx-hash ctx #f) 109 | ;; must be merged already 110 | binds 111 | (let* ([m-ctx-hash (binds-ctx-hash (cdr ctx+m-binds))] 112 | [new-ctx-hash (foldl (lambda (ctx ctx-hash) 113 | (hash-set ctx-hash ctx (hash-ref m-ctx-hash ctx #f))) 114 | ctx-hash 115 | (hash-keys m-ctx-hash))]) 116 | (binds-set-ctx-hash binds new-ctx-hash))))) 117 | 118 | ;; Convert an expansion context plus bindings to mergable ctx+binds 119 | (define (make-export-merge-binds ctx binds) 120 | (cons ctx binds)) 121 | 122 | (define (bound-identifier=? a b) 123 | (unless (identifier? a) (arg-error 'bound-identifier=? "syntax object" a)) 124 | (unless (identifier? b) (arg-error 'bound-identifier=? "syntax object" b)) 125 | (or (and (syntactic-closure? a) 126 | (syntactic-closure? b) 127 | (eq? (syntactic-closure-sym a) (syntactic-closure-sym b)) 128 | (eq? (syntactic-closure-ctx a) (syntactic-closure-ctx b))) 129 | (eq? a b))) 130 | 131 | (include "../base-common/free-id-eq.zuo") 132 | 133 | ;; syntax-quote turns a symbol into a syntactic closure, and leaves everything 134 | ;; else alone; the closure captures the enclosing context where the symbol is 135 | ;; currently bound, or the module context if it's not bound 136 | (define (syntax-quote v mod-ctx binds) 137 | (letrec ([syntax-quote 138 | (lambda (v) 139 | (cond 140 | [(pair? v) (list 'cons (syntax-quote (car v)) (syntax-quote (cdr v)))] 141 | [(null? v) '()] 142 | [(symbol? v) 143 | (list 'quote (syntactic-closure v (hash-ref (binds-sym-hash binds) v mod-ctx)))] 144 | [else v]))]) 145 | (syntax-quote v))) 146 | 147 | (define (apply-macro m s ctx binds name k) 148 | (let ([proc (if (defined-macro? m) 149 | (defined-macro-proc m) 150 | (macro-implementation m))]) 151 | (k (apply-macro* proc s name (lambda (a b) (free-id=? binds a b))) 152 | binds))) 153 | 154 | ;; Convert a local macro to one that can be used as imported elsewhere 155 | (define (make-exported-macro proc ctx) 156 | (make-macro proc)) 157 | 158 | -------------------------------------------------------------------------------- /lib/zuo/private/base/struct.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/struct.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/syntax-error.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/syntax-error.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/jobserver-manager.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; Used by "../jobserver.zuo" 4 | 5 | "#lang zuo/base" 6 | (require zuo/thread) 7 | 8 | (define args (hash-ref (runtime-env) 'args)) 9 | 10 | (define stdin (fd-open-input 'stdin)) 11 | (define stdout (fd-open-output 'stdout)) 12 | 13 | (define in (fd-open-input (string->integer (list-ref args 0)))) 14 | (define out (fd-open-output (string->integer (list-ref args 1)))) 15 | 16 | ;; jobserver-manager's job is to reliably clean up on exit, 17 | ;; so disable signals 18 | (suspend-signal) 19 | 20 | (let loop ([held 0] [waiting 0]) 21 | (define ready (fd-poll (if (= 0 waiting) 22 | (list stdin) 23 | (list stdin in)))) 24 | (cond 25 | [(eq? ready stdin) 26 | (define b (fd-read stdin 1)) 27 | (cond 28 | [(eq? b eof) 29 | ;; parent has exited, so release all resources 30 | (let done-loop ([held held]) 31 | (when (> held 1) 32 | (fd-write out "x") 33 | (done-loop (- held 1))))] 34 | [(equal? b "+") 35 | ;; acquire request 36 | (cond 37 | [(> held 0) 38 | (loop held (+ waiting 1))] 39 | [else 40 | ;; acquired initial 41 | (fd-write stdout "x") 42 | (loop (+ held 1) waiting)])] 43 | [else 44 | ;; release 45 | (when (> held 1) 46 | (fd-write out "x")) 47 | (loop (- held 1) waiting)])] 48 | [else 49 | (fd-read in 1) 50 | ;; acquired 51 | (fd-write stdout "x") 52 | (loop (+ held 1) (- waiting 1))])) 53 | -------------------------------------------------------------------------------- /lib/zuo/private/list.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | ;; See note in "pair.zuo" about language choice 4 | 5 | (require "base/and-or.zuo") 6 | 7 | (provide list* 8 | list-tail 9 | map 10 | for-each 11 | foldl 12 | andmap 13 | ormap 14 | filter) 15 | 16 | (define list* 17 | (lambda (val . vals) 18 | (if (null? vals) 19 | val 20 | (cons val (apply list* vals))))) 21 | 22 | (define list-tail 23 | (lambda (l n) 24 | (unless (and (integer? n) (>= n 0)) (arg-error 'list-tail "index" n)) 25 | (letrec ([list-tail (lambda (n l) 26 | (cond 27 | [(= n 0) l] 28 | [(pair? l) (list-tail (- n 1) (cdr l))] 29 | [else (error "list-tail: encountered a non-pair" l)]))]) 30 | (list-tail n l)))) 31 | 32 | (define foldl 33 | (lambda (f init lst) 34 | (unless (procedure? f) (arg-error 'foldl "procedure" f)) 35 | (unless (list? lst) (arg-error 'foldl "list" lst)) 36 | (letrec ([foldl (lambda (accum lst) 37 | (if (null? lst) 38 | accum 39 | (foldl (f (car lst) accum) (cdr lst))))]) 40 | (foldl init lst)))) 41 | 42 | ;; Other functions could be written with `foldl`, but we write them 43 | ;; directly so that a more helpful name shows up stack traces 44 | 45 | (define map 46 | (lambda (f lst . lsts) 47 | (unless (procedure? f) (arg-error 'map "procedure" f)) 48 | (unless (list? lst) (arg-error 'map "list" lst)) 49 | (cond 50 | [(null? lsts) 51 | (letrec ([map (lambda (lst) 52 | (if (null? lst) 53 | '() 54 | (cons (f (car lst)) (map (cdr lst)))))]) 55 | (map lst))] 56 | [else 57 | (letrec ([check (lambda (lsts) 58 | (unless (null? lsts) 59 | (unless (list? (car lsts)) 60 | (arg-error 'map "list" (car lsts))) 61 | (unless (= (length lst) (length (car lsts))) 62 | (error "map: lists have different lengths" (cons lst lsts))) 63 | (check (cdr lsts))))]) 64 | (check lsts)) 65 | (let ([map1 map]) 66 | (letrec ([map (lambda (lsts) 67 | (if (null? (car lsts)) 68 | '() 69 | (cons (apply f (map1 car lsts)) 70 | (map (map1 cdr lsts)))))]) 71 | (map (cons lst lsts))))]))) 72 | 73 | (define for-each 74 | (lambda (f lst) 75 | (unless (procedure? f) (arg-error 'for-each "procedure" f)) 76 | (unless (list? lst) (arg-error 'for-each "list" lst)) 77 | (letrec ([for-each (lambda (lst) 78 | (unless (null? lst) 79 | (f (car lst)) 80 | (for-each (cdr lst))))]) 81 | (for-each lst)))) 82 | 83 | (define andmap 84 | (lambda (f lst) 85 | (unless (procedure? f) (arg-error 'andmap "procedure" f)) 86 | (unless (list? lst) (arg-error 'andmap "list" lst)) 87 | (letrec ([andmap (lambda (lst) 88 | (cond 89 | [(null? lst) #t] 90 | [(null? (cdr lst)) (f (car lst))] 91 | [else (and (f (car lst)) (andmap (cdr lst)))]))]) 92 | (andmap lst)))) 93 | 94 | (define ormap 95 | (lambda (f lst) 96 | (unless (procedure? f) (arg-error 'ormap "procedure" f)) 97 | (unless (list? lst) (arg-error 'ormap "list" lst)) 98 | (letrec ([ormap (lambda (lst) 99 | (cond 100 | [(null? lst) #f] 101 | [(null? (cdr lst)) (f (car lst))] 102 | [else (or (f (car lst)) (ormap (cdr lst)))]))]) 103 | (ormap lst)))) 104 | 105 | (define filter 106 | (lambda (f lst) 107 | (unless (procedure? f) (arg-error 'filter "procedure" f)) 108 | (unless (list? lst) (arg-error 'filter "list" lst)) 109 | (letrec ([filter (lambda (lst) 110 | (if (null? lst) 111 | '() 112 | (if (f (car lst)) 113 | (cons (car lst) (filter (cdr lst))) 114 | (filter (cdr lst)))))]) 115 | (filter lst)))) 116 | -------------------------------------------------------------------------------- /lib/zuo/private/looper.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/kernel 2 | 3 | ;; The `zuo/private/looper` language is like `zuo/kernel`, but adds 4 | ;; `letrec`, `cond`, and `let*` --- because implementing simple 5 | ;; transformations like `or` and `and` is especially tedious without 6 | ;; those. This language use is to implement `zuo/private/stitcher`. 7 | 8 | (let ([convert-var (variable 'convert)]) 9 | (let ([convert (lambda (s) ((variable-ref convert-var) s))]) 10 | (begin 11 | (variable-set! 12 | convert-var 13 | (lambda (s) 14 | (if (pair? s) 15 | (if (eq? (car s) 'letrec) 16 | (let ([no (lambda () (error (~a "letrec: bad looper syntax: " (~s s))))]) 17 | (let ([clauses (if (pair? (cdr s)) 18 | (car (cdr s)) 19 | #f)]) 20 | (if (if (list? clauses) 21 | (if (= 1 (length clauses)) 22 | (= 2 (length (car clauses))) 23 | #f) 24 | #f) 25 | (let ([id (car (car clauses))]) 26 | (let ([rhs (car (cdr (car clauses)))]) 27 | (if (if (pair? rhs) 28 | (eq? 'lambda (car rhs)) 29 | #f) 30 | (let ([var (string->uninterned-symbol "recvar")]) 31 | (list 'let 32 | (list (list var (list 'variable (list 'quote id)))) 33 | (list 'let 34 | (list (list id 35 | (list 'lambda (car (cdr rhs)) 36 | (cons (list 'variable-ref var) 37 | (car (cdr rhs)))))) 38 | (list 'begin 39 | (list variable-set! 40 | var 41 | (let ([lam (convert rhs)]) 42 | (if #t ; keep-names? 43 | (cons (car lam) 44 | (cons (car (cdr lam)) 45 | (cons (symbol->string id) 46 | (cdr (cdr lam))))) 47 | lam))) 48 | (let ([body (cdr (cdr s))]) 49 | (if (if (list? body) 50 | (pair? body) 51 | #f) 52 | (convert (if (null? (cdr body)) 53 | (car body) 54 | (cons 'begin body))) 55 | (no))))))) 56 | (no)))) 57 | (no)))) 58 | (if (eq? (car s) 'cond) 59 | (if (not (list? s)) 60 | (error (~a "cond: bad looper syntax: " (~s s))) 61 | (if (null? (cdr s)) 62 | '(void) 63 | (let ([cl (car (cdr s))]) 64 | (if (if (list? cl) 65 | (>= (length cl) 2) 66 | #f) 67 | (let ([rhs (convert (cons 'begin (cdr cl)))]) 68 | (if (null? (cdr (cdr s))) 69 | (if (eq? (car cl) 'else) 70 | rhs 71 | (list 'if (car cl) rhs '(void))) 72 | (list 'if (car cl) rhs 73 | (convert (cons 'cond (cdr (cdr s))))))) 74 | (error (~a "cond clause: bad looper syntax: " (~s cl))))))) 75 | (if (eq? (car s) 'let*) 76 | (if (if (list? s) 77 | (if (= (length s) 3) 78 | (list? (car (cdr s))) 79 | #f) 80 | #f) 81 | (let ([clauses (car (cdr s))]) 82 | (if (null? clauses) 83 | (convert (car (cdr (cdr s)))) 84 | (let ([cl (car clauses)]) 85 | (if (if (list? cl) 86 | (if (= (length cl) 2) 87 | (symbol? (car cl)) 88 | #f) 89 | #f) 90 | (convert (list 'let (list cl) 91 | (cons 'let* 92 | (cons (cdr clauses) 93 | (cdr (cdr s)))))) 94 | (error (~a "let* clause: bad looper syntax: " (~s cl))))))) 95 | (error (~a "let*: bad looper syntax: " (~s s)))) 96 | (if (eq? (car s) 'quote) 97 | s 98 | (cons (convert (car s)) 99 | (convert (cdr s))))))) 100 | (if (eq? s 'looper-eval) ; this is how we expose looper's eval to the next layer 101 | (lambda (e) (kernel-eval (convert e))) 102 | s)))) 103 | (hash 'read-and-eval 104 | (lambda (str start mod-path) 105 | (let ([es (string-read str start mod-path)]) 106 | (if (= 1 (length es)) 107 | (kernel-eval (convert (car es))) 108 | (error "looper: only one expression allowed")))))))) 109 | -------------------------------------------------------------------------------- /lib/zuo/private/main-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic/base 2 | 3 | (require zuo/hygienic/cmdline) 4 | 5 | (provide (all-from-out zuo/private/base-hygienic/main 6 | zuo/hygienic/cmdline)) 7 | -------------------------------------------------------------------------------- /lib/zuo/private/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | 3 | (require zuo/cmdline 4 | zuo/config 5 | zuo/thread 6 | zuo/build 7 | zuo/shell 8 | zuo/c 9 | zuo/glob 10 | zuo/jobserver 11 | zuo/dry-run) 12 | 13 | (provide (all-from-out zuo/private/base/main 14 | zuo/cmdline 15 | zuo/config 16 | zuo/thread 17 | zuo/build 18 | zuo/shell 19 | zuo/c 20 | zuo/glob 21 | zuo/jobserver 22 | zuo/dry-run)) 23 | -------------------------------------------------------------------------------- /lib/zuo/private/pair.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | ;; This module could be implemented in either `base` or 4 | ;; `base-hygienic`, but use use `base` to keep it faster 5 | ;; (at least for `base`-only programs) 6 | 7 | (provide caar 8 | cadr 9 | cdar 10 | cddr) 11 | 12 | (define bad 13 | (lambda (who v) 14 | (error (~a who ": not a valid argument") v))) 15 | 16 | (define caar 17 | (lambda (v) 18 | (if (pair? v) 19 | (let ([a (car v)]) 20 | (if (pair? a) 21 | (car a) 22 | (bad 'caar v))) 23 | (bad 'caar v)))) 24 | 25 | (define cadr 26 | (lambda (v) 27 | (if (pair? v) 28 | (let ([d (cdr v)]) 29 | (if (pair? d) 30 | (car d) 31 | (bad 'cadr v))) 32 | (bad 'cadr v)))) 33 | 34 | (define cdar 35 | (lambda (v) 36 | (if (pair? v) 37 | (let ([a (car v)]) 38 | (if (pair? a) 39 | (cdr a) 40 | (bad 'cdar v))) 41 | (bad 'cdar v)))) 42 | 43 | (define cddr 44 | (lambda (v) 45 | (if (pair? v) 46 | (let ([d (cdr v)]) 47 | (if (pair? d) 48 | (cdr d) 49 | (bad 'cddr v))) 50 | (bad 'cddr v)))) 51 | -------------------------------------------------------------------------------- /lib/zuo/shell.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | (require "thread.zuo") 3 | 4 | (provide shell 5 | shell/wait 6 | build-shell 7 | shell-subst) 8 | 9 | (define (shell arg . args) 10 | (call-with-command 11 | 'shell 12 | (cons arg args) 13 | (lambda (command options) 14 | (cond 15 | [(eq? (hash-ref (runtime-env) 'system-type) 'unix) 16 | (process "/bin/sh" "-c" command options)] 17 | [else 18 | (let ([cmd (build-path (hash-ref (runtime-env) 'sys-dir) "cmd.exe")]) 19 | (process cmd (~a cmd " /c \"" command "\"") (hash-set options 'exact? #t)))])))) 20 | 21 | (define (shell/wait arg . args) 22 | (call-with-command 23 | 'shell/wait 24 | (cons arg args) 25 | (lambda (command options) 26 | (unless (hash-ref options 'quiet? #f) 27 | (displayln (let ([dir (hash-ref options 'dir #f)]) 28 | (if dir 29 | (~a "cd " (string->shell dir) " && " command) 30 | command)))) 31 | (define p (shell command (hash-remove (hash-remove 32 | (hash-remove options 'quiet?) 33 | 'no-thread?) 34 | 'desc))) 35 | (if (hash-ref options 'no-thread? #f) 36 | (process-wait (hash-ref p 'process)) 37 | (thread-process-wait (hash-ref p 'process))) 38 | (unless (= 0 (process-status (hash-ref p 'process))) 39 | (error (~a (hash-ref options 'desc "shell command") " failed")))))) 40 | 41 | (define (call-with-command who args k) 42 | (let loop ([args args] [accum '()]) 43 | (cond 44 | [(null? args) 45 | (k (do-build-shell who (reverse accum)) 46 | (hash))] 47 | [(and (hash? (car args)) 48 | (null? (cdr args)) 49 | (pair? accum)) 50 | (k (do-build-shell who (reverse accum)) 51 | (car args))] 52 | [else 53 | (loop (cdr args) (cons (car args) accum))]))) 54 | 55 | (define (build-shell . strs) 56 | (do-build-shell 'build-shell strs)) 57 | 58 | (define (do-build-shell who . strs) 59 | (let ([strs (let loop ([strs strs]) 60 | (cond 61 | [(null? strs) '()] 62 | [else 63 | (let ([a (car strs)]) 64 | (cond 65 | [(string? a) (if (string=? a "") 66 | (loop (cdr strs)) 67 | (cons a (loop (cdr strs))))] 68 | [(list? a) (loop (append a (cdr strs)))] 69 | [else (arg-error who "string or list" a)]))]))]) 70 | (string-join strs))) 71 | 72 | (define (shell-subst str config) 73 | (unless (string? str) (arg-error 'shell-subst "string" str)) 74 | (unless (hash? config) (arg-error 'shell-subst "hash table" config)) 75 | (let loop ([i 0]) 76 | (cond 77 | [(> (+ i 2) (string-length str)) str] 78 | [(and (= (char "$") (string-ref str i)) 79 | (= (char "{") (string-ref str (+ i 1)))) 80 | (let ([end (let loop ([i (+ i 2)]) 81 | (cond 82 | [(= i (string-length str)) (error "didn't find closer" str)] 83 | [(= (char "}") (string-ref str i)) i] 84 | [else (loop (+ i 1))]))]) 85 | (shell-subst (~a (substring str 0 i) 86 | (let ([key (string->symbol (substring str (+ i 2) end))]) 87 | (or (hash-ref config key #f) 88 | (error "shell-subst: no substitution found for name" key))) 89 | (substring str (+ end 1))) 90 | config))] 91 | [else (loop (+ i 1))]))) 92 | -------------------------------------------------------------------------------- /local/hello.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | "Hello, world!" 4 | 5 | ;; If you don't want the quotes: 6 | ;; (alert "Hello, world!") 7 | 8 | ;; If you don't want it in blue: 9 | ;; (displayln "Hello, world!") 10 | -------------------------------------------------------------------------------- /local/repl.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | ;; Zuo is really not for interctive evaluation, but `kernel-eval` does 4 | ;; exist... 5 | 6 | (alert "REPL for single-line kernel expressions:") 7 | (define in (fd-open-input 'stdin)) 8 | (define out (fd-open-output 'stdout (hash))) 9 | (fd-write out "> ") 10 | (let loop ([pending ""]) 11 | (define line-end (let loop ([i 0]) 12 | (cond 13 | [(= i (string-length pending)) #f] 14 | [(= (string-ref pending i) (char "\n")) (+ i 1)] 15 | [else (loop (+ i 1))]))) 16 | (define (read-and-eval s) 17 | (for-each (lambda (e) 18 | (alert (~v (kernel-eval e)))) 19 | (string-read s))) 20 | (cond 21 | [line-end 22 | (read-and-eval (substring pending 0 line-end)) 23 | (fd-write out "> ") 24 | (loop (substring pending line-end (string-length pending)))] 25 | [else 26 | (define input (fd-read in 1)) 27 | (if (eq? input eof) 28 | (read-and-eval pending) 29 | (loop (~a pending input)))])) 30 | -------------------------------------------------------------------------------- /local/tree.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | ;; This module implements a simple version of the `tree` program, 4 | ;; which shows the content of a directory in tree form. 5 | 6 | ;; Another script could use this `tree` function... 7 | (provide tree) 8 | 9 | ;; ... but if this script is the main one passed to Zuo, 10 | ;; then the `main` submodule is run, which parses command-line 11 | ;; arguments and call `tree`. 12 | (module+ main 13 | ;; Imitates Racket's `command-line` form, but we have to explicitly 14 | ;; thread through `accum`, because there's no state 15 | (command-line 16 | :init (hash) ; initial accumulator (but `(hash)` is the default, anyway) 17 | :once-each 18 | ;; Each flag clause starts with the accumulator id 19 | [accum ("-a") "Include names that start with `.`" 20 | (hash-set accum 'all? #t)] 21 | [accum ("-h") "Show file sizes human-readable" 22 | (hash-set accum 'h-size? #t)] 23 | :args ([dir "."]) 24 | (lambda (accum) ; args handler as procedure to receive the accumulator 25 | (if (directory-exists? dir) 26 | (tree dir 27 | (hash-ref accum 'all? #f) 28 | (hash-ref accum 'h-size? #f)) 29 | (error (~a (hash-ref (runtime-env) 'script) 30 | ": no such directory: " 31 | dir)))))) 32 | 33 | ;; Recur using `ls` to get a directory's content 34 | (define (tree dir show-all? show-size?) 35 | (displayln dir) 36 | (let tree ([dir dir] [depth 0]) 37 | (define elems (sort (ls dir) stringmatcher ".*")]) 62 | (lambda (s) (not (dot? s))))) 63 | 64 | ;; Arithmetic is not Zuo's strong suit, since it supports only 65 | ;; 64-bit signed integers 66 | (define (human-readable n) 67 | (define (decimal n) 68 | (define d (quotient 1024 10)) 69 | (define dec (quotient (+ (modulo n 1024) (quotient d 2)) d)) 70 | (~a (quotient n (* 1024)) "." dec)) 71 | (define s 72 | (cond 73 | [(< n 1024) (~a n)] 74 | [(< n (quotient (* 1024 1024) 10)) (~a (decimal n) "K")] 75 | [else (~a (decimal (quotient n 1024)) "M")])) 76 | (if (< (string-length s) 4) 77 | (~a (substring " " (string-length s)) s) 78 | s)) 79 | -------------------------------------------------------------------------------- /main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (for-each 4 | alert 5 | (append 6 | (list "" 7 | "Welcome to Zuo!" 8 | "" 9 | "This message is from \"main.zuo\"." 10 | "" 11 | "Probably, you're seeing this message because you ran Zuo with no arguments," 12 | "in which case \"main.zuo\" in the current directory is loaded by default." 13 | "It's possible that you meant to run Zuo with \"build.zuo\" to (re)build or" 14 | "install Zuo." 15 | "" 16 | "If you want to run your own program, supply the program's path as an argument." 17 | "A program file will start with `#lang`, and most likely it starts `#lang zuo`." 18 | "Additional arguments are made available to the target program through the" 19 | "`command-line-arguments` procedure (in languages like `#lang zuo`, at least)." 20 | "" 21 | "If you want to type in a program directly, supply the empty string \"\" in" 22 | "place of a file path. You'll still need to start the program with something" 23 | "like `#lang zuo`." 24 | ""))) 25 | -------------------------------------------------------------------------------- /main.zuo.in: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | ;; @configure_input@ 3 | ;; `configure` modifies the following line: 4 | (require "@srcdir@/build.zuo") 5 | (build/command-line* targets-at at-source) 6 | -------------------------------------------------------------------------------- /tests/build-cycle.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | (require "harness.zuo") 3 | 4 | ;; This script is run by the "build.zuo" test 5 | 6 | (define (pause) 7 | (thread-process-wait 8 | (hash-ref 9 | (process (hash-ref (runtime-env) 'exe) 10 | "-c" 11 | "#lang zuo/kernel (hash)") 12 | 'process))) 13 | 14 | (define (touch fn) 15 | (error "shouldn't get to touch") 16 | (fd-close (fd-open-output fn :truncate))) 17 | 18 | (define (tmp fn) 19 | (build-path tmp-dir fn)) 20 | 21 | (define x (target (tmp "cycle-x") 22 | (lambda (path token) 23 | (pause) 24 | (rule (list z) 25 | (lambda () 26 | (touch path)))))) 27 | 28 | (define y (target (tmp "cycle-y") 29 | (lambda (path token) 30 | (pause) 31 | (rule (list x) 32 | (lambda () 33 | (touch path)))))) 34 | 35 | (define z (target (tmp "cycle-z") 36 | (lambda (path token) 37 | (pause) 38 | (rule (list y) 39 | (lambda () 40 | (touch path)))))) 41 | 42 | ;; should fail with cycle error: 43 | (build (list x y z) #f (hash 'jobs 3)) 44 | -------------------------------------------------------------------------------- /tests/build.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "build") 6 | 7 | (let () 8 | (define p (process (hash-ref (runtime-env) 'exe #f) 9 | (at-source "build-cycle.zuo") 10 | (hash 'stdin 'pipe 'stdout 'pipe 'stderr 'pipe))) 11 | (fd-close (hash-ref p 'stdin)) 12 | (define out (fd-read (hash-ref p 'stdout) eof)) 13 | (define err (fd-read (hash-ref p 'stderr) eof)) 14 | (fd-close (hash-ref p 'stdout)) 15 | (fd-close (hash-ref p 'stderr)) 16 | (process-wait (hash-ref p 'process)) 17 | 18 | (check (glob-match? "*dependency cycle*" err) #t) 19 | (check "" out)) 20 | -------------------------------------------------------------------------------- /tests/c.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "c") 6 | 7 | (check (config-merge (hash 'CFLAGS "-O2") 'CFLAGS "-g") 8 | (hash 'CFLAGS "-O2 -g")) 9 | 10 | (check (config-define (hash 'CFLAGS "-O2") "ZUO") 11 | (hash 'CFLAGS "-O2" 'CPPFLAGS "-DZUO")) 12 | 13 | (check (config-define (hash 'CPPFLAGS "-DSLOW") "ZUO") 14 | (hash 'CPPFLAGS "-DSLOW -DZUO")) 15 | 16 | (check (config-include (hash 'CPPFLAGS "-DSLOW") "zuo/private") 17 | (hash 'CPPFLAGS "-DSLOW -Izuo/private")) 18 | -------------------------------------------------------------------------------- /tests/cleanable.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "cleanables") 6 | 7 | (define adios-file (build-path tmp-dir "adios.txt")) 8 | 9 | (define (check-cleaned pre post expect-status expect-exist?) 10 | (run-zuo* '("") 11 | (~a "#lang zuo\n" 12 | (~s 13 | `(begin 14 | ,@pre 15 | (define cl (cleanable-file ,adios-file)) 16 | ,@post))) 17 | (lambda (status out err) 18 | (check status expect-status))) 19 | (check (file-exists? adios-file) expect-exist?)) 20 | 21 | (fd-close (fd-open-output adios-file :truncate)) 22 | (check-cleaned '() 23 | '() 24 | 0 25 | #f) 26 | (check-cleaned `((void (fd-open-output ,adios-file :truncate))) 27 | '() 28 | 0 29 | #f) 30 | (check-cleaned `((void (fd-open-output ,adios-file :truncate))) 31 | '((car '())) 32 | 1 33 | #f) 34 | (check-cleaned `((void (fd-open-output ,adios-file :truncate))) 35 | '((cleanable-cancel cl)) 36 | 0 37 | #t) 38 | 39 | ;; check that a process doesn't exit before a subprocess, 40 | ;; even when it doesn't explicitly wait, or that it does exit 41 | ;; in no-wait mode 42 | (define (check-sub no-wait?) 43 | (define sub.zuo (build-path tmp-dir "sub.zuo")) 44 | (define inner.zuo (build-path tmp-dir "inner.zuo")) 45 | (let ([o (fd-open-output sub.zuo :truncate)]) 46 | (fd-write o (~a "#lang zuo\n" 47 | (~s `(void (process (hash-ref (runtime-env) 'exe) 48 | ,inner.zuo 49 | ,(if no-wait? 50 | '(hash 'cleanable? #f) 51 | '(hash))))))) 52 | (fd-close o)) 53 | (let ([o (fd-open-output inner.zuo :truncate)]) 54 | (fd-write o (~a "#lang zuo\n" 55 | (~s `(let ([in (fd-open-input 'stdin)] 56 | [out (fd-open-output 'stdout)]) 57 | (define s (fd-read in 1)) 58 | (fd-write out s) 59 | (fd-read in 1))))) 60 | (fd-close o)) 61 | (define p (process (hash-ref (runtime-env) 'exe) 62 | sub.zuo 63 | (hash 'stdin 'pipe 'stdout 'pipe))) 64 | (define to (hash-ref p 'stdin)) 65 | (define from (hash-ref p 'stdout)) 66 | (cond 67 | [no-wait? (process-wait (hash-ref p 'process))] 68 | [else (check (process-status (hash-ref p 'process)) 'running)]) 69 | (fd-write to "x") 70 | (check (fd-read from 1) "x") 71 | (unless no-wait? 72 | (check (process-status (hash-ref p 'process)) 'running)) 73 | (fd-write to "y") 74 | (process-wait (hash-ref p 'process)) 75 | (check (process-status (hash-ref p 'process)) 0)) 76 | 77 | (check-sub #f) 78 | (check-sub #f) 79 | (check-sub #t) 80 | 81 | (check-arg-fail (cleanable-file 10) not-path) 82 | (check-arg-fail (cleanable-cancel 10) "cleanable handle") 83 | -------------------------------------------------------------------------------- /tests/config.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "config") 6 | 7 | (define Mf-config (build-path tmp-dir "Mf-config")) 8 | 9 | (define (config->hash content [overrides (hash)]) 10 | (display-to-file content Mf-config :truncate) 11 | (config-file->hash Mf-config overrides)) 12 | 13 | (check (config->hash "") (hash)) 14 | (check (config->hash "" (hash 'X "x")) (hash 'X "x")) 15 | (check (config->hash "This is not a confg line" (hash 'X "x")) (hash 'X "x")) 16 | (check (config->hash "Comment # no=6" (hash 'X "x")) (hash 'X "x")) 17 | 18 | (check (config->hash "X=5") (hash 'X "5")) 19 | (check (config->hash "X =5") (hash 'X "5")) 20 | (check (config->hash "X= 5 ") (hash 'X "5")) 21 | (check (config->hash " X = 5 ") (hash 'X "5")) 22 | (check (config->hash "\n\n X = 5 \n\n") (hash 'X "5")) 23 | (check (config->hash "X = 5\\\n1") (hash 'X "51")) 24 | 25 | (check (config->hash "X_1=5") (hash 'X_1 "5")) 26 | (check (config->hash "abcdefg_ZXSGFH_=5") (hash 'abcdefg_ZXSGFH_ "5")) 27 | (check (config->hash "123=5") (hash (string->symbol "123") "5")) 28 | (check (config->hash "1%23=5") (hash)) 29 | (check (config->hash "x%23=5") (hash)) 30 | 31 | (check (config->hash "X=5\nY=8") (hash 'X "5" 'Y "8")) 32 | (check (config->hash "X=5\nX=8") (hash 'X "8")) 33 | (check (config->hash "X=5\nX=8" (hash 'X "0")) (hash 'X "0")) 34 | (check (config->hash "X=5\nY=8" (hash 'X "0")) (hash 'X "0" 'Y "8")) 35 | 36 | (check (config->hash "X=5 # Comment after") (hash 'X "5")) 37 | (check (config->hash "X=5 # Comment after\nY=8") (hash 'X "5" 'Y "8")) 38 | (check (config->hash "X=5 \\# 7") (hash 'X "5 # 7")) 39 | (check (config->hash "X=5 \\\\# 7") (hash 'X "5 \\# 7")) 40 | (check (config->hash "X=5# \\\\# 7") (hash 'X "5")) 41 | (check (config->hash "X=# # #") (hash 'X "")) 42 | (check (config->hash "X = 5\\\n# 1 \\\n 2") (hash 'X "5")) 43 | (check (config->hash "X = 5\\\n 1 \\\n 2") (hash 'X "5 1 2")) 44 | 45 | (rm* Mf-config) 46 | -------------------------------------------------------------------------------- /tests/cycle.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "cycle") 6 | 7 | (define cycle-file (build-path tmp-dir "cycle.zuo")) 8 | 9 | (define out (fd-open-output cycle-file :truncate)) 10 | (fd-write out (~a "#lang zuo\n" 11 | "(require \"cycle.zuo\")\n")) 12 | (fd-close out) 13 | 14 | (check (run-zuo `(require ,(if (relative-path? cycle-file) 15 | (build-path (hash-ref (runtime-env) 'dir) cycle-file) 16 | cycle-file)) 17 | (lambda (status out err) 18 | (and (not (= status 0)) 19 | (equal? out "") 20 | (contains? err "cycle in module loading"))))) 21 | 22 | -------------------------------------------------------------------------------- /tests/equal.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | ;; We need certain things to work for checking even to work, but all 6 | ;; we can do is assume that things work... 7 | 8 | (alert "equal") 9 | 10 | (check #t) 11 | (check (not #f)) 12 | (check (eq? 'apple 'apple)) 13 | (check (not (eq? 'apple 'banana))) 14 | (check (not (eq? 'apple "apple"))) 15 | 16 | (check (string=? "apple" "apple")) 17 | (check (not (string=? "apple" "banana"))) 18 | (check (string-ci=? "apple" "aPPle")) 19 | (check (not (string-ci=? "apple" "banana"))) 20 | 21 | (check (= 1 1)) 22 | (check (not (= 1 -1))) 23 | 24 | (check (equal? 1 1)) 25 | (check (equal? "apple" "apple")) 26 | 27 | (check (equal? "apple" "apple")) 28 | (check (equal? '("apple") '("apple"))) 29 | (check (equal? '(0 "apple") '(0 "apple"))) 30 | (check (not (equal? '("apple") '("banana")))) 31 | (check (not (equal? '(0 "apple") '(0 "banana")))) 32 | 33 | (check (equal? (hash 'a 1) (hash 'a 1))) 34 | (check (not (equal? (hash 'a 1) (hash 'b 1)))) 35 | (check (not (equal? (hash 'a 1) (hash 'a 2)))) 36 | 37 | (check (not (equal? "apple" 'other))) 38 | (check (not (equal? 'other "apple"))) 39 | (check (not (equal? 1 'other))) 40 | (check (not (equal? 'other 1))) 41 | (check (not (equal? 1 (hash 'a 1)))) 42 | (check (not (equal? (hash 'a 1) 1))) 43 | 44 | (check-fail (= 1 'apple) not-integer) 45 | (check-fail (= 'apple 1) not-integer) 46 | (check-arg-fail (string=? 1 "apple") not-string) 47 | (check-arg-fail (string=? "apple" 1) not-string) 48 | (check-arg-fail (string-ci=? 1 "apple") not-string) 49 | (check-arg-fail (string-ci=? "apple" 1) not-string) 50 | 51 | (check (eq? (void) (void))) 52 | (check (void? (void))) 53 | (check (not (void? 'void))) 54 | -------------------------------------------------------------------------------- /tests/example-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (include "example-common.zuo") 4 | -------------------------------------------------------------------------------- /tests/example.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (include "example-common.zuo") 4 | -------------------------------------------------------------------------------- /tests/fib-common.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; The classic toy benchmark 4 | (provide fib) 5 | 6 | (define input 7 | (let ([args (hash-ref (runtime-env) 'args)]) 8 | (if (null? args) 9 | 30 10 | (string->integer (car args))))) 11 | 12 | (define (fib n) 13 | (cond 14 | [(= n 0) 1] 15 | [(= n 1) 1] 16 | [else (+ (fib (- n 1)) (fib (- n 2)))])) 17 | 18 | (fib input) 19 | -------------------------------------------------------------------------------- /tests/fib-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | ;; Performance should be the same as the non-hygienic parsing, but we 4 | ;; may want to check on the startup overhead of `zuo/hygienic` 5 | 6 | (include "fib-common.zuo") 7 | -------------------------------------------------------------------------------- /tests/fib.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (include "fib-common.zuo") 4 | -------------------------------------------------------------------------------- /tests/filesystem.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "filesystem") 6 | 7 | (check (hash? (stat tmp-dir #f))) 8 | (check (stat (build-path tmp-dir "nonesuch.txt") #f) #f) 9 | 10 | (let ([s (stat tmp-dir #f)]) 11 | (check (hash-ref s 'type) 'dir)) 12 | (check (directory-exists? tmp-dir)) 13 | (check (file-exists? tmp-dir) #f) 14 | (check (link-exists? tmp-dir) #f) 15 | (check-arg-fail (stat 10) not-path) 16 | 17 | (define now (current-time)) 18 | 19 | (define exists.txt (build-path tmp-dir "exists.txt")) 20 | (let ([fd (fd-open-output exists.txt :truncate)]) 21 | (fd-write fd "xyz") 22 | (fd-close fd)) 23 | 24 | (define exists2.txt (build-path tmp-dir "exists2.txt")) 25 | (fd-close (fd-open-output exists2.txt :can-update)) 26 | 27 | (check (file-exists? exists.txt)) 28 | (check (file-exists? exists2.txt)) 29 | (check (directory-exists? exists2.txt) #f) 30 | (check (link-exists? exists2.txt) #f) 31 | 32 | (check-arg-fail (file-exists? 10) not-path) 33 | (check-arg-fail (directory-exists? 10) not-path) 34 | (check-arg-fail (link-exists? 10) not-path) 35 | 36 | (let ([s (stat exists.txt #f)]) 37 | (check (hash? s)) 38 | (check (hash-ref s 'type) 'file) 39 | (check (hash-ref s 'size) 3) 40 | ;; Seems to be too precise for some Linux configurations: 41 | #; 42 | (check (or (> (hash-ref s 'modify-time-seconds) (car now)) 43 | (and (= (hash-ref s 'modify-time-seconds) (car now)) 44 | (>= (hash-ref s 'modify-time-nanoseconds) (cdr now))))) 45 | (check (>= (hash-ref s 'modify-time-seconds) (car now))) 46 | (let ([s2 (stat exists.txt #t)]) 47 | (check s s2)) 48 | (let ([s2 (stat exists2.txt #t)]) 49 | (check (hash? s2)) 50 | (check (not (equal? (hash-ref s 'inode) (hash-ref s2 'inode)))) 51 | (check (equal? (hash-ref s 'device-id) (hash-ref s2 'device-id))))) 52 | 53 | (let ([l (ls tmp-dir)]) 54 | (check (pair? (member "exists.txt" l))) 55 | (check (pair? (member "exists2.txt" l)))) 56 | (check-arg-fail (ls 10) not-path) 57 | 58 | (rm exists2.txt) 59 | (check (stat exists2.txt #t) #f) 60 | (check (member "exists2.txt" (ls tmp-dir)) #f) 61 | 62 | (define sub-dir (build-path tmp-dir "sub")) 63 | (rm* sub-dir) 64 | 65 | (check (directory-exists? sub-dir) #f) 66 | (check (mkdir sub-dir) (void)) 67 | (check (directory-exists? sub-dir)) 68 | (check-arg-fail (mkdir 10) not-path) 69 | 70 | (define sub-sub-dir (build-path sub-dir "subsub")) 71 | (check (directory-exists? sub-sub-dir) #f) 72 | (check (mkdir sub-sub-dir) (void)) 73 | (check (directory-exists? sub-sub-dir)) 74 | (check (rmdir sub-sub-dir) (void)) 75 | (check (directory-exists? sub-sub-dir) #f) 76 | (check (mkdir sub-sub-dir) (void)) 77 | 78 | (fd-close (fd-open-output (build-path sub-sub-dir "apple") :can-update)) 79 | (fd-close (fd-open-output (build-path sub-sub-dir "banana") :can-update)) 80 | (fd-close (fd-open-output (build-path sub-sub-dir "cherry") :can-update)) 81 | (fd-close (fd-open-output (build-path sub-dir "donut") :can-update)) 82 | 83 | (check (length (ls sub-dir)) 2) 84 | (check (length (ls sub-sub-dir)) 3) 85 | 86 | (check (void? (mv (build-path sub-sub-dir "banana") 87 | (build-path sub-dir "banana")))) 88 | (check (length (ls sub-dir)) 3) 89 | (check (length (ls sub-sub-dir)) 2) 90 | (check (void? (mv (build-path sub-dir "banana") 91 | (build-path sub-sub-dir "eclair")))) 92 | (let ([l (ls sub-sub-dir)]) 93 | (check (pair? (member "apple" l))) 94 | (check (pair? (member "cherry" l))) 95 | (check (pair? (member "eclair" l))) 96 | (check (not (member "banana" l)))) 97 | (check-arg-fail (mv 10 "x") not-path) 98 | (check-arg-fail (mv "x" 10) not-path) 99 | 100 | (check-fail (rm ,sub-dir) "failed") 101 | (check-arg-fail (rm 10) not-path) 102 | 103 | (rm* sub-dir) 104 | (check (directory-exists? sub-sub-dir) #f) 105 | (check (directory-exists? sub-dir) #f) 106 | (check-arg-fail (rm* 10) not-path) 107 | 108 | (mkdir-p sub-sub-dir) 109 | (check (directory-exists? sub-sub-dir)) 110 | (check (directory-exists? sub-dir)) 111 | (check-arg-fail (mkdir-p 10) not-path) 112 | 113 | (when (eq? 'unix (hash-ref (runtime-env) 'system-type)) 114 | (let ([fd (fd-open-output (build-path sub-dir "high") :can-update)]) 115 | (fd-write fd "HIGH") 116 | (fd-close fd)) 117 | (let ([fd (fd-open-output (build-path sub-sub-dir "low") :can-update)]) 118 | (fd-write fd "LOW") 119 | (fd-close fd)) 120 | (define (get path) 121 | (let ([fd (fd-open-input path)]) 122 | (define v (fd-read fd eof)) 123 | (fd-close fd) 124 | v)) 125 | (symlink "low" (build-path sub-sub-dir "below")) 126 | (check (get (build-path sub-sub-dir "below")) "LOW") 127 | (check (readlink (build-path sub-sub-dir "below")) "low") 128 | (check (hash-ref (stat (build-path sub-sub-dir "below") #f) 'type) 'link) 129 | (check (hash-ref (stat (build-path sub-sub-dir "below") #t) 'type) 'file) 130 | (check (link-exists? (build-path sub-sub-dir "below"))) 131 | (check (rm (build-path sub-sub-dir "below")) (void)) 132 | (check (get (build-path sub-sub-dir "low")) "LOW") 133 | 134 | (symlink "../high" (build-path sub-sub-dir "above")) 135 | (check (get (build-path sub-sub-dir "above")) "HIGH") 136 | (check (readlink (build-path sub-sub-dir "above")) "../high") 137 | (check (rm (build-path sub-sub-dir "above")) (void)) 138 | (check (get (build-path sub-dir "high")) "HIGH") 139 | 140 | (symlink ".." (build-path sub-sub-dir "again")) 141 | (check (link-exists? (build-path sub-sub-dir "again"))) 142 | (check (hash-ref (stat (build-path sub-sub-dir "again") #f) 'type) 'link) 143 | (check (hash-ref (stat (build-path sub-sub-dir "again") #t) 'type) 'dir) 144 | (check (get (build-path sub-sub-dir "again" "high")) "HIGH") 145 | (check (get (build-path sub-sub-dir "again" "subsub" "low")) "LOW") 146 | (check (ls sub-dir) (ls (build-path sub-sub-dir "again"))) 147 | 148 | (rm* sub-sub-dir) 149 | (check (get (build-path sub-dir "high")) "HIGH") 150 | 151 | (void)) 152 | 153 | (check-arg-fail (readlink 10) not-path) 154 | (check-arg-fail (symlink 10 "a") not-path) 155 | (check-arg-fail (symlink "a" 10) not-path) 156 | 157 | (rm* sub-dir) 158 | 159 | (check (cp exists.txt exists2.txt) (void)) 160 | (check (equal? (hash-ref (stat exists.txt) 'mode) 161 | (hash-ref (stat exists2.txt) 'mode))) 162 | (check (file-exists? exists.txt)) 163 | (check (file-exists? exists2.txt)) 164 | (check (cp exists.txt exists2.txt (hash 'replace-mode #f)) (void)) 165 | (check (cp exists.txt exists2.txt :no-replace-mode) (void)) 166 | 167 | (check-arg-fail (cp "exists.txt" "exists2.txt" 'oops) "not a hash") 168 | (check-arg-fail (cp "exists.txt" "exists2.txt" (hash 'mode 'oops)) "not an integer") 169 | (check-arg-fail (cp "exists.txt" "exists2.txt" (hash 'other 0)) "unrecognized or unused option") 170 | -------------------------------------------------------------------------------- /tests/form-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (require "harness-hygienic.zuo") 4 | 5 | (alert "syntactic forms, hygienic expander") 6 | 7 | (include "form-common.zuo") 8 | -------------------------------------------------------------------------------- /tests/form.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "syntactic forms") 6 | 7 | (include "form-common.zuo") 8 | -------------------------------------------------------------------------------- /tests/glob.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "glob") 6 | 7 | (check (glob-match? "apple" "apple")) 8 | (check (glob-match? "apple" "banana") #f) 9 | 10 | (check (glob-match? "" "")) 11 | (check (glob-match? "" "x") #f) 12 | (check (glob-match? "x" "") #f) 13 | 14 | (check (glob-match? "a*le" "apple")) 15 | (check (glob-match? "a*le" "ale")) 16 | (check (glob-match? "a*le" "aple")) 17 | (check (glob-match? "a*le" "a//p//le")) 18 | (check (glob-match? "a*le" "appe") #f) 19 | (check (glob-match? "a*le" "pple") #f) 20 | 21 | (check (glob-match? "a*?le" "apple")) 22 | (check (glob-match? "a*?le" "aple")) 23 | (check (glob-match? "a*?le" "ale") #f) 24 | 25 | (check (glob-match? "*le" "apple")) 26 | (check (glob-match? "*le" ".apple")) 27 | 28 | (check (glob-match? "*le" "apple")) 29 | (check (glob-match? "*le" ".apple")) 30 | 31 | (check (glob-match? "x[a-c]x" "x0x") #f) 32 | (check (glob-match? "x[a-c]x" "xax")) 33 | (check (glob-match? "x[a-c]x" "xbx")) 34 | (check (glob-match? "x[a-c]x" "xcx")) 35 | (check (glob-match? "x[a-c]x" "xdx") #f) 36 | (check (glob-match? "x[a-c]x" "x[x") #f) 37 | (check (glob-match? "x[a-c]x" "x]x") #f) 38 | 39 | (check (glob-match? "x[0-9][A-Z]x" "x0Ax")) 40 | (check (glob-match? "x[0-9][A-Z]x" "x9Zx")) 41 | (check (glob-match? "x[0-9][A-Z]x" "xA0x") #f) 42 | 43 | (check (glob-match? "x[0-9a]x" "x0x")) 44 | (check (glob-match? "x[0-9a]x" "xax")) 45 | (check (glob-match? "x[0-9a]x" "xbx") #f) 46 | (check (glob-match? "x[0-9a]x" "x-x") #f) 47 | (check (glob-match? "x[-0-9a]x" "x-x")) 48 | (check (glob-match? "x[0-9a-]x" "x-x")) 49 | (check (glob-match? "x[]0-9a]x" "x]x")) 50 | (check (glob-match? "x[]0-9a]x" "x0x")) 51 | (check (glob-match? "x[]0-9a]x" "x[x") #f) 52 | (check (glob-match? "x[a-]x" "x-x")) 53 | (check (glob-match? "x[a-]x" "x.x") #f) 54 | 55 | (check (glob-match? "x[^0-9a]x" "x_x")) 56 | (check (glob-match? "x[^0-9a]x" "x0x") #f) 57 | (check (glob-match? "x[^0-9a]x" "x5x") #f) 58 | (check (glob-match? "x[^0-9a]x" "x9x") #f) 59 | (check (glob-match? "x[^0-9a]x" "xax") #f) 60 | (check (glob-match? "x[^0-9a]x" "xbx")) 61 | (check (glob-match? "x[^0-9a]x" "xbx")) 62 | (check (glob-match? "x[^^]x" "xbx")) 63 | (check (glob-match? "x[^^]x" "x^x") #f) 64 | (check (glob-match? "x[^-]x" "x-x") #f) 65 | (check (glob-match? "x[^x]x" "x-x")) 66 | (check (glob-match? "x[^]]x" "x]x") #f) 67 | (check (glob-match? "x[^]]x" "x-x")) 68 | 69 | (check (glob-match? "**e" "apple")) 70 | (check (glob-match? "**" "apple")) 71 | (check (glob-match? "**z" "apple") #f) 72 | 73 | (check (procedure? (glob->matcher "a*c"))) 74 | (check ((glob->matcher "a*c") "abxyzc")) 75 | 76 | (define-syntax (check-glob-fail stx) 77 | `(check-fail (begin 78 | (require zuo/glob) 79 | ,(cadr stx)) 80 | ,(list-ref stx 2))) 81 | 82 | (check-glob-fail (glob-match? 10 "a") not-string) 83 | (check-glob-fail (glob-match? "a" 10) not-string) 84 | (check-glob-fail (glob->matcher 10) not-string) 85 | (check-glob-fail (glob->matcher "[") "unclosed square bracket") 86 | (check-glob-fail (glob->matcher "[]") "unclosed square bracket") 87 | (check-glob-fail (glob->matcher "[^]") "unclosed square bracket") 88 | (check-glob-fail (glob->matcher "[z-a]") "bad range") 89 | -------------------------------------------------------------------------------- /tests/harness-common.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (provide check 4 | check-fail 5 | check-fail* 6 | check-arg-fail 7 | check-output 8 | 9 | run-zuo* 10 | run-zuo 11 | contains? 12 | 13 | bad-stx 14 | arity 15 | not-integer 16 | not-string 17 | not-path 18 | 19 | tmp-dir) 20 | 21 | (define (check* e a b) 22 | (unless (equal? a b) 23 | (error (~a "failed: " 24 | (~s e) 25 | "\n result: " (~v a) 26 | "\n result: " (~v b))))) 27 | 28 | (define-syntax (check stx) 29 | (unless (list? stx) (bad-syntax stx)) 30 | (list* (quote-syntax check*) 31 | (list (quote-syntax quote) stx) 32 | (let ([len (length (cdr stx))]) 33 | (cond 34 | [(= 1 len) (cons #t (cdr stx))] 35 | [(= 2 len) (cdr stx)] 36 | [else (bad-syntax stx)])))) 37 | 38 | (define (run-zuo* args input k) 39 | (define p (apply process 40 | (cons (hash-ref (runtime-env) 'exe #f) 41 | (append args 42 | (list (hash 'stdin 'pipe 'stdout 'pipe 'stderr 'pipe)))))) 43 | (fd-write (hash-ref p 'stdin) input) 44 | (fd-close (hash-ref p 'stdin)) 45 | (define out (fd-read (hash-ref p 'stdout) eof)) 46 | (define err (fd-read (hash-ref p 'stderr) eof)) 47 | (fd-close (hash-ref p 'stdout)) 48 | (fd-close (hash-ref p 'stderr)) 49 | (process-wait (hash-ref p 'process)) 50 | (k (process-status (hash-ref p 'process)) out err)) 51 | 52 | (define (run-zuo e k) 53 | (run-zuo* '("") (~a "#lang " language-name " " (~s e)) k)) 54 | 55 | (define (contains? err msg) 56 | (let loop ([i 0]) 57 | (and (not (> i (- (string-length err) (string-length msg)))) 58 | (or (string=? (substring err i (+ i (string-length msg))) msg) 59 | (loop (+ i 1)))))) 60 | 61 | (define (check-fail* e who msg) 62 | (run-zuo 63 | e 64 | (lambda (status out err) 65 | (when (= 0 status) 66 | (error (~a "check-fail: failed to fail: " (~s e) 67 | "\n stdout: " (~s out) 68 | "\n stderr: " (~s err)))) 69 | (unless (contains? err msg) 70 | (error (~a "check-fail: didn't find expected message: " (~s e) 71 | "\n expected: " (~s msg) 72 | "\n stderr: " (~s err)))) 73 | (when who 74 | (let* ([who (symbol->string who)] 75 | [len (string-length who)]) 76 | (unless (and (> (string-length err) len) 77 | (string=? (substring err 0 len) who)) 78 | (error (~a "check-fail: didn't find expected who: " (~s e) 79 | "\n expected: " who 80 | "\n stderr: " (~s err))))))))) 81 | 82 | (define-syntax (check-fail stx) 83 | (unless (and (list? stx) (= 3 (length stx))) (bad-syntax stx)) 84 | (list (quote-syntax check-fail*) 85 | (list (quote-syntax quasiquote) (cadr stx)) 86 | #f 87 | (cadr (cdr stx)))) 88 | 89 | (define-syntax (check-arg-fail stx) 90 | (unless (and (list? stx) (= 3 (length stx)) 91 | (pair? (cadr stx)) (identifier? (car (cadr stx)))) 92 | (bad-syntax stx)) 93 | (list (quote-syntax check-fail*) 94 | (list (quote-syntax quasiquote) (cadr stx)) 95 | (list (quote-syntax quote) (car (cadr stx))) 96 | (cadr (cdr stx)))) 97 | 98 | (define (check-output* e stdout stderr) 99 | (run-zuo 100 | e 101 | (lambda (status out err) 102 | (unless ((if (equal? stderr "") (lambda (v) v) not) 103 | (= 0 status)) 104 | (error (~a "check-output: process failed: " (~s e) 105 | "\n stdout: " (~s out) 106 | "\n stderr: " (~s err)))) 107 | (unless (and (equal? out stdout) 108 | (equal? err stderr)) 109 | (error (~a "check-output: process failed: " (~s e) 110 | "\n stdout: " (~s out) 111 | "\n expect: " (~s stdout) 112 | "\n stderr: " (~s err) 113 | "\n expect: " (~s stderr))))))) 114 | 115 | (define-syntax (check-output stx) 116 | (unless (list? stx) (bad-syntax stx)) 117 | (cond 118 | [(= 3 (length stx)) 119 | (list (quote-syntax check-output*) 120 | (list (quote-syntax quote) (cadr stx)) 121 | (list-ref stx 2) 122 | "")] 123 | [(= 4 (length stx)) 124 | (list (quote-syntax check-output*) 125 | (list (quote-syntax quote) (cadr stx)) 126 | (list-ref stx 2) 127 | (list-ref stx 3))] 128 | [else (bad-syntax stx)])) 129 | 130 | ;; Some common error messages 131 | (define bad-stx "bad syntax") 132 | (define arity "wrong number of arguments") 133 | (define not-integer "not an integer") 134 | (define not-string "not a string") 135 | (define not-path "not a path string") 136 | 137 | (define tmp-dir (build-path (car (split-path (quote-module-path))) ".." "build" "tmp")) 138 | (mkdir-p tmp-dir) 139 | -------------------------------------------------------------------------------- /tests/harness-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (define language-name 'zuo/hygienic) 4 | 5 | (include "harness-common.zuo") 6 | -------------------------------------------------------------------------------- /tests/harness.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (define language-name 'zuo/base) 4 | 5 | (include "harness-common.zuo") 6 | -------------------------------------------------------------------------------- /tests/hash.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "hash tables") 6 | 7 | (check (hash? (hash))) 8 | (check (not (hash? 'apple))) 9 | 10 | (check (hash-ref (hash 'a 1) 'a #f) 1) 11 | (check (hash-ref (hash 'a 1) 'b #f) #f) 12 | (check (hash-ref (hash 'a 1) 'b 'no) 'no) 13 | (check-arg-fail (hash-ref 0 0 0) "not a hash table") 14 | (check-arg-fail (hash-ref (hash) 0 0) "not a symbol") 15 | 16 | (check (hash-set (hash 'a 1) 'b 2) (hash 'a 1 'b 2)) 17 | (check (hash-ref (hash-set (hash 'a 1) 'b 2) 'a #f) 1) 18 | (check (hash-ref (hash-set (hash 'a 1) 'b 2) 'b #f) 2) 19 | (check (hash-ref (hash-set (hash 'a 1) 'b 2) 'c #f) #f) 20 | (check-arg-fail (hash-set 0 0 0) "not a hash table") 21 | (check-arg-fail (hash-set (hash) 0 0) "not a symbol") 22 | 23 | (check (hash-remove (hash 'a 1) 'a) (hash)) 24 | (check (hash-remove (hash 'a 1) 'b) (hash 'a 1)) 25 | (check (hash-remove (hash 'a 1 'b 2) 'a) (hash 'b 2)) 26 | (check (hash-ref (hash-remove (hash 'a 1) 'a) 'a #f) #f) 27 | (check-arg-fail (hash-remove 0 0) "not a hash table") 28 | (check-arg-fail (hash-remove (hash) 0) "not a symbol") 29 | 30 | (check (hash-count (hash)) 0) 31 | (check (hash-count (hash 'a 1 'a 2 'b 3)) 2) 32 | (check (hash-count (hash-set (hash 'a 1 'b 3) 'c 3)) 3) 33 | (check (hash-count (hash-remove (hash 'a 1 'b 3) 'b)) 1) 34 | (check-arg-fail (hash-count 0) "not a hash table") 35 | 36 | (check (hash-keys (hash)) '()) 37 | (check (hash-keys (hash 'a 1)) '(a)) 38 | (check (hash-keys (hash 'a 1 'b 2)) '(a b)) ; always in order 39 | (check (length (hash-keys (hash 'a 1 'b 2 'c 3))) 3) 40 | (check (length (hash-keys (hash 'a 1 'b 2 'a 3))) 2) 41 | (check-arg-fail (hash-keys 0) "not a hash table") 42 | 43 | (check (hash-keys-subset? (hash) (hash 'a 1)) #t) 44 | (check (hash-keys-subset? (hash 'a 1) (hash)) #f) 45 | (check (hash-keys-subset? (hash 'a 1) (hash 'a 1 'b 2)) #t) 46 | (check (hash-keys-subset? (hash 'b 2) (hash 'a 1 'b 2)) #t) 47 | (check (hash-keys-subset? (hash 'a 1 'b 2) (hash 'a 1)) #f) 48 | (check (hash-keys-subset? (hash 'a 1 'b 2) (hash 'b 1)) #f) 49 | (check-arg-fail (hash-keys-subset? 0 (hash)) "not a hash table") 50 | (check-arg-fail (hash-keys-subset? (hash) 0) "not a hash table") 51 | 52 | ;; print sorts keys alphabetically: 53 | (check (~a (hash 'a 1 'b 2)) "#hash((a . 1) (b . 2))") 54 | (check (~a (hash 'b 2 'a 1)) "#hash((a . 1) (b . 2))") 55 | -------------------------------------------------------------------------------- /tests/image.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "image") 6 | 7 | (define dump.zuo (build-path tmp-dir "dump.zuo")) 8 | (define image-file (build-path tmp-dir "image.boot")) 9 | 10 | (define (try-dump lang) 11 | (define out (fd-open-output dump.zuo :truncate)) 12 | (fd-write out (~a "#lang " lang "\n" 13 | "(dump-image-and-exit (fd-open-output (car (hash-ref (runtime-env) 'args)) :truncate))\n")) 14 | (fd-close out) 15 | 16 | (check (run-zuo* (list dump.zuo image-file) 17 | "" 18 | (lambda (status out err) 19 | (= status 0)))) 20 | (run-zuo* (list "-X" "" "-B" image-file "") 21 | (~a "#lang " lang " 10") 22 | (lambda (status out err) 23 | (check err "") 24 | (check (and (= status 0) lang) lang) 25 | (check out "10\n")))) 26 | 27 | (try-dump "zuo") 28 | (try-dump "zuo/hygienic") 29 | 30 | (check-arg-fail (dump-image-and-exit "oops") "open output file") 31 | -------------------------------------------------------------------------------- /tests/integer.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "predicate") 6 | 7 | (check (integer? 10)) 8 | (check (not (integer? 'a))) 9 | (check (not (integer? '(1 . 2)))) 10 | 11 | (alert "arithmetic") 12 | 13 | (check (+ 1 2) 3) 14 | (check (+ 1 -2) -1) 15 | (check (+ 1 2 3 4) 10) 16 | (check (+) 0) 17 | (check (+ 1) 1) 18 | (check (+ 4294967296 1) 4294967297) 19 | (check (+ -4294967296 1) -4294967295) 20 | (check (+ 4294967296 1) 4294967297) 21 | (check (+ -9223372036854775808 1) -9223372036854775807) 22 | (check (- -9223372036854775808 1) 9223372036854775807) 23 | (check (+ 9223372036854775807 1) -9223372036854775808) 24 | (check-arg-fail (+ 1 'apple) not-integer) 25 | 26 | (check (- 2 1) 1) 27 | (check (- 2 -1) 3) 28 | (check (- 1 2 3 4) -8) 29 | (check (- 1) -1) 30 | (check (- 0) 0) 31 | (check (- -9223372036854775808) -9223372036854775808) 32 | (check (- -9223372036854775807) 9223372036854775807) 33 | (check-arg-fail (-) arity) 34 | (check-arg-fail (- 1 'apple) not-integer) 35 | 36 | (check (* 10 2) 20) 37 | (check (* 10 -2) -20) 38 | (check (* 1 2 3 4) 24) 39 | (check (*) 1) 40 | (check (* 10) 10) 41 | (check (* 10 0) 0) 42 | (check (* 4294967296 4294967296) 0) 43 | (check (* 4294967296 -4294967296) 0) 44 | (check (* 4294967296 4294967297) 4294967296) 45 | (check (* 4294967296 -4294967297) -4294967296) 46 | (check (* 2147483648 4294967296) -9223372036854775808) 47 | (check (* -9223372036854775808 1) -9223372036854775808) 48 | (check (* -9223372036854775808 -1) -9223372036854775808) 49 | (check (* 9223372036854775807 -1) -9223372036854775807) 50 | (check (* -9223372036854775807 -1) 9223372036854775807) 51 | (check-arg-fail (* 1 'apple) not-integer) 52 | 53 | (check (quotient 5 2) 2) 54 | (check (quotient 1 2) 0) 55 | (check (quotient -5 2) -2) 56 | (check (quotient 5 -2) -2) 57 | (check (quotient -9223372036854775808 4294967296) -2147483648) 58 | (check (quotient -9223372036854775808 1) -9223372036854775808) 59 | (check (quotient -9223372036854775808 -1) -9223372036854775808) 60 | (check (quotient 9223372036854775807 -1) -9223372036854775807) 61 | (check (quotient -9223372036854775807 -1) 9223372036854775807) 62 | (check-arg-fail (quotient -5) arity) 63 | (check-arg-fail (quotient 5 'apple) not-integer) 64 | (check-arg-fail (quotient 5 0) "divide by zero") 65 | 66 | (check (remainder 5 2) 1) 67 | (check (remainder 2 2) 0) 68 | (check (remainder -5 2) -1) 69 | (check (remainder 5 -2) 1) 70 | (check (remainder -9223372036854775808 1) 0) 71 | (check (remainder -9223372036854775808 -1) 0) 72 | (check (remainder 9223372036854775807 -1) 0) 73 | (check (remainder -9223372036854775807 -1) 0) 74 | (check (remainder -9223372036854775808 9223372036854775807) -1) 75 | (check (remainder 9223372036854775807 -9223372036854775808) 9223372036854775807) 76 | (check-arg-fail (remainder -5) arity) 77 | (check-arg-fail (remainder 5 'apple) not-integer) 78 | (check-arg-fail (remainder 5 0) "divide by zero") 79 | 80 | (check (modulo 5 2) 1) 81 | (check (modulo 2 2) 0) 82 | (check (modulo -5 2) 1) 83 | (check (modulo 5 -2) -1) 84 | (check (modulo -9223372036854775808 1) 0) 85 | (check (modulo -9223372036854775808 -1) 0) 86 | (check (modulo 9223372036854775807 -1) 0) 87 | (check (modulo -9223372036854775807 -1) 0) 88 | (check (modulo -9223372036854775808 9223372036854775807) 9223372036854775806) 89 | (check (modulo 9223372036854775807 -9223372036854775808) -1) 90 | (check-arg-fail (modulo -5) arity) 91 | (check-arg-fail (modulo 5 'apple) not-integer) 92 | (check-arg-fail (modulo 5 0) "divide by zero") 93 | 94 | (alert "ordering") 95 | 96 | (check (= 1 1)) 97 | (check (= -9223372036854775808 -9223372036854775808)) 98 | 99 | (check (<= 1 1)) 100 | (check (<= 1 2)) 101 | (check (<= -2 -1)) 102 | (check (not (<= -1 -2))) 103 | (check (<= -9223372036854775808 -9223372036854775808)) 104 | (check (<= -9223372036854775808 9223372036854775807)) 105 | (check (not (<= 9223372036854775807 -9223372036854775808))) 106 | (check-arg-fail (<= 'apple 5) not-integer) 107 | (check-arg-fail (<= 5 'apple) not-integer) 108 | 109 | (check (not (< 1 1))) 110 | (check (< 1 2)) 111 | (check (< -2 -1)) 112 | (check (not (< -1 -2))) 113 | (check (not (< -9223372036854775808 -9223372036854775808))) 114 | (check (< -9223372036854775808 9223372036854775807)) 115 | (check (not (< 9223372036854775807 -9223372036854775808))) 116 | (check-arg-fail (< 'apple 5) not-integer) 117 | (check-arg-fail (< 5 'apple) not-integer) 118 | 119 | (check (not (> 1 1))) 120 | (check (> 2 1)) 121 | (check (> -1 -2)) 122 | (check (not (> -2 -1))) 123 | (check (not (> -9223372036854775808 -9223372036854775808))) 124 | (check (> 9223372036854775807 -9223372036854775808)) 125 | (check (not (> -9223372036854775808 9223372036854775807))) 126 | (check-arg-fail (> 'apple 5) not-integer) 127 | (check-arg-fail (> 5 'apple) not-integer) 128 | 129 | (check (>= 1 1)) 130 | (check (>= 2 1)) 131 | (check (>= -1 -2)) 132 | (check (not (>= -2 -1))) 133 | (check (>= -9223372036854775808 -9223372036854775808)) 134 | (check (>= 9223372036854775807 -9223372036854775808)) 135 | (check (not (>= -9223372036854775808 9223372036854775807))) 136 | (check-arg-fail (>= 'apple 5) not-integer) 137 | (check-arg-fail (>= 5 'apple) not-integer) 138 | 139 | (alert "bitwise") 140 | 141 | (check 1 (bitwise-and 3 1)) 142 | (check 0 (bitwise-and 2 1)) 143 | (check 42 (bitwise-and -1 42)) 144 | (check -42 (bitwise-and -1 -42)) 145 | (check 0 (bitwise-and -1 0)) 146 | (check 0 (bitwise-and -9223372036854775808 9223372036854775807)) 147 | (check-arg-fail (bitwise-and 'apple 5) not-integer) 148 | (check-arg-fail (bitwise-and 5 'apple) not-integer) 149 | 150 | (check 3 (bitwise-ior 3 1)) 151 | (check 3 (bitwise-ior 2 1)) 152 | (check -1 (bitwise-ior -1 42)) 153 | (check 42 (bitwise-ior 0 42)) 154 | (check -42 (bitwise-ior 0 -42)) 155 | (check -1 (bitwise-ior -9223372036854775808 9223372036854775807)) 156 | (check-arg-fail (bitwise-ior 'apple 5) not-integer) 157 | (check-arg-fail (bitwise-ior 5 'apple) not-integer) 158 | 159 | (check 2 (bitwise-xor 3 1)) 160 | (check 3 (bitwise-xor 2 1)) 161 | (check -43 (bitwise-xor -1 42)) 162 | (check 42 (bitwise-xor 0 42)) 163 | (check -42 (bitwise-xor 0 -42)) 164 | (check -1 (bitwise-xor -9223372036854775808 9223372036854775807)) 165 | (check-arg-fail (bitwise-xor 'apple 5) not-integer) 166 | (check-arg-fail (bitwise-xor 5 'apple) not-integer) 167 | 168 | (check -1 (bitwise-not 0)) 169 | (check 0 (bitwise-not -1)) 170 | (check 41 (bitwise-not -42)) 171 | (check -43 (bitwise-not 42)) 172 | (check 9223372036854775807 (bitwise-not -9223372036854775808)) 173 | (check-arg-fail (bitwise-not 'apple) not-integer) 174 | -------------------------------------------------------------------------------- /tests/kernel.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "kernel eval") 6 | 7 | (define bad-kernel-stx "bad kernel syntax") 8 | 9 | (check (kernel-eval 1) 1) 10 | (check (kernel-eval 'cons) cons) 11 | 12 | (check (kernel-eval '(cons 1 2)) '(1 . 2)) 13 | (check-fail (kernel-eval '(cons 1 . 2)) bad-kernel-stx) 14 | (check-fail (kernel-eval '(cons . 2)) bad-kernel-stx) 15 | 16 | (check (procedure? (kernel-eval '(lambda (x) x))) #t) 17 | (check (procedure? (kernel-eval '(lambda (x x) x))) #t) 18 | (check (procedure? (kernel-eval '(lambda (x . x) x))) #t) 19 | (check (procedure? (kernel-eval '(lambda (x x) "name" x))) #t) 20 | (check ((kernel-eval '(lambda (x x) x)) #f 2) 2) 21 | (check ((kernel-eval '(lambda (x x . x) x)) #f 2 3 4) '(3 4)) 22 | (check-fail (kernel-eval '(lambda)) bad-kernel-stx) 23 | (check-fail (kernel-eval '(lambda . x)) bad-kernel-stx) 24 | (check-fail (kernel-eval '(lambda x)) bad-kernel-stx) 25 | (check-fail (kernel-eval '(lambda (x x))) bad-kernel-stx) 26 | (check-fail (kernel-eval '(lambda (x x . x) . x)) bad-kernel-stx) 27 | (check-fail (kernel-eval '(lambda (x y . x) . x)) bad-kernel-stx) 28 | (check-fail (kernel-eval '(lambda (x x . 5) x)) bad-kernel-stx) 29 | (check-fail (kernel-eval '(lambda 5 x)) bad-kernel-stx) 30 | (check-fail (kernel-eval '(lambda x #f 2)) bad-kernel-stx) 31 | (check-fail (kernel-eval '(lambda x #f . 2)) bad-kernel-stx) 32 | (check-fail (kernel-eval 'lambda) "undefined: 'lambda") 33 | (check (((kernel-eval '(lambda (lambda) (lambda x x))) 1) 2) '(2)) 34 | 35 | (check (kernel-eval '(quote cons)) 'cons) 36 | (check-fail (kernel-eval '(quote)) bad-kernel-stx) 37 | (check-fail (kernel-eval '(quote cons list)) bad-kernel-stx) 38 | (check-fail (kernel-eval '(quote . cons)) bad-kernel-stx) 39 | (check-fail (kernel-eval '(quote cons . list)) bad-kernel-stx) 40 | (check-fail (kernel-eval 'quote) "undefined: 'quote") 41 | 42 | (check (kernel-eval '(if #t 1 2)) 1) 43 | (check (kernel-eval '(if 0 1 2)) 1) 44 | (check (kernel-eval '(if #f 1 2)) 2) 45 | (check-fail (kernel-eval '(if)) bad-kernel-stx) 46 | (check-fail (kernel-eval '(if . 1)) bad-kernel-stx) 47 | (check-fail (kernel-eval '(if 1)) bad-kernel-stx) 48 | (check-fail (kernel-eval '(if 1 . 2)) bad-kernel-stx) 49 | (check-fail (kernel-eval '(if 1 2)) bad-kernel-stx) 50 | (check-fail (kernel-eval '(if 1 2 . 3)) bad-kernel-stx) 51 | (check-fail (kernel-eval '(if 1 2 3 . 4)) bad-kernel-stx) 52 | (check-fail (kernel-eval '(if 1 2 3 4)) bad-kernel-stx) 53 | (check-fail (kernel-eval 'if) "undefined: 'if") 54 | 55 | (check (kernel-eval '(let ([x 1]) x)) 1) 56 | (check (kernel-eval '(let ([x 1]) (let ([x 2]) x))) 2) 57 | (check (kernel-eval '(let ([x 1]) (list (let ([x 2]) x) x))) '(2 1)) 58 | (check-fail (kernel-eval '(let)) bad-kernel-stx) 59 | (check-fail (kernel-eval '(let . x)) bad-kernel-stx) 60 | (check-fail (kernel-eval '(let ())) bad-kernel-stx) 61 | (check-fail (kernel-eval '(let () x)) bad-kernel-stx) 62 | (check-fail (kernel-eval '(let (x) x)) bad-kernel-stx) 63 | (check-fail (kernel-eval '(let ([x]) x)) bad-kernel-stx) 64 | (check-fail (kernel-eval '(let ([x . 1]) x)) bad-kernel-stx) 65 | (check-fail (kernel-eval '(let ([x 1 . 2]) x)) bad-kernel-stx) 66 | (check-fail (kernel-eval '(let ([x 1 2]) x)) bad-kernel-stx) 67 | (check-fail (kernel-eval '(let ([1 2]) x)) bad-kernel-stx) 68 | (check-fail (kernel-eval '(let ([x 2] . y) x)) bad-kernel-stx) 69 | (check-fail (kernel-eval '(let ([x 2] y) x)) bad-kernel-stx) 70 | (check-fail (kernel-eval '(let ([x 2]))) bad-kernel-stx) 71 | (check-fail (kernel-eval '(let ([x 2]) . x)) bad-kernel-stx) 72 | (check-fail (kernel-eval '(let ([x 2]) x . x)) bad-kernel-stx) 73 | (check-fail (kernel-eval '(let ([x 2]) x x)) bad-kernel-stx) 74 | (check-fail (kernel-eval 'let) "undefined: 'let") 75 | 76 | (check (kernel-eval '(begin 1)) 1) 77 | (check (kernel-eval '(begin 1 2)) 2) 78 | (check (kernel-eval '(begin 1 2 3 4)) 4) 79 | (check-fail (kernel-eval '(begin)) bad-kernel-stx) 80 | (check-fail (kernel-eval '(begin . 1)) bad-kernel-stx) 81 | (check-fail (kernel-eval '(begin 1 2 3 . 4)) bad-kernel-stx) 82 | (check-fail (kernel-eval 'begin) "undefined: 'begin") 83 | 84 | (check (andmap (lambda (k) 85 | (eq? (kernel-eval k) (hash-ref (kernel-env) k #f))) 86 | (hash-keys (kernel-env)))) 87 | 88 | (check (kernel-eval 89 | (let loop ([i 10000]) 90 | (if (= i 0) 91 | "ok" 92 | `(kernel-eval ',(loop (- i 1)))))) 93 | "ok") 94 | -------------------------------------------------------------------------------- /tests/macro-common.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (define macro-dir (build-path tmp-dir "macros")) 4 | (rm* macro-dir) 5 | (mkdir macro-dir) 6 | 7 | (check ((lambda lambda lambda) 3) '(3)) 8 | (check (let ([let 10]) let) 10) 9 | (check (let ([let 11]) (let* ([let let]) let)) 11) 10 | (check (let ([quote list]) '1) '(1)) 11 | 12 | (let () 13 | (define-syntax (let-one stx) 14 | (list (quote-syntax let) 15 | (list (list (cadr stx) 1)) 16 | (cadr (cdr stx)))) 17 | (check (let-one x (list x x)) '(1 1)) 18 | (check (let-one x (let ([let 0]) (list x let x))) '(1 0 1))) 19 | 20 | (let ([five 5]) 21 | (define-syntax (let-five stx) 22 | (list (quote-syntax let) 23 | (list (list (cadr stx) (quote-syntax five))) 24 | (cadr (cdr stx)))) 25 | (check (let-five x (list x x)) '(5 5)) 26 | (check (let-five x (let ([five 10]) (list x x))) '(5 5)) 27 | (check (let ([five 10]) (let-five x (list x x))) '(5 5))) 28 | 29 | (define (make-file* path content) 30 | (let ([fd (fd-open-output (build-path macro-dir path) :truncate)]) 31 | (fd-write fd (~a "#lang " lang-name "\n" 32 | (~s (cons 'begin content)))) 33 | (fd-close fd))) 34 | 35 | (define-syntax (make-file stx) 36 | (list (quote-syntax make-file*) 37 | (cadr stx) 38 | (cons (quote-syntax list) 39 | (map (lambda (c) (list (quote-syntax quote) c)) 40 | (cddr stx))))) 41 | 42 | (make-file "exports-macro.zuo" 43 | (provide macro) 44 | (define (my-list . x) x) 45 | (define-syntax (macro stx) 46 | (list (quote-syntax my-list) 47 | (cadr stx) 48 | (cadr stx)))) 49 | 50 | (make-file "uses-macro.zuo" 51 | (require "exports-macro.zuo") 52 | (provide macro-to-macro) 53 | (define hello "hi") 54 | (macro hello) 55 | (define-syntax (macro-to-macro stx) 56 | (list (quote-syntax list) 57 | (list (quote-syntax macro) (cadr stx)) 58 | (list (quote-syntax macro) (cadr stx))))) 59 | 60 | (run-zuo* (list (build-path macro-dir "uses-macro.zuo")) 61 | "" 62 | (lambda (status out err) 63 | (check err "") 64 | (check status 0) 65 | (check out "(list \"hi\" \"hi\")\n"))) 66 | 67 | (make-file "uses-macro-to-macro.zuo" 68 | (require "uses-macro.zuo") 69 | (define-syntax (go stx) (quote-syntax 'went)) 70 | (macro-to-macro go)) 71 | 72 | (run-zuo* (list (build-path macro-dir "uses-macro-to-macro.zuo")) 73 | "" 74 | (lambda (status out err) 75 | (check err "") 76 | (check status 0) 77 | (check out "(list \"hi\" \"hi\")\n(list (list 'went 'went) (list 'went 'went))\n"))) 78 | 79 | (make-file "exports-helper.zuo" 80 | (provide doubled) 81 | (define (my-list . x) x) 82 | (define (doubled stx) 83 | (list (quote-syntax my-list) 84 | stx 85 | stx))) 86 | 87 | (make-file "uses-helper.zuo" 88 | (provide macro) 89 | (require "exports-helper.zuo") 90 | (define-syntax (macro stx) 91 | (doubled (cadr stx)))) 92 | 93 | (make-file "uses-macro-with-helper.zuo" 94 | (require "uses-helper.zuo") 95 | (define hello "hi") 96 | (macro hello)) 97 | 98 | (run-zuo* (list (build-path macro-dir "uses-macro-with-helper.zuo")) 99 | "" 100 | (lambda (status out err) 101 | (check err "") 102 | (check status 0) 103 | (check out "(list \"hi\" \"hi\")\n"))) 104 | -------------------------------------------------------------------------------- /tests/macro-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (require "harness-hygienic.zuo") 4 | 5 | (alert "macros, hygienic expander") 6 | 7 | (define lang-name 'zuo/hygienic) 8 | 9 | (include "macro-common.zuo") 10 | 11 | (define module-five 5) 12 | (define-syntax (let-module-five stx) 13 | (list (quote-syntax let) 14 | (list (list (cadr stx) 'module-five)) ; coerced to defining context 15 | (cadr (cdr stx)))) 16 | (check (let-module-five x (list x x)) '(5 5)) 17 | (check (let-module-five x (let ([module-five 10]) (list x x))) '(5 5)) 18 | (check (let ([module-five 10]) (let-module-five x (list x x))) '(5 5)) 19 | 20 | (let ([five 5]) 21 | (define-syntax (let-five stx) 22 | (list (quote-syntax let) 23 | (list (list (cadr stx) (datum->syntax (car stx) 'five))) ; non-hygienic 24 | (cadr (cdr stx)))) 25 | (check (let-five x (list x x)) '(5 5)) 26 | (check (let-five x (let ([five 10]) (list x x))) '(5 5)) 27 | (check (let ([five 10]) (let-five x (list x x))) '(10 10))) 28 | 29 | -------------------------------------------------------------------------------- /tests/macro.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "macros") 6 | 7 | (define lang-name 'zuo) 8 | 9 | (include "macro-common.zuo") 10 | 11 | (let ([five 5]) 12 | (define-syntax (let-five stx) 13 | (list (quote-syntax let) 14 | (list (list (cadr stx) 'five)) ; can get captured 15 | (cadr (cdr stx)))) 16 | (check (let-five x (list x x)) '(5 5)) 17 | (check (let-five x (let ([five 10]) (list x x))) '(5 5)) 18 | (check (let ([five 10]) (let-five x (list x x))) '(10 10))) 19 | 20 | -------------------------------------------------------------------------------- /tests/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "equal.zuo") 4 | (require "integer.zuo") 5 | (require "pair.zuo") 6 | (require "string.zuo") 7 | (require "symbol.zuo") 8 | (require "hash.zuo") 9 | (require "procedure.zuo") 10 | (require "path.zuo") 11 | (require "opaque.zuo") 12 | (require "variable.zuo") 13 | (require "module-path.zuo") 14 | (require "kernel.zuo") 15 | (require "read+print.zuo") 16 | (require "syntax.zuo") 17 | (require "syntax-hygienic.zuo") 18 | (require "file-handle.zuo") 19 | (require "process.zuo") 20 | (require "filesystem.zuo") 21 | (require "cleanable.zuo") 22 | (require "image.zuo") 23 | (require "shell.zuo") 24 | (require "config.zuo") 25 | (require "c.zuo") 26 | (require "cycle.zuo") 27 | (require "build.zuo") 28 | (require "form.zuo") 29 | (require "form-hygienic.zuo") 30 | (require "macro.zuo") 31 | (require "macro-hygienic.zuo") 32 | 33 | (alert "... tests passed!") 34 | -------------------------------------------------------------------------------- /tests/module-path.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "module paths") 6 | 7 | (check (module-path? 'zuo)) 8 | (check (module-path? 'zuo/main)) 9 | (check (module-path? 'zuo/private/main)) 10 | (check (module-path? '/zuo) #f) 11 | (check (module-path? 'zuo/) #f) 12 | (check (module-path? 'zuo//main) #f) 13 | (check (module-path? 'zuo?) #f) 14 | (check (module-path? 'zuo/?/x) #f) 15 | 16 | (check (module-path? "main.zuo")) 17 | (check (module-path? "private/main.zuo")) 18 | (check (module-path? "private/../main.zuo")) 19 | (check (module-path? "./../main.zuo")) 20 | (check (module-path? "main")) 21 | (check (module-path? "main.rkt")) 22 | (check (module-path? " main.zuo ")) 23 | (check (module-path? "") #f) 24 | (check (module-path? "a\0b") #f) 25 | 26 | (check (module-path? 1) #f) 27 | (check (module-path? '(zuo)) #f) 28 | 29 | (check (build-module-path 'zuo "list.zuo") 'zuo/list) 30 | (check (build-module-path 'zuo/main "list.zuo") 'zuo/list) 31 | (check (build-module-path 'zuo/private/main "list.zuo") 'zuo/private/list) 32 | (check (build-module-path 'zuo "helper/list.zuo") 'zuo/helper/list) 33 | (check (build-module-path 'zuo/main "helper/list.zuo") 'zuo/helper/list) 34 | (check (build-module-path 'zuo/private/main "helper/list.zuo") 'zuo/private/helper/list) 35 | (check (build-module-path 'zuo/private/main "../list.zuo") 'zuo/list) 36 | (check (build-module-path 'zuo/private/main "./list.zuo") 'zuo/private/list) 37 | (check (build-module-path 'zuo/private/main "./././../././list.zuo") 'zuo/list) 38 | (check-arg-fail (build-module-path 'zuo "list") "lacks \".zuo\"") 39 | (check-arg-fail (build-module-path 'zuo "../list.zuo") "too many up elements") 40 | (check-arg-fail (build-module-path 'zuo "x//list.zuo") "not a relative module library path") 41 | (check-arg-fail (build-module-path 'zuo "..//list.zuo") "not a relative module library path") 42 | (check-arg-fail (build-module-path 'zuo "list@.zuo") "not a relative module library path") 43 | (check-arg-fail (build-module-path 'zuo "@/list.zuo") "not a relative module library path") 44 | (check-arg-fail (build-module-path 'zuo "list.rkt") "not a relative module library path") 45 | (check-arg-fail (build-module-path 'zuo "x.y/list.zuo") "not a relative module library path") 46 | 47 | (check (build-module-path "lib/zuo/main.zuo" "list.zuo") "lib/zuo/list.zuo") 48 | (check (build-module-path "lib/zuo/main.zuo" "../list.zuo") "lib/list.zuo") 49 | (check (build-module-path "lib.zuo" "list.zuo") "list.zuo") 50 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "list") "lacks \".zuo\"") 51 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "x//list.zuo") "not a relative module library path") 52 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "..//list.zuo") "not a relative module library path") 53 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "list@.zuo") "not a relative module library path") 54 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "@/list.zuo") "not a relative module library path") 55 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "list.rkt") "not a relative module library path") 56 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "x.y/list.zuo") "not a relative module library path") 57 | 58 | (check-arg-fail (build-module-path "" "x.zuo") "not a module path") 59 | (check-arg-fail (build-module-path 1 "x.zuo") "not a module path") 60 | (check-arg-fail (build-module-path "main.zuo" 1) "not a module path") 61 | (check-arg-fail (build-module-path 'zuo 1) "not a module path") 62 | 63 | (check (hash? (module->hash 'zuo))) 64 | (check-arg-fail (module->hash 8) "not a module path") 65 | -------------------------------------------------------------------------------- /tests/opaque.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "opaque records") 6 | 7 | (check (not (pair? (opaque 'hello "hi")))) 8 | 9 | (check (opaque-ref 'hello (opaque 'hello "hi") #f) "hi") 10 | (check (opaque-ref 'not-hello (opaque 'hello "hi") #f) #f) 11 | (check (opaque-ref (string->uninterned-symbol "hello") (opaque 'hello "hi") #f) #f) 12 | (check (opaque-ref 'hello (opaque (string->uninterned-symbol "hello") "hi") #f) #f) 13 | (check (opaque-ref (opaque 'hello "hi") 'hello #f) #f) 14 | (check (opaque-ref 10 10 #f) #f) 15 | (check (opaque-ref 10 10 'no) 'no) 16 | -------------------------------------------------------------------------------- /tests/pair.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "pairs") 6 | 7 | (check (null? '())) 8 | (check (null? 10) #f) 9 | (check (null? '(1)) #f) 10 | 11 | (check (pair? '()) #f) 12 | (check (pair? 10) #f) 13 | (check (pair? '(1))) 14 | 15 | (check (list? '())) 16 | (check (list? 10) #f) 17 | (check (list? '(1))) 18 | (check (list? '(1 2 3 4 5 6 7))) 19 | (check (list? '(1 . 2)) #f) 20 | (check (list? '(1 2 3 4 5 6 . 7)) #f) 21 | 22 | (check (cons 1 2) '(1 . 2)) 23 | 24 | (check (car '(1 2)) 1) 25 | (check (car '(1 . 2)) 1) 26 | (check-arg-fail (car '()) "not a pair") 27 | (check-arg-fail (car 'apple) "not a pair") 28 | 29 | (check (cdr '(1 . 2)) 2) 30 | (check (cdr '(1 2)) '(2)) 31 | (check-arg-fail (cdr '()) "not a pair") 32 | (check-arg-fail (cdr 'apple) "not a pair") 33 | 34 | (check (list) '()) 35 | (check (list 1 2 3) '(1 2 3)) 36 | 37 | (check (list* 1) 1) 38 | (check (list* 1 2 3) '(1 2 . 3)) 39 | (check-fail (list*) arity) 40 | 41 | (check (append) '()) 42 | (check (append 1) 1) 43 | (check (append '(1 2)) '(1 2)) 44 | (check (append '(1 2) 3) '(1 2 . 3)) 45 | (check (append '(1 2) '(3 4)) '(1 2 3 4)) 46 | (check (append '(1 2) '(3 4) 5) '(1 2 3 4 . 5)) 47 | 48 | (check (reverse '()) '()) 49 | (check (reverse '(1 2 3)) '(3 2 1)) 50 | (check-arg-fail (reverse 1) "not a list") 51 | (check-arg-fail (reverse '(1 . 2)) "not a list") 52 | 53 | (check (list-ref '(1) 0) 1) 54 | (check (list-ref '(1 . 2) 0) 1) 55 | (check (list-ref '(1 2 3 . 4) 2) 3) 56 | (check-arg-fail (list-ref '(1 . 2) 1) "encountered a non-pair") 57 | 58 | (check (list-set '(1) 0 'x) '(x)) 59 | (check (list-set '(1 . 2) 0 'x) '(x . 2)) 60 | (check (list-set '(1 2 3 . 4) 2 'x) '(1 2 x . 4)) 61 | (check-arg-fail (list-set '(1 . 2) 1 'x) "encountered a non-pair") 62 | 63 | (check (list-tail '() 0) '()) 64 | (check (list-tail 1 0) 1) 65 | (check (list-tail '(1 . 2) 1) 2) 66 | (check (list-tail '(1 2 3 . 4) 2) '(3 . 4)) 67 | (check-arg-fail (list-tail '(1 . 2) 2) "encountered a non-pair") 68 | 69 | (check (caar '((1) (2))) 1) 70 | (check-arg-fail (caar 1) "not a valid argument") 71 | (check-arg-fail (caar '(1)) "not a valid argument") 72 | 73 | (check (cadr '((1 2) (3 4))) '(3 4)) 74 | (check-arg-fail (cadr 1) "not a valid argument") 75 | (check-arg-fail (cadr '(1)) "not a valid argument") 76 | 77 | (check (cdar '((1 2) (3 4))) '(2)) 78 | (check-arg-fail (cdar 1) "not a valid argument") 79 | (check-arg-fail (cdar '(1 . 2)) "not a valid argument") 80 | 81 | (check (cddr '((1 2) (3 4) (5 6))) '((5 6))) 82 | (check-arg-fail (cddr 1) "not a valid argument") 83 | (check-arg-fail (cddr '(1 . 2)) "not a valid argument") 84 | 85 | (check (map (lambda (x) (+ x 1)) '(0 1 2)) '(1 2 3)) 86 | (check (map (lambda (x y) (+ x y)) '(1 2 3) '(-10 -20 -30)) '(-9 -18 -27)) 87 | (check-arg-fail (map 1 '()) "not a procedure") 88 | (check-arg-fail (map (lambda (a) a) 1) "not a list") 89 | (check-arg-fail (map (lambda (a) a) '(1) 1) "not a list") 90 | (check-arg-fail (map (lambda (a b) a) '(1) '(1 2)) "lists have different lengths") 91 | 92 | (check (for-each (lambda (x) x) '(1 2 3)) (void)) 93 | (check-output (for-each alert '(1 2 3)) "1\n2\n3\n") 94 | (check-arg-fail (for-each (lambda (a) a) 1) "not a list") 95 | (check-arg-fail (for-each 9 '(1 2)) "not a procedure") 96 | 97 | (check (foldl (lambda (x a) (+ a x)) 7 '(0 1 2)) 10) 98 | (check-arg-fail (foldl (lambda (x a) (+ a x)) 7 7) "not a list") 99 | (check-arg-fail (foldl 10 0 '(1)) "not a procedure") 100 | 101 | (check (andmap integer? '(1 2 3))) 102 | (check (andmap integer? '())) 103 | (check (andmap (lambda (x) (< x 10)) '(1 2 3))) 104 | (check (andmap (lambda (x) (< x 3)) '(1 2 3)) #f) 105 | (check (andmap (lambda (x) (< x 3)) '(1 2 3 "oops")) #f) 106 | (check-arg-fail (andmap 10 '(1)) "not a procedure") 107 | (check-arg-fail (andmap (lambda (x) (< x 3)) '(1 2 3 . "oops")) "not a list") 108 | 109 | (check (ormap integer? '(1 2 3))) 110 | (check (ormap string? '(1 2 3)) #f) 111 | (check (ormap string? '("a" 2 3)) #t) 112 | (check (ormap (lambda (x) (< x 10)) '(1 "oops"))) 113 | (check-arg-fail (ormap 10 '(1)) "not a procedure") 114 | (check-arg-fail (ormap (lambda (x) (< x 3)) '(1 2 3 . "oops")) "not a list") 115 | 116 | (check (member "x" '()) #f) 117 | (check (member "x" '("x" y z)) '("x" y z)) 118 | (check (member "x" '(x "x" y z)) '("x" y z)) 119 | (check-arg-fail (member "x" "y") "not a list") 120 | 121 | (check (assoc "x" '()) #f) 122 | (check (assoc "x" '(("x" . x) y z)) '("x" . x)) 123 | (check (assoc "x" '((x . x) ("x" . x) y z)) '("x" . x)) 124 | (check-arg-fail (assoc "x" "y") "not a list") 125 | (check-arg-fail (assoc "y" '((x . x) ("x" . x) y z)) "non-pair found in list") 126 | 127 | (check (filter (lambda (x) (> x 7)) '()) '()) 128 | (check (filter (lambda (x) (> x 7)) '(1 11 2 12 3 13 4)) '(11 12 13)) 129 | (check-arg-fail (filter "x" '()) "not a procedure") 130 | (check-arg-fail (filter (lambda (x) #t) "y") "not a list") 131 | 132 | (check (sort '() <) '()) 133 | (check (sort '(1 2 3 4) <) '(1 2 3 4)) 134 | (check (sort '(3 4 2 1) <) '(1 2 3 4)) 135 | (check (sort '("z" "d" "a" "m" "p" "q" "w" "f" "b") string (length l) 3) 113 | (check (find-relative-path "../../../bin/tarm64osx/bin/" "../main.o") 114 | (build-path ".." ".." ".." (list-ref l 2) (list-ref l 1) "main.o")))) 115 | (check (find-relative-path "tmp/cache" "/home/zuo/src") 116 | "/home/zuo/src") 117 | 118 | (when unix? 119 | (check (find-relative-path "/home/zuo/src" "/home/zuo/src/private/optimize") 120 | "private/optimize") 121 | (check (find-relative-path "/home/zuo/src" "/home/zuo/lib") 122 | "../lib") 123 | (check (find-relative-path "/home/zuo/src" "/home/zuo/src") 124 | ".") 125 | (check (find-relative-path "/home/zuo/src" "/tmp/cache") 126 | "../../../tmp/cache")) 127 | 128 | (check (path-only "hello.txt") ".") 129 | (check (path-only ".") ".") 130 | (check (path-only "greeting/hello.txt") "greeting/") 131 | (check (path-only "in/greeting/hello.txt") "in/greeting/") 132 | (check (path-only "/") "/") 133 | (check (path-only "a/") "a/") 134 | (check (path-only "a\\") (if unix? "." "a\\")) 135 | (check (path-only "a/.") "a/.") 136 | (check (path-only "a/..") "a/..") 137 | (check-arg-fail (path-only 10) not-path) 138 | 139 | (check (file-name-from-path "hello.txt") "hello.txt") 140 | (check (file-name-from-path ".") #f) 141 | (check (file-name-from-path "greeting/hello.txt") "hello.txt") 142 | (check (file-name-from-path "in/greeting/hello.txt") "hello.txt") 143 | (check (file-name-from-path "/") #f) 144 | (check (file-name-from-path "a/") #f) 145 | (check (file-name-from-path "a\\") (if unix? "a\\" #f)) 146 | (check (file-name-from-path "a/.") #f) 147 | (check (file-name-from-path "a/..") #f) 148 | (check-arg-fail (file-name-from-path 10) not-path) 149 | 150 | (check (path-replace-extension "a.c" ".o") "a.o") 151 | (check (path-replace-extension "p/a.c" ".o") (build-path "p/a.o")) 152 | (check (path-replace-extension "p/.rc" ".o") (build-path "p/.rc.o")) 153 | (check-arg-fail (path-replace-extension 10 "x") not-path) 154 | (check-arg-fail (path-replace-extension "x" 10) not-string) 155 | -------------------------------------------------------------------------------- /tests/procedure.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "procedures") 6 | 7 | (check (procedure? procedure?)) 8 | (check (procedure? (lambda (x) x))) 9 | (check (procedure? (lambda args args))) 10 | (check (procedure? apply)) 11 | (check (procedure? call/cc)) 12 | (check (procedure? (call/cc (lambda (k) k)))) 13 | (check (not (procedure? 1))) 14 | 15 | (check (apply + '()) 0) 16 | (check (apply + '(1)) 1) 17 | (check (apply + '(1 2)) 3) 18 | (check (apply + '(1 2 3 4)) 10) 19 | (check (apply apply (list + '(1 2))) 3) 20 | (check-fail (apply +) arity) 21 | (check-fail (apply '(+ 1 2)) arity) 22 | (check-fail (apply apply (cons + '(1 2))) arity) 23 | (check-arg-fail (apply + 1) "not a list") 24 | 25 | (check (call/cc (lambda (k) (+ 1 (k 'ok)))) 'ok) 26 | (check (let ([f (call/cc (lambda (k) k))]) 27 | (if (procedure? f) 28 | (f 10) 29 | f)) 30 | 10) 31 | (check-fail (call/cc 1) "not a procedure") 32 | 33 | (check (call/prompt (lambda () 10) 'tag) 10) 34 | (check (let ([k (call/prompt 35 | (lambda () 36 | (call/cc (lambda (k) k))) 37 | 'tag)]) 38 | (+ 1 (call/prompt (lambda () (k 11)) 'tag))) 39 | 12) 40 | (check (let ([k (call/prompt 41 | (lambda () 42 | (call/cc 43 | (lambda (esc) 44 | (+ 1 45 | (* 2 46 | (call/cc 47 | (lambda (k) (esc k)))))))) 48 | 'tag)]) 49 | (list (call/prompt (lambda () (k 3)) 'tag) 50 | (call/prompt (lambda () (k 4)) 'tag))) 51 | (list 7 9)) 52 | (check-fail (call/prompt 1 'tag) "not a procedure") 53 | (check-fail (call/prompt void 7) "not a symbol") 54 | 55 | (check (continuation-prompt-available? 'tag) #f) 56 | (check (call/prompt (lambda () 57 | (continuation-prompt-available? 'tag)) 58 | 'tag) 59 | #t) 60 | (check (call/prompt (lambda () 61 | (continuation-prompt-available? 'other)) 62 | 'tag) 63 | #f) 64 | (check (call/prompt (lambda () 65 | (call/prompt 66 | (lambda () 67 | (continuation-prompt-available? 'tag)) 68 | 'other)) 69 | 'tag) 70 | #f) 71 | (check (call/prompt (lambda () 72 | (call/prompt 73 | (lambda () 74 | (continuation-prompt-available? 'other)) 75 | 'other)) 76 | 'tag) 77 | #t) 78 | (check (call/prompt (lambda () 79 | (list (call/prompt 80 | (lambda () 81 | (continuation-prompt-available? 'other)) 82 | 'other) 83 | (continuation-prompt-available? 'tag))) 84 | 'tag) 85 | '(#t #t)) 86 | (check-fail (call/prompt apply 'tag) 87 | "apply: wrong number of arguments: [no arguments]\n") -------------------------------------------------------------------------------- /tests/process.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "processes") 6 | 7 | (define zuo.exe (hash-ref (runtime-env) 'exe)) 8 | (define answer.txt (build-path tmp-dir "answer.txt")) 9 | 10 | ;; check process without redirection, inculding multiple processes 11 | (let () 12 | (define echo-to-file.zuo (build-path tmp-dir "echo-to-file.zuo")) 13 | 14 | (let ([out (fd-open-output echo-to-file.zuo :truncate)]) 15 | (fd-write out (~a "#lang zuo\n" 16 | (~s '(let* ([args (hash-ref (runtime-env) 'args)] 17 | [out (fd-open-output (car args) :truncate)]) 18 | (fd-write out (cadr args)))))) 19 | (fd-close out)) 20 | 21 | (let ([ht (process zuo.exe 22 | echo-to-file.zuo 23 | (list answer.txt 24 | "anybody home?"))]) 25 | (check (hash? ht)) 26 | (check (= 1 (hash-count ht))) 27 | (check (handle? (hash-ref ht 'process))) 28 | (let ([p (hash-ref ht 'process)]) 29 | (check (handle? p)) 30 | (check (process-wait p) p) 31 | (check (process-wait p p p) p) 32 | (check (handle? p)) 33 | (check (process-status p) 0)) 34 | (let ([in (fd-open-input answer.txt)]) 35 | (check (fd-read in eof) "anybody home?") 36 | (fd-close in))) 37 | 38 | (define answer2.txt (build-path tmp-dir "answer2.txt")) 39 | (let ([ht1 (process zuo.exe echo-to-file.zuo answer.txt "one")] 40 | [ht2 (process zuo.exe (list echo-to-file.zuo answer2.txt) "two")]) 41 | (define p1 (hash-ref ht1 'process)) 42 | (define p2 (hash-ref ht2 'process)) 43 | (define pa (process-wait p1 p2)) 44 | (define pb (process-wait (if (eq? p1 pa) p2 p1))) 45 | (check (or (and (eq? p1 pa) (eq? p2 pb)) 46 | (and (eq? p1 pb) (eq? p2 pa)))) 47 | (check (process-status p1) 0) 48 | (check (process-status p2) 0) 49 | (check (process-wait p1) p1) 50 | (check (process-wait p2) p2) 51 | (define pc (process-wait p1 p2)) 52 | (check (or (eq? pc p1) (eq? pc p2))) 53 | (let ([in (fd-open-input answer.txt)]) 54 | (check (fd-read in eof) "one") 55 | (fd-close in)) 56 | (let ([in (fd-open-input answer2.txt)]) 57 | (check (fd-read in eof) "two") 58 | (fd-close in)))) 59 | 60 | ;; check setting the process directory and environment variables 61 | (let ([path->absolute-path (lambda (p) (if (relative-path? p) 62 | (build-path (hash-ref (runtime-env) 'dir) p) 63 | p))]) 64 | (define runtime-to-file 65 | (~a "#lang zuo\n" 66 | (~s `(let* ([out (fd-open-output ,(path->absolute-path answer.txt) :truncate)]) 67 | (fd-write out (~s (cons 68 | (hash-ref (runtime-env) 'dir) 69 | (hash-ref (runtime-env) 'env)))))))) 70 | 71 | (let ([ht (process zuo.exe "" (hash 'stdin 'pipe))]) 72 | (check (hash? ht)) 73 | (check (= 2 (hash-count ht))) 74 | (check (handle? (hash-ref ht 'process))) 75 | (check (handle? (hash-ref ht 'stdin))) 76 | (fd-write (hash-ref ht 'stdin) runtime-to-file) 77 | (fd-close (hash-ref ht 'stdin)) 78 | (process-wait (hash-ref ht 'process)) 79 | (check (process-status (hash-ref ht 'process)) 0) 80 | (let () 81 | (define in (fd-open-input answer.txt)) 82 | (define dir+env (car (string-read (fd-read in eof)))) 83 | (fd-close in) 84 | (check (car dir+env) (hash-ref (runtime-env) 'dir)) 85 | (check (andmap (lambda (p) 86 | (define p2 (assoc (car p) (cdr dir+env))) 87 | (and p2 (equal? (cdr p) (cdr p2)))) 88 | (hash-ref (runtime-env) 'env))))) 89 | 90 | (let* ([env (list (cons "HELLO" "there"))] 91 | [ht (process zuo.exe "" (hash 'stdin 'pipe 92 | 'dir tmp-dir 93 | 'env env))]) 94 | (fd-write (hash-ref ht 'stdin) runtime-to-file) 95 | (fd-close (hash-ref ht 'stdin)) 96 | (process-wait (hash-ref ht 'process)) 97 | (check (process-status (hash-ref ht 'process)) 0) 98 | (let () 99 | (define in (fd-open-input answer.txt)) 100 | (define dir+env (car (string-read (fd-read in eof)))) 101 | (fd-close in) 102 | (define (dir-identity d) (hash-ref (stat d #t) 'inode)) 103 | (check (dir-identity (car dir+env)) (dir-identity tmp-dir)) 104 | (check (andmap (lambda (p) 105 | (define p2 (assoc (car p) (cdr dir+env))) 106 | (and p2 (equal? (cdr p) (cdr p2)))) 107 | env))))) 108 | 109 | ;; make sure that the file descriptor for one process's pipe isn't 110 | ;; kept open by a second process 111 | (let () 112 | (define ht1 (process zuo.exe "" (hash 'stdin 'pipe 'stdout 'pipe))) 113 | (define ht2 (process zuo.exe "" (hash 'stdin 'pipe))) 114 | 115 | (define in1 (hash-ref ht1 'stdin)) 116 | (fd-write in1 "#lang zuo 'hello") 117 | (fd-close in1) 118 | (check (fd-read (hash-ref ht1 'stdout) eof) "'hello\n") 119 | (process-wait (hash-ref ht1 'process)) 120 | (fd-close (hash-ref ht1 'stdout)) 121 | 122 | (define in2 (hash-ref ht2 'stdin)) 123 | (fd-write in2 "#lang zuo") 124 | (fd-close in2) 125 | (process-wait (hash-ref ht2 'process)) 126 | (void)) 127 | 128 | ;; check transfer of UTF-8 arguments and related 129 | (define (check-process-arg arg) 130 | (define p (process (hash-ref (runtime-env) 'exe) 131 | "" 132 | arg 133 | (hash 'stdin 'pipe 'stdout 'pipe))) 134 | (define to (hash-ref p 'stdin)) 135 | (fd-write to "#lang zuo (displayln (hash-ref (runtime-env) 'args))") 136 | (fd-close to) 137 | (define from (hash-ref p 'stdout)) 138 | (define s (fd-read from eof)) 139 | (process-wait (hash-ref p 'process)) 140 | (check s (~a"(" arg ")\n"))) 141 | 142 | (check-process-arg "\316\273") 143 | (check-process-arg "a b c") 144 | (check-process-arg "a \"b\" c") 145 | (check-process-arg "a \"b c") 146 | (check-process-arg "a \\b c") 147 | -------------------------------------------------------------------------------- /tests/read+print.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "reading and printing") 6 | 7 | (check (string-read " 1 (apple) \n 2 \n\n" 0) '(1 (apple) 2)) 8 | (check (string-read " 1 (apple) \n 2 \n\n" 3) '((apple) 2)) 9 | (check (string-read "" 0) '()) 10 | (check (string-read "x" 1) '()) 11 | (check-fail (string-read "(" 0) "missing closer") 12 | (check-fail (string-read 'apple 0) not-string) 13 | (check-fail (string-read "x" "y") not-integer) 14 | (check-fail (string-read "x" 2) "out of bounds") 15 | (check-fail (string-read "x" -2) "out of bounds") 16 | 17 | (check (~v 1 '(apple) "banana") "1 (list 'apple) \"banana\"") 18 | (check (~v 1 '(apple . pie) (string->uninterned-symbol "banana")) "1 (cons 'apple 'pie) #") 19 | (check (~s 1 '(apple) "banana") "1 (apple) \"banana\"") 20 | (check (~s 1 '(apple . pie) (string->uninterned-symbol "banana")) "1 (apple . pie) #") 21 | (check (~a 1 '(apple) "banana") "1(apple)banana") 22 | (check (~a 1 '(apple . pie) (string->uninterned-symbol "banana")) "1(apple . pie)banana") 23 | (check (~a 1 '(apple . pie) (string->uninterned-symbol "banana")) "1(apple . pie)banana") 24 | 25 | (check-fail (string-read "( . pie)") "misplaced `.`") 26 | (check-fail (string-read "[ . pie]") "misplaced `.`") 27 | 28 | (define table 29 | (list 30 | (list #t "#t" "#t" "#t") 31 | (list #f "#f" "#f" "#f") 32 | (list 1 "1" "1" "1") 33 | (list 0 "0" "0" "0") 34 | (list -1 "-1" "-1" "-1") 35 | (list 'apple "'apple" "apple" "apple") 36 | (list (string->uninterned-symbol "banana") "#" "#" "banana") 37 | (list "cherry" "\"cherry\"" "\"cherry\"" "cherry") 38 | (list (cons "cherry" 'pie) "(cons \"cherry\" 'pie)" "(\"cherry\" . pie)" "(cherry . pie)") 39 | (list (list* 1 2 3) "(list* 1 2 3)" "(1 2 . 3)" "(1 2 . 3)") 40 | (list (hash 'a "x") "(hash 'a \"x\")" "#hash((a . \"x\"))" "#hash((a . x))") 41 | (list apply "#" "#" "#") 42 | (list call/cc "#" "#" "#") 43 | (list (let ([f (lambda (x) x)]) f) "#" "#" "#") 44 | (list (opaque 'donut 5) "#" "#" "#") 45 | (list (variable 'elderberry) "#" "#" "#") 46 | (list (void) "#" "#" "#"))) 47 | 48 | (for-each (lambda (row) 49 | (apply (lambda (v pr wr di) 50 | (check (~v v) pr) 51 | (check (~s v) wr) 52 | (check (~a v) di)) 53 | row)) 54 | table) 55 | 56 | (check-output (alert "hello" 'x) "hello: 'x\n") 57 | (check-output (alert 'hello 'x) "'hello 'x\n") 58 | (check-output (alert 'hello 'x 3 4) "'hello 'x 3 4\n") 59 | (check-output (error "hello" 'x) "" "hello: 'x\n") 60 | (check-output (error 'hello 'x) "" "'hello 'x\n") 61 | (check-output (error 'hello 'x 3 4) "" "'hello 'x 3 4\n") 62 | 63 | (check-fail (arity-error 'hello '()) not-string) 64 | (check-fail (arity-error "hello" 'oops) "not a list") 65 | (check-output (arity-error "hello" '(1 () "apple")) "" "hello: wrong number of arguments: 1 '() \"apple\"\n") 66 | 67 | (check (~s (let loop ([i 10000]) 68 | (if (= i 0) 69 | '() 70 | (list (loop (- i 1)))))) 71 | (apply ~a 72 | (let loop ([i 10000] [accum '()]) 73 | (if (= i 0) 74 | (cons "()" accum) 75 | (cons "(" (loop (- i 1) (cons ")" accum))))))) 76 | -------------------------------------------------------------------------------- /tests/shell.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "shell") 6 | 7 | (define unix? (eq? (hash-ref (runtime-env) 'system-type) 'unix)) 8 | 9 | (when unix? 10 | (let ([p (shell "echo hi" (hash 'stdout 'pipe))]) 11 | (check (fd-read (hash-ref p 'stdout) eof) "hi\n") 12 | (fd-close (hash-ref p 'stdout)) 13 | (process-wait (hash-ref p 'process)) 14 | (check (process-status (hash-ref p 'process)) 0))) 15 | 16 | (check (build-shell "x" "" "y" "" "" "z" "") "x y z") 17 | (check (build-shell "x" "" '("y" "" "" "z") "") "x y z") 18 | 19 | (check (shell-subst "Hello, ${who}!" (hash 'who "World")) "Hello, World!") 20 | (check (shell-subst "a${b}c" (hash 'b "c${d}e" 'd "D")) "acDec") 21 | (check (shell-subst "${a}}" (hash 'a "${x" 'x "done")) "done") 22 | (check (shell-subst "${?$^}" (hash (string->symbol "?$^") "weird")) "weird") 23 | 24 | (check-fail (begin 25 | (require zuo/shell) 26 | (shell-subst "${a}" (hash))) 27 | "no substitution found for name") 28 | -------------------------------------------------------------------------------- /tests/string.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "strings") 6 | 7 | (check (string? "apple")) 8 | (check (string? #"apple")) 9 | (check (string? "")) 10 | (check (not (string? 'apple))) 11 | (check (not (string? 10))) 12 | 13 | (check (string 48 97) "0a") 14 | (check (string) "") 15 | (check-fail (string -1) "not an integer in [0, 255]") 16 | (check-fail (string 256) "not an integer in [0, 255]") 17 | (check-fail (string "a") "not an integer in [0, 255]") 18 | 19 | (check (string 2 17) "\002\021") 20 | (check (string 2 17) "\2\21") 21 | (check (string 2 17) "\02\21") 22 | (check (string 2 32 17) "\2 \21") 23 | (check (string 2 32 17) "\02 \21") 24 | (check (string 2 32 17 32) "\02 \21 ") 25 | (check (string 34 49) "\421") 26 | 27 | (check (string-length "") 0) 28 | (check (string-length "apple") 5) 29 | (check-fail (string-length 'apple) not-string) 30 | 31 | (check (string-ref "0123" 0) 48) 32 | (check (string-ref "0123" 2) 50) 33 | (check-fail (string-ref "0123" 4) "out of bounds") 34 | (check-fail (string-ref "0123" -1) "out of bounds") 35 | 36 | (check (substring "0123" 0 0) "") 37 | (check (substring "0123" 0 1) "0") 38 | (check (substring "0123" 0 4) "0123") 39 | (check (substring "0123" 4 4) "") 40 | (check-fail (substring "0123" -1 0) "out of bounds") 41 | (check-fail (substring "0123" 5 6) "out of bounds") 42 | (check-fail (substring "0123" -1 5) "out of bounds") 43 | (check-fail (substring "0123" 1 5) "out of bounds") 44 | (check-fail (substring "0123" 1 0) "index less than starting") 45 | 46 | (check (string-u32-ref "\000\000\000\000" 0) 0) 47 | (check (string-u32-ref "\000\004\004\000" 0) (+ (* 256 4) (* 256 256 4))) 48 | (check (string-u32-ref "\003\000\000\003" 0) (+ 3 (* 256 256 256 3))) 49 | (check (string-u32-ref "\377\000\000\377" 0) (+ 255 (* 256 256 256 255))) 50 | 51 | (check (string-u32-ref "__\000\000\000\000!" 2) 0) 52 | (check (string-u32-ref "__\000\004\004\000!" 2) (+ (* 256 4) (* 256 256 4))) 53 | (check (string-u32-ref "__\003\000\000\003!" 2) (+ 3 (* 256 256 256 3))) 54 | (check (string-u32-ref "__\377\000\000\377!" 2) (+ 255 (* 256 256 256 255))) 55 | 56 | (check (char "0") 48) 57 | (check (char "\377") 255) 58 | (check-fail (char) bad-stx) 59 | (check-fail (char "0" "more") bad-stx) 60 | (check-fail (char . "0") bad-stx) 61 | 62 | (check (string-split " apple pie " " ") '("" "apple" "pie" "" "")) 63 | (check (string-split "__apple____pie__" "__") '("" "apple" "" "pie" "")) 64 | (check (string-split " apple pie ") '("apple" "pie")) 65 | (check-fail (string-split 10) not-string) 66 | (check-fail (string-split "apple" "") "not a nonempty string") 67 | 68 | (check (string-join '("a" "b" "c")) "a b c") 69 | (check (string-join '("a" "b" "c") "x") "axbxc") 70 | (check (string-join '("a" "b" "c") "") "abc") 71 | (check (string-join '()) "") 72 | (check (string-join '() "x") "") 73 | (check-fail (string-join 10) "not a list of strings") 74 | (check-fail (string-join '("x") 10) not-string) 75 | 76 | (check (string-trim " a ") "a") 77 | (check (string-trim " a b c ") "a b c") 78 | (check (string-trim " a " " ") " a ") 79 | (check (string-trim " a " " ") " a ") 80 | (check-fail (string-trim 10) not-string) 81 | (check-fail (string-trim "apple" "") "not a nonempty string") 82 | 83 | (let ([s "hello! / \\ \\\\ // \\\" \"\\ the:re/547\\65\"13\"2-*()*^$*&^'|'&~``'"]) 84 | (let i-loop ([i 0]) 85 | (let j-loop ([j i]) 86 | (let* ([s (substring s i j)]) 87 | (check (shell->strings (string->shell s)) (list s)) 88 | (check (shell->strings (~a " " (string->shell s) " ")) (list s))) 89 | (unless (= j (string-length s)) (j-loop (+ j 1)))) 90 | (unless (= i (string-length s)) (i-loop (+ i 1))))) 91 | 92 | (check (string-sha256 "hello\n") "5891b5b522d5df086d0ff0b110fbd9d21bb4fc7163af34d08286a2e846f6be03") 93 | 94 | (check (string->integer "10") 10) 95 | (check (string->integer "-10") -10) 96 | (check (string->integer "-0") 0) 97 | (check (string->integer "-") #f) 98 | (check (string->integer "") #f) 99 | (check (string->integer "12x") #f) 100 | (check (string->integer "9223372036854775807") 9223372036854775807) 101 | (check (string->integer "9223372036854775808") #f) 102 | (check (string->integer "-9223372036854775807") -9223372036854775807) 103 | (check (string->integer "-9223372036854775808") -9223372036854775808) 104 | (check (string->integer "-9223372036854775809") #f) 105 | (check (string->integer "000000000000000000000007") 7) 106 | (check-fail (string->integer 1) not-string) 107 | 108 | (check (stringuninterned-symbol "apple"))) 9 | (check (not (symbol? "apple"))) 10 | (check (not (symbol? 10))) 11 | 12 | (check (symbol->string 'apple) "apple") 13 | (check-arg-fail (symbol->string "apple") "not a symbol") 14 | 15 | (check (eq? 'apple (string->symbol "apple"))) 16 | (check (not (eq? 'apple (string->uninterned-symbol "apple")))) 17 | (check (not (eq? (string->uninterned-symbol "apple") 18 | (string->uninterned-symbol "apple")))) 19 | (check (not (equal? 'apple (string->uninterned-symbol "apple")))) 20 | (check-arg-fail (string->symbol 'apple) not-string) 21 | (check-arg-fail (string->uninterned-symbol 'apple) not-string) 22 | 23 | (check-arg-fail (string->symbol "apple\0spice") "without a nul character") 24 | (check (symbol? (string->uninterned-symbol "apple\0spice"))) 25 | -------------------------------------------------------------------------------- /tests/syntax-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (require "harness-hygienic.zuo") 4 | 5 | (alert "hygienic syntax") 6 | 7 | (check (identifier? (quote-syntax x))) 8 | (check (not (identifier? 'x))) 9 | (check (not (identifier? #f))) 10 | (check (not (identifier? (quote-syntax (x y))))) 11 | (check (not (identifier? '(x y)))) 12 | (check (andmap identifier? (quote-syntax (x y)))) 13 | 14 | (check (syntax-e (quote-syntax x)) 'x) 15 | (check-fail (syntax-e 'x) "not a syntax object") 16 | 17 | (check (syntax->datum 'x) 'x) 18 | (check (syntax->datum (quote-syntax x)) 'x) 19 | (check (syntax->datum (quote-syntax (x y))) '(x y)) 20 | (check (syntax->datum '(1 #f)) '(1 #f)) 21 | 22 | (check (not (symbol? (datum->syntax (quote-syntax x) 'y)))) 23 | (check (syntax-e (datum->syntax (quote-syntax x) 'y)) 'y) 24 | (check-fail (datum->syntax 'x 'y) "not a syntax object") 25 | 26 | (check (bound-identifier=? (quote-syntax x) (quote-syntax x))) 27 | (check (not (bound-identifier=? (quote-syntax x) (quote-syntax y)))) 28 | 29 | (check-fail (syntax-e #f) "not a syntax object") 30 | (check-fail (syntax-e '(x y)) "not a syntax object") 31 | (check-fail (bound-identifier=? '(x) 'x) "not a syntax object") 32 | (check-fail (bound-identifier=? 'x '(x)) "not a syntax object") 33 | -------------------------------------------------------------------------------- /tests/syntax.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "syntax objects") 6 | 7 | (check (identifier? (quote-syntax x))) 8 | (check (identifier? 'x)) 9 | (check (not (identifier? #f))) 10 | (check (not (identifier? (quote-syntax (x y))))) 11 | (check (not (identifier? '(x y)))) 12 | (check (andmap identifier? (quote-syntax (x y)))) 13 | 14 | (check (syntax-e (quote-syntax x)) 'x) 15 | (check (syntax-e 'x) 'x) 16 | (check-arg-fail (syntax-e #f) "not a syntax object") 17 | (check-arg-fail (syntax-e '(x y)) "not a syntax object") 18 | 19 | (check (syntax->datum 'x) 'x) 20 | (check (syntax->datum (quote-syntax x)) 'x) 21 | (check (syntax->datum (quote-syntax (x y))) '(x y)) 22 | (check (syntax->datum '(1 #f)) '(1 #f)) 23 | 24 | (check (datum->syntax 'x 'y) 'y) 25 | (check (datum->syntax (quote-syntax x) 'y) 'y) 26 | (check (syntax-e (datum->syntax (quote-syntax x) 'y)) 'y) 27 | (check-arg-fail (datum->syntax '(x) 'y) "not a syntax object") 28 | 29 | (check (bound-identifier=? 'x 'x)) 30 | (check (bound-identifier=? (quote-syntax x) (quote-syntax x))) 31 | (check (not (bound-identifier=? (quote-syntax x) (quote-syntax y)))) 32 | (check (not (bound-identifier=? 'x (quote-syntax x)))) 33 | (check-arg-fail (bound-identifier=? '(x) 'x) "not a syntax object") 34 | (check-arg-fail (bound-identifier=? 'x '(x)) "not a syntax object") 35 | 36 | -------------------------------------------------------------------------------- /tests/variable.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "variables") 6 | 7 | (check (variable? (variable 'alice))) 8 | (check (not (variable? 'alice))) 9 | 10 | (check-fail (variable-ref (variable 'alice)) "undefined: alice") 11 | (check-fail (variable-ref 'alice) "not a variable") 12 | 13 | (check (let ([a (variable 'alice)]) 14 | (variable-set! a 'home) 15 | (list (variable-ref a) (variable-ref a))) 16 | '(home home)) 17 | (check-fail (let ([a (variable 'alice)]) 18 | (variable-set! a 'home) 19 | (variable-set! a 'home)) 20 | "variable already has a value") 21 | (check-fail (variable-set! 'alice 'home) "not a variable") 22 | 23 | (check-arg-fail (variable 10) "not a symbol") 24 | -------------------------------------------------------------------------------- /zuo-doc/defzuomodule.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | (require scribble/manual) 3 | 4 | (provide defzuomodule) 5 | 6 | @(define-syntax-rule (defzuomodule zuo/x) 7 | (begin 8 | @defmodule[zuo/x #:no-declare #:packages ()] 9 | @declare-exporting[zuo zuo/x #:packages () #:use-sources (zuo-doc/fake-zuo)] 10 | @para{The @racketmodname[zuo/x] module is reprovided by @racketmodname[zuo].})) 11 | -------------------------------------------------------------------------------- /zuo-doc/fake-kernel.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define-syntax-rule (define-fake id ...) 4 | (begin 5 | (provide id ...) 6 | (define id 'id) ...)) 7 | 8 | (define-syntax-rule (intro-define-fake) 9 | (define-fake 10 | lambda 11 | let 12 | quote 13 | if 14 | define 15 | begin)) 16 | 17 | (intro-define-fake) 18 | 19 | -------------------------------------------------------------------------------- /zuo-doc/fake-zuo-hygienic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define-syntax-rule (define-fake id ...) 4 | (begin 5 | (provide id ...) 6 | (define id 'id) ...)) 7 | 8 | (define-syntax-rule (intro-define-fake) 9 | (define-fake 10 | identifier? 11 | syntax-e 12 | syntax->datum 13 | datum->syntax 14 | bound-identifier=?)) 15 | 16 | (intro-define-fake) 17 | -------------------------------------------------------------------------------- /zuo-doc/fake-zuo.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define-syntax-rule (define-fake id ...) 4 | (begin 5 | (provide id ...) 6 | (define id 'id) ...)) 7 | 8 | (define-syntax-rule (intro-define-fake) 9 | (define-fake 10 | lambda 11 | let 12 | let* 13 | letrec 14 | if 15 | and 16 | or 17 | when 18 | unless 19 | begin 20 | cond 21 | else 22 | quote 23 | quasiquote 24 | unquote 25 | unquote-splicing 26 | quote-syntax 27 | 28 | define 29 | define-syntax 30 | struct 31 | include 32 | require 33 | provide 34 | module+ 35 | quote-module-path 36 | 37 | pair? 38 | null? 39 | integer? 40 | string? 41 | symbol? 42 | hash? 43 | list? 44 | procedure? 45 | path-string? 46 | module-path? 47 | relative-path? 48 | handle? 49 | boolean? 50 | void 51 | 52 | apply 53 | call/cc 54 | call/prompt 55 | continuation-prompt-available? 56 | context-consumer 57 | context-consumer? 58 | 59 | cons 60 | car 61 | cdr 62 | list 63 | list* 64 | append 65 | reverse 66 | length 67 | member 68 | assoc 69 | remove 70 | list-ref 71 | list-set 72 | list-tail 73 | 74 | caar cadr cdar cddr 75 | 76 | andmap 77 | ormap 78 | map 79 | filter 80 | sort 81 | foldl 82 | for-each 83 | 84 | not 85 | eq? 86 | equal? 87 | void? 88 | 89 | + 90 | - 91 | * 92 | quotient 93 | modulo 94 | remainder 95 | < 96 | <= 97 | = 98 | >= 99 | > 100 | bitwise-and 101 | bitwise-ior 102 | bitwise-xor 103 | bitwise-not 104 | 105 | string-length 106 | string-ref 107 | string-u32-ref 108 | substring 109 | string=? 110 | string-ci=? 111 | stringinteger 113 | string->symbol 114 | string->uninterned-symbol 115 | symbol->string 116 | string 117 | string-sha256 118 | char 119 | string-split string-join string-trim 120 | string-tree? 121 | 122 | hash 123 | hash-ref 124 | ref 125 | hash-set 126 | hash-remove 127 | hash-keys 128 | hash-count 129 | hash-keys-subset? 130 | 131 | opaque 132 | opaque-ref 133 | 134 | build-path 135 | split-path 136 | at-source 137 | 138 | variable? 139 | variable 140 | variable-ref 141 | variable-set! 142 | 143 | identifier? 144 | syntax-e 145 | syntax->datum 146 | datum->syntax 147 | bound-identifier=? 148 | syntax-error 149 | bad-syntax 150 | misplaced-syntax 151 | duplicate-identifier 152 | 153 | fd-open-input 154 | fd-open-output 155 | fd-close 156 | fd-read 157 | fd-write 158 | fd-poll 159 | eof 160 | fd-terminal? 161 | fd-valid? 162 | file->string 163 | display-to-file 164 | 165 | stat 166 | ls rm mv mkdir rmdir symlink readlink cp 167 | current-time 168 | system-type 169 | file-exists? 170 | directory-exists? 171 | link-exists? 172 | explode-path 173 | simple-form-path 174 | find-relative-path 175 | build-raw-path 176 | path-replace-extension 177 | path-only 178 | file-name-from-path 179 | path->complete-path 180 | ls* rm* cp* mkdir-p 181 | :no-replace-mode 182 | :error :truncate :must-truncate :append :update :can-update 183 | cleanable-file 184 | cleanable-cancel 185 | 186 | process 187 | process-status 188 | process-wait 189 | find-executable-path 190 | shell->strings 191 | string->shell 192 | 193 | error 194 | alert 195 | ~v 196 | ~a 197 | ~s 198 | arity-error 199 | arg-error 200 | display displayln 201 | 202 | string-read 203 | module->hash 204 | build-module-path 205 | kernel-env 206 | kernel-eval 207 | dynamic-require 208 | 209 | runtime-env 210 | dump-image-and-exit 211 | exit 212 | suspend-signal resume-signal 213 | 214 | command-line 215 | 216 | target 217 | rule 218 | phony-rule 219 | input-file-target 220 | input-data-target 221 | target-path 222 | target-shell 223 | target-name 224 | target? 225 | token? 226 | rule? 227 | phony-rule? 228 | sha256? 229 | file-sha256 230 | no-sha256 231 | sha256-length 232 | build 233 | build/command-line 234 | build/command-line* 235 | build/dep 236 | build/no-dep 237 | provide-targets 238 | find-target 239 | make-at-dir 240 | make-targets 241 | command-target? 242 | command-target->target 243 | bounce-to-targets 244 | 245 | glob->matcher glob-match? 246 | 247 | shell 248 | shell/wait 249 | build-shell 250 | shell-subst 251 | 252 | c-compile c-link c-ar 253 | .c->.o .exe .a 254 | config-merge config-include config-define 255 | 256 | call-in-main-thread 257 | thread? thread channel? channel channel-put channel-get channel-try-get 258 | thread-process-wait 259 | config-file->hash 260 | 261 | maybe-jobserver-client 262 | maybe-jobserver-jobs 263 | 264 | maybe-dry-run-mode)) 265 | 266 | (intro-define-fake) 267 | -------------------------------------------------------------------------------- /zuo-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define deps '("base" 4 | "scribble-lib" 5 | "at-exp-lib" 6 | "racket-doc")) 7 | 8 | (define scribblings '(("zuo.scrbl" (multi-page) (language)))) 9 | 10 | (define pkg-desc "Documentation for the Zuo build language") 11 | 12 | (define pkg-authors '(mflatt)) 13 | 14 | (define license '(Apache-2.0 OR MIT)) 15 | -------------------------------------------------------------------------------- /zuo-doc/lang-zuo-datum.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require (for-label zuo-doc/fake-zuo)) 3 | 4 | @title{Zuo Data as Module} 5 | 6 | @defmodulelang[zuo/datum] 7 | 8 | A module in the @racketmodname[zuo/datum] language ``exports'' its 9 | content as a list of S-expressions. The export is not a 10 | @racket[provide] in the sense of the @racketmodname[zuo] language. 11 | Instead, the module's representation (see @secref["module-protocol"]) 12 | is just a hash table mapping @racket['datums] to the list of 13 | S-expressions. 14 | -------------------------------------------------------------------------------- /zuo-doc/lang-zuo-hygienic.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require (for-label (except-in zuo-doc/fake-zuo 3 | identifier? 4 | syntax-e 5 | syntax->datum 6 | datum->syntax 7 | bound-identifier=?) 8 | zuo-doc/fake-zuo-hygienic) 9 | "real-racket.rkt") 10 | 11 | @title[#:tag "zuo-hygienic"]{Zuo with Hygienic Macros} 12 | 13 | @defmodulelang[zuo/hygienic #:no-declare #:packages ()] 14 | @declare-exporting[zuo/hygienic #:packages () #:use-sources(zuo-doc/fake-zuo-hygienic)] 15 | 16 | The @racketmodname[zuo/hygienic] language provides the same set of 17 | bindings as @racketmodname[zuo/base], but with hygienic macros. Its 18 | macro-expansion protocol uses a different representation of 19 | identifiers and binding scope, and different rules for 20 | @racket[quote-syntax] and macros: 21 | 22 | @itemlist[ 23 | 24 | @item{A @racketmodname[zuo/hygienic] term's representation always 25 | uses identifier syntax objects in place of symbols. A macro 26 | will never receive a plain symbol in its input, and if the 27 | macro produces a term with plain symbol, it is automatically 28 | coerced to a syntax object using the scope of the module that 29 | defines the macro.} 30 | 31 | @item{A syntax object's context includes a @defterm{set of scopes}, 32 | instead of just one @tech{scope}. Before expanding forms in a 33 | new context, a fresh scope representation is added to every 34 | identifier appearing within the context. An reference is 35 | resolved by finding the binding identifier with the most 36 | specific set of scopes that is a subset of the referencing 37 | identifier's scopes.} 38 | 39 | @item{In addition to binding contexts, a specific macro invocation is 40 | also represented by a scope: a fresh scope is added to every 41 | syntax object introduced by a macro expansion. This fresh scope 42 | means that an identifier introduced by the expansion can only 43 | bind identifiers that were introduced by the same expansion. 44 | Meanwhile, a @racket[quote-syntax]-imposed scope on an 45 | introduced identifier prevents it from being bound by an 46 | identifier that's at the macro-use site and not visible at the 47 | macro-definition site.} 48 | 49 | @item{The @racket[quote-syntax] form produces an identifier syntax 50 | object with all of its scope intact. That syntax object 51 | acquires additional scope if it is returned from a macro 52 | expander into a new context.} 53 | 54 | ] 55 | 56 | These differences particularly affect the functions that operate on 57 | @tech{syntax objects}: 58 | 59 | @deftogether[( 60 | @defproc[(identifier? [v any/c]) boolean?] 61 | @defproc[(syntax-e [v identifier?]) symbol?] 62 | @defproc[(syntax->datum [v any/c]) any/c] 63 | @defproc[(datum->syntax [ctx identifier?] [v any/c]) any/c] 64 | @defproc[(bound-identifier=? [id1 identifier?] 65 | [id2 identifier?]) boolean?] 66 | )]{ 67 | 68 | Unlike the @racketmodname[zuo] function, @racket[identifier?] does not 69 | recognize a plain symbol as an identifier. The @racket[datum->syntax] 70 | function converts symbols in @racket[v] to syntax objects using the 71 | context of @racket[ctx].} 72 | -------------------------------------------------------------------------------- /zuo-doc/lang-zuo-kernel.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require (for-label zuo-doc/fake-kernel 3 | (except-in zuo-doc/fake-zuo 4 | lambda 5 | let 6 | quote 7 | if 8 | define 9 | begin)) 10 | "real-racket.rkt") 11 | 12 | @title[#:tag "zuo-kernel"]{Zuo Kernel Language} 13 | 14 | @defmodulelang[zuo/kernel #:no-declare #:packages ()] 15 | @declare-exporting[zuo/kernel #:packages () #:use-sources (zuo-doc/fake-kernel)] 16 | 17 | The body of a @racketmodname[zuo/kernel] module is a single expression 18 | using a set of core @seclink["kernel-syntax"]{syntactic forms} 19 | and @seclink["kernel-primitives"]{primitives}. The expression 20 | must produce a @tech{hash table} that serves as the module's 21 | representation (see @secref["module-protocol"]). 22 | 23 | 24 | @section[#:tag "kernel-syntax"]{Syntactic Forms} 25 | 26 | @deftogether[( 27 | @defform[#:link-target? #f #:id not-id id] 28 | @defform[#:link-target? #f #:id not-literal literal] 29 | @defform[#:link-target? #f #:id not-expr (expr expr ...)] 30 | @defform[(lambda formals maybe-name maybe-arity-mask expr) 31 | #:grammar ([formals (id ...) 32 | id 33 | (id ... . id)] 34 | [maybe-name string 35 | code:blank] 36 | [maybe-arity-mask integer 37 | code:blank])] 38 | @defform[(quote datum)] 39 | @defform[(if expr expr expr)] 40 | @defform[(let ([id expr]) expr)] 41 | @defform[(begin expr ...+)] 42 | )]{ 43 | 44 | These forms are analogous to a variable reference, literal, procedure 45 | application, @realracket*[lambda quote if let begin] in 46 | @racketmodname[racket], but often restricted to a single expression or 47 | binding clause. Unlike the corresponding @racketmodname[racket] or 48 | @racketmodname[zuo] forms, the names of syntactic forms are not 49 | shadowed by a @racket[lambda] or @racket[let] binding, and they refer 50 | to syntactic forms only at the head of a term. A reference to an 51 | unbound variable is a run-time error. If an @racket[id] appears 52 | multiple times in @racket[formals], the last instance shadows the 53 | others. 54 | 55 | A @racket[lambda] form can optionally include a name and/or 56 | arity mask. If an arity mask is provided, it must be a subset of the mask 57 | implied by the @racket[formals]. If @racket[formals] allows 63 or more 58 | arguments, then it must allow any number of arguments (to be 59 | consistent with the possible arities expressed by a mask). 60 | 61 | Although @racket[let] and @racket[begin] could be encoded with 62 | @racket[lambda] easily enough, they're useful shortcuts to make 63 | explicit internally.} 64 | 65 | 66 | @section[#:tag "kernel-primitives"]{Primitives} 67 | 68 | The following names provided by @racketmodname[zuo] are also available 69 | in @racketmodname[zuo/kernel] (and the values originate there): 70 | 71 | @racketblock[ 72 | 73 | pair? null? list? cons car cdr list append reverse length 74 | list-ref list-set 75 | 76 | integer? + - * quotient remainder < <= = >= > 77 | bitwise-and bitwise-ior bitwise-xor bitwise-not 78 | 79 | string? string-length string-ref string-u32-ref substring string 80 | string=? string-ci=? string-sha256 string-split 81 | 82 | symbol? symbol->string string->symbol string->uninterned-symbol 83 | 84 | hash? hash hash-ref hash-set hash-remove 85 | hash-keys hash-count hash-keys-subset? 86 | 87 | procedure? apply call/cc call/prompt 88 | 89 | eq? not void 90 | 91 | opaque opaque-ref 92 | 93 | path-string? build-path build-raw-path split-path relative-path? 94 | module-path? build-module-path 95 | 96 | variable? variable variable-ref variable-set! 97 | 98 | handle? fd-open-input fd-open-output fd-close fd-read fd-write eof 99 | fd-terminal? cleanable-file cleanable-cancel 100 | 101 | stat ls rm mv mkdir rmdir symlink readlink cp 102 | runtime-env current-time 103 | 104 | process process-status process-wait string->shell shell->strings 105 | 106 | string-read ~v ~a ~s alert error arity-error arg-error 107 | 108 | kernel-env kernel-eval module->hash dump-image-and-exit exit 109 | suspend-signal resume-signal 110 | 111 | ] 112 | 113 | @history[#:changed "1.9" @elem{Removed @racket[modulo] and added @racket[remainder].}] 114 | -------------------------------------------------------------------------------- /zuo-doc/reader.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(define ((line chars) . expl) 4 | (list (hspace 1) (litchar chars) expl)) 5 | 6 | @(define (litchars s) 7 | (tabular 8 | #:sep (hspace 1) 9 | (list (cons (hspace 1) (map (lambda (c) (litchar (string c))) (string->list s)))))) 10 | 11 | @title[#:tag "reader"]{Zuo S-Expression Reader} 12 | 13 | The Zuo reader recognizes a subset (roughly) of Racket S-expression 14 | notation. The reader works in terms of bytes as characters, not 15 | Unicode. It reads and potentially recurs based on a starting character 16 | sequence after skipping ASCII whitespace characters: 17 | 18 | @tabular[ 19 | #:sep @hspace[1] 20 | (list 21 | @@line{;}{starts a line comment} 22 | @@line{#!}{starts a line comment; @litchar{\} at then end of a line to the next} 23 | @@line{#;}{comments out the next S-expression} 24 | @@line{(}{starts a pair or list; see @secref["read-list"]} 25 | @@line{[}{starts a pair or list; see @secref["read-list"]} 26 | @@line{.}{creates a pair when delimited afterward; see @secref["read-list"]} 27 | @@line{"}{starts a string; see @secref["read-string"]} 28 | @@line{#"}{starts a string; see @secref["read-string"]} 29 | @@line{#t}{starts a boolean; see @secref["read-boolean"]} 30 | @@line{#f}{starts a boolean; see @secref["read-boolean"]} 31 | @@line{'}{creates a list with @racket[quote] and the next S-expression} 32 | @@line{`}{creates a list with @racket[quasiquote] and the next S-expression} 33 | @@line{,}{creates a list with @racket[unquote] and the next S-expression} 34 | @@line|{,@}|{creates a list with @racket[unquote-splicing] and the next S-expression}) 35 | ] 36 | 37 | A @litchar{#} followed by any other character is not allowed. Other 38 | starting character sequences either create a number (see 39 | @secref["read-number"]) or symbol (see @secref["read-symbol"]), or 40 | they are disallowed. Any character that is not allowed with a symbol 41 | (see @secref["read-symbol"]) counts as a delimiter. 42 | 43 | @section[#:tag "read-number"]{Reading Numbers} 44 | 45 | A Zuo number starts optionally @litchar{-} and then one or more 46 | decimal digits. It must be delimited afterward. The resulting integer 47 | must fit into a 64-bit two's complement representation. Any number of 48 | leading @litchar{0}s is allowed. 49 | 50 | Zuo does not support floating-point numbers, and it does not allow 51 | @litchar{+} at the beginning of a number. Such sequences will parse as 52 | symbols. 53 | 54 | @section[#:tag "read-symbol"]{Reading Symbols} 55 | 56 | A symbol can include any ASCII digit, alphabetic character for the 57 | following characters: 58 | 59 | @litchars|{~!@#$%^&*-_=+:<>?/.}| 60 | 61 | Although @litchar{#} is allowed within a symbol, a symbol cannot start with 62 | @litchar{#}. A sequence that optional starts @litchar{-} with one or 63 | more digits up to a delimited is parsed as a number (see 64 | @secref["read-number"]) instead of a symbol. A delimited @litchar{.} 65 | is not a symbol. 66 | 67 | @section[#:tag "read-string"]{Reading Strings} 68 | 69 | A string starts with @litchar{#"} or @litchar{"} and ends with a matching 70 | @litchar{"}. Any character is allowed in a string, except for a 71 | newline or return character. The following escapes are supported with 72 | the usual meaning: @litchar{\"}, @litchar{\\}, @litchar{\n}, 73 | @litchar{\r}, @litchar{\t}, and @litchar{\} followed by one to three 74 | octal digits. 75 | 76 | @section[#:tag "read-list"]{Reading Lists} 77 | 78 | An @litchar{(} or @litchar{[} starts a list or pair that runs until 79 | the matching @litchar{)} or @litchar{]}, respectively. S-expressions 80 | between the matching pair are the elements of the list or pair. If a 81 | delimited @litchar{.} appears where a list element is expected, then 82 | exactly one S-expressioon must appear afterward within the matching 83 | pair. 84 | 85 | @section[#:tag "read-boolean"]{Reading Booleans} 86 | 87 | A boolean is @litchar{#t}, @litchar{#f}, @litchar{#true}, or 88 | @litchar{#false}, and it must be followed by a delimiter. Any other 89 | sequence after @litchar{#}, other than a string or line comment, is an 90 | error. 91 | -------------------------------------------------------------------------------- /zuo-doc/real-racket.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | (require scribble/manual 3 | (for-syntax racket/base) 4 | (for-label racket/base 5 | racket/contract/base 6 | racket/cmdline 7 | racket/format 8 | racket/list)) 9 | 10 | (provide realracket 11 | realracket* 12 | (for-label any/c 13 | or/c 14 | listof 15 | ->)) 16 | 17 | (define-syntax (realracket stx) 18 | (syntax-case stx () 19 | [(_ id) @#`racket[#,(datum->syntax #'here (syntax-e #'id))]])) 20 | 21 | (define-syntax (realracket* stx) 22 | (syntax-case stx () 23 | [(_ id) @#'realracket[id]] 24 | [(_ id1 id2) @#'elem{@realracket[id1] and @realracket[id2]}] 25 | [(_ id1 id2 id3) @#'elem{@realracket[id1], @realracket[id2], and @realracket[id3]}] 26 | [(_ id0 id ...) @#'elem{@realracket[id0], @realracket*[id ...]}])) 27 | 28 | 29 | -------------------------------------------------------------------------------- /zuo-doc/zuo.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title{Zuo: A Tiny Racket for Scripting} 4 | 5 | You should use Racket to write scripts. But for the case where you 6 | need something much smaller than Racket for some reason, or the case 7 | you're trying to script the build of Racket itself, Zuo is a tiny 8 | Racket with primitives for dealing with files and running processes. 9 | 10 | @table-of-contents[] 11 | 12 | @include-section["overview.scrbl"] 13 | @include-section["lang-zuo.scrbl"] 14 | @include-section["zuo-build.scrbl"] 15 | @include-section["zuo-lib.scrbl"] 16 | @include-section["lang-zuo-hygienic.scrbl"] 17 | @include-section["lang-zuo-datum.scrbl"] 18 | @include-section["lang-zuo-kernel.scrbl"] 19 | @include-section["reader.scrbl"] 20 | --------------------------------------------------------------------------------