ref: b627a0cb99f603a0cc1bcf69be1da5eb00135cf3
author: Matthew Flatt <mflatt@racket-lang.org>
date: Sun Apr 10 03:23:17 CDT 2022
initial version Zuo started in the Racket repo, then moved to https://github.com/mflatt/zuo/, and then moved back to the Racket repo during development at https://github.com/mflatt/racket/tree/zuo, and finally will reside officially in the Racket repo at https://github.com/racket/racket. Going forward, this repo is intended to track changes at the Racket repo.
--- /dev/null
+++ b/.gitignore
@@ -1,0 +1,29 @@
+/zuo
+/zuo.dSYM
+/zuo.exe
+/zuo.obj
+/zuo.o
+
+/build
+
+compiled/
+
+# common backups, autosaves, lock files, OS meta-files
+*~
+\#*
+.#*
+.DS_Store
+*.bak
+TAGS
+*.swn
+*.swo
+*.swp
+.gdb_history
+/.vscode/
+
+# generated by patch
+*.orig
+*.rej
+
+# coredumps
+*.core
--- /dev/null
+++ b/LICENSE.txt
@@ -1,0 +1,10 @@
+This component of Racket is distributed under the under the Apache 2.0
+and MIT licenses. The user can choose the license under which they
+will be using the software. There may be other licenses within the
+distribution with which the user must also comply.
+
+See the files
+ https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt
+and
+ https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt
+for the full text of the licenses.
--- /dev/null
+++ b/Makefile.in
@@ -1,0 +1,12 @@
+# `configure` adds lines before to record configuration
+
+.PHONY: zuos-to-run-and-install
+zuos-to-run-and-install: zuo
+ ./zuo . zuos-to-run-and-install
+
+zuo: $(srcdir)/zuo.c
+ $(CC) $(CPPFLAGS) $(CFLAGS) -DZUO_LIB_PATH='"'"$(srcdir)/lib"'"' -o zuo $(srcdir)/zuo.c $(LDFLAGS) $(LIBS)
+
+.PHONY: install
+install: zuo
+ ./zuo . install
--- /dev/null
+++ b/README.md
@@ -1,0 +1,103 @@
+Zuo: A Tiny Racket for Scripting
+================================
+
+You should use Racket to write scripts. But what if you need something
+much smaller than Racket for some reason — or what if you're trying
+to script a build of Racket itself? Zuo is a tiny Racket with
+primitives for dealing with files and running processes, and it comes
+with a `make`-like embedded DSL.
+
+Zuo is a Racket variant in the sense that program files start with
+`#lang`, and the module path after `#lang` determines the parsing and
+expansion of the file content. That's how the `make`-like DSL is
+defined, and even the base Zuo language is defined by layers of
+`#lang`s. One of the early layers implements macros.
+
+
+Some Example Scripts
+--------------------
+
+See [`local/hello.zuo`](local/hello.zuo),
+[`local/tree.zuo`](local/tree.zuo),
+[`local/image.zuo`](local/image.zuo), and
+[`build.zuo`](build.zuo).
+
+
+Building and Running Zuo
+------------------------
+
+Compile `zuo.c` with a C compiler. No additional are files needed,
+other than system and C library headers. No compiler flags should be
+needed, although flags like `-o zuo` or `-O2` are a good idea.
+
+You can also use `configure`, `make`, and `make install`, where `make`
+targets mostly invoke a Zuo script after compiling `zuo.c`. If you
+don't use `configure` but compile to `zuo` in the current directory,
+then `./zuo build.zuo` and `./zuo build.zuo install` (omit the `./` on Windows)
+will do the same thing as `make` and `make install` with a default
+configuration.
+
+The Zuo executable runs only modules. If you run Zuo with no
+command-line arguments, then it loads `main.zuo`. Otherwise, the first
+argument to Zuo is a file to run or a directory containing a
+`main.zuo` to run, and additional arguments are delivered to that Zuo
+program via the `runtime-env` procedure. Running the command
+`./zuo build install`, for example, runs the `build/main.zuo` program
+with the argument `install`. Whatever initial script is run, if it has
+a `main` submodule, that submodule is also run.
+
+
+Library Modules and Startup Performance
+---------------------------------------
+
+Except for the built-in `zuo/kernel` language module, Zuo finds
+languages and modules through a collection of libraries. By default,
+Zuo looks for a directory `lib` relative to the executable as the root
+of the library-collection tree. You can supply an alternate collection
+path with the `-X` command-line flag.
+
+You can also create an instance of Zuo with a set of libraries
+embedded as a heap image. Embedding a heap image has two advantages:
+
+ * No extra directory of library modules is necessary.
+
+ * Zuo can start especially quickly, competitive with the fastest
+ command-line programs.
+
+The `local/image.zuo` script generates a `.c` file that is a copy of
+`zuo.c` plus embedded modules. By default, the `zuo` module and its
+dependencies are included, but you can specify others with `++lib`. In
+addition, the default collection-root path is disabled in the
+generated copy, unless you supply `--keep-collects` to
+`local/image.zuo`.
+
+When you use `configure` and `make` or `./zuo build.zuo`, the default
+build target creates a `to-run/zuo` that embeds the `zuo` library, as
+well as a `to-install/zuo` that has the right internal path to find
+other libraries after `make install` or `./zuo build.zuo install`.
+
+You can use heap images without embedding. The `dump-heap-and-exit`
+Zuo kernel permitive creates a heap image, and a `-B` or `--boot`
+command-line flag for Zuo uses the given boot image on startup.
+
+A boot image is machine-independent, whether in a stand-alone file or
+embedded in `.c` source.
+
+
+Embedding Zuo in Another Application
+------------------------------------
+
+Zuo can be embedded in a larger application, with or without an
+embedded boot image. To support embedding, compile `zuo.c` or the
+output of `local/image.zuo` with the `ZUO_EMBEDDED` preprocessor macro
+defined (to anything); the `zuo.h` header will be used in that case,
+and `zuo.h` should also be used by the embedding application.
+Documentation for the embedding API is provided as comments within
+`zuo.h`.
+
+
+More Information
+----------------
+
+Install the `zuo-doc` directory as a package in Racket to render the
+documentation there.
--- /dev/null
+++ b/build.zuo
@@ -1,0 +1,105 @@
+#lang zuo
+(require "local/image.zuo")
+
+;; Exports `targets` and also defines a `main` submodule
+;; that handles command-line arguments and builds a target
+;; in a `make`-like way
+(provide-targets targets-at)
+
+;; The `targets-at` function generates targets, and `to-dir` determines
+;; the build directory --- so these targets could be used by another
+;; build script that wants the output in a subdirectory, for example
+(define (targets-at at-dir [vars (hash)])
+ ;; The `configure` script writes configuration info to "Makefile", so
+ ;; use that if it's available, or use defaults otherwise
+ (define Makefile (at-dir "Makefile"))
+ (define config-in
+ (cond
+ [(file-exists? Makefile) (config-file->hash Makefile)]
+ ;; no `configure`-generated `Makefile`, so use defaults
+ [(eq? (hash-ref (runtime-env) 'system-type) 'unix)
+ (hash 'INSTALL_PREFIX "/usr/local"
+ 'CC "cc"
+ 'CFLAGS "-O2")]
+ [else
+ (hash 'INSTALL_PREFIX "C:\\Program Files\\Zuo"
+ 'CC "cl.exe"
+ 'CFLAGS "/O2")]))
+ (define config (foldl (lambda (key config)
+ (hash-set config key (hash-ref vars key)))
+ config-in
+ (hash-keys vars)))
+
+ (define install-prefix (hash-ref config 'INSTALL_PREFIX))
+
+ ;; Get a target for "image_zuo.c" from `image.zuo`
+ (define image_zuo.c
+ (image-target (hash 'output (at-dir "image_zuo.c")
+ 'libs (map string->symbol (string-split (hash-ref config 'EMBED_LIBS "zuo")))
+ 'keep-collects? #t)))
+
+ ;; We'll build two executables; they are the same except for the
+ ;; embedded libary path, so we have a target maker parameterized
+ ;; over that choice
+ (define (exe-target name lib-path)
+ (target (at-dir (add-exe name))
+ (lambda (path token)
+ (rule (list image_zuo.c
+ (input-data-target 'config config)
+ (quote-module-path))
+ (lambda ()
+ (define l (split-path path))
+ (when (car l) (mkdir-p (car l)))
+ (c-compile path
+ (list (target-path image_zuo.c))
+ (config-merge config
+ 'CPPFLAGS
+ (string->shell (~a "-DZUO_LIB_PATH=" lib-path)))))))))
+
+ (define (add-exe name)
+ (if (eq? (hash-ref (runtime-env) 'system-type) 'windows)
+ (~a name ".exe")
+ name))
+
+ ;; The library path gets used as a C string constant, which isn't
+ ;; trivial because there are likely to be backslashes on Windows
+ (define (as-c-string path) (~s path)) ; probably a good enough approximation
+
+ ;; The two executable targets
+ (define zuo-to-run (exe-target "to-run/zuo" (as-c-string (find-relative-path "to-run"
+ (at-source "lib")))))
+ (define zuo-to-install (exe-target "to-install/zuo" (as-c-string (build-path install-prefix "lib"))))
+
+ ;; A phony target to build both executables, which we'll list first
+ ;; so it's used as the default target
+ (define zuos-to-run-and-install
+ (target 'zuos-to-run-and-install
+ (lambda (token)
+ (phony-rule (list zuo-to-run zuo-to-install)
+ void))))
+
+ ;; A phony target to install
+ (define install
+ (target 'install
+ (lambda (token)
+ (phony-rule (list zuo-to-install)
+ (lambda ()
+ (define (say-copy cp a b)
+ (displayln (~a "copying " a " to " b))
+ (cp a b))
+ (mkdir-p install-prefix)
+ (mkdir-p (build-path install-prefix "bin"))
+ (define dest-exe (build-path install-prefix "bin" "zuo"))
+ (when (file-exists? dest-exe) (rm dest-exe)) ; needed for macOS
+ (say-copy cp (target-name zuo-to-install) dest-exe)
+ (mkdir-p (build-path install-prefix "lib"))
+ (say-copy cp*
+ (at-source "lib" "zuo")
+ (build-path install-prefix "lib" "zuo")))))))
+
+ ;; Return all the targets
+ (list zuos-to-run-and-install
+ image_zuo.c
+ zuo-to-run
+ zuo-to-install
+ install))
--- /dev/null
+++ b/configure
@@ -1,0 +1,77 @@
+#! /bin/sh
+
+srcdir=`dirname "$0"`
+installprefix=/usr/local
+: ${CC:="cc"}+: ${CFLAGS:="-O2"}+embed=zuo
+LIB_PATH=lib
+
+while [ $# != 0 ] ; do
+ case $1 in
+ --embed=*)
+ embed=`echo $1 | sed -e 's/^--embed=//'`
+ ;;
+ --big)
+ embed="zuo zuo/hygienic"
+ ;;
+ --prefix=*)
+ installprefix=`echo $1 | sed -e 's/^--prefix=//'`
+ LIB_PATH=${installprefix}/share/zuo+ ;;
+ --help)
+ help=yes
+ ;;
+ CC=*)
+ CC=`echo $1 | sed -e 's/^CC=//'`
+ ;;
+ CPPFLAGS=*)
+ CPPFLAGS=`echo $1 | sed -e 's/^CPPFLAGS=//'`
+ ;;
+ CFLAGS=*)
+ CFLAGS=`echo $1 | sed -e 's/^CFLAGS=//'`
+ cflagsset=yes
+ ;;
+ LDFLAGS=*)
+ LDFLAGS=`echo $1 | sed -e 's/^LDFLAGS=//'`
+ ;;
+ LIBS=*)
+ LIBS=`echo $1 | sed -e 's/^LIBS=//'`
+ ;;
+ *)
+ echo "option '$1' unrecognized or missing an argument; try $0 --help"
+ exit 1
+ ;;
+ esac
+ shift
+done
+
+if [ "$help" = "yes" ]; then
+ echo ""
+ echo "Options (defaults shown in parens):"
+ echo " --prefix=<pathname> installation root ($installprefix)"
+ echo " --embed=\"<lib> ...\" embed <lib>s in executable (zuo)"
+ echo " --big shorthand for --embed=\"zuo zuo/hygienic\""
+ echo " CC=<C compiler> C compiler"
+ echo " CPPFLAGS=<C preprocessor flags> C preprocessor flags"
+ echo " CFLAGS=<C compiler flags> C compiler flags"
+ echo " LDFLAGS=<linker flags> additional linker flags"
+ echo " LIBS=<libraries> additional libraries"
+ echo ""
+ echo ""
+ exit 0
+fi
+
+echo "srcdir = ${srcdir}" > Makefile+echo "EMBED_LIBS = ${embed}" >> Makefile+echo "CC = ${CC}" >> Makefile+echo "CPPFLAGS = ${CPPFLAGS}" >> Makefile+echo "CFLAGS = ${CFLAGS}" >> Makefile+echo "LDFLAGS = ${LDFLAGS}" >> Makefile+echo "LIBS = ${LIBS}" >> Makefile+echo "INSTALL_PREFIX = ${installprefix}" >> Makefile+cat ${srcdir}/Makefile.in >> Makefile+
+echo "#lang zuo" > main.zuo
+echo "(require "'"'"${srcdir}/build.zuo"'"'")" >> main.zuo+echo "(build/command-line* targets-at at-source)" >> main.zuo
--- /dev/null
+++ b/lib/zuo/base.zuo
@@ -1,0 +1,4 @@
+#lang zuo/kernel
+
+(let ([maker (hash-ref (module->hash 'zuo/private/base) 'make-language #f)])
+ (maker 'zuo/private/base/main))
--- /dev/null
+++ b/lib/zuo/bounce.zuo
@@ -1,0 +1,2 @@
+#lang zuo/base
+
--- /dev/null
+++ b/lib/zuo/build.zuo
@@ -1,0 +1,953 @@
+#lang zuo/base
+(require "cmdline.zuo"
+ "thread.zuo"
+ "config.zuo"
+ "private/build-db.zuo")
+
+(provide (rename-out [make-target target]
+ [make-rule rule]
+ [make-phony-rule phony-rule])
+ input-file-target
+ input-data-target
+
+ target-name
+ target-path
+ target-shell
+
+ target?
+ token?
+ rule?
+ phony-rule?
+
+ sha1?
+ file-sha1
+ no-sha1
+
+ build
+ build/command-line
+ build/command-line*
+ build/dep
+ build/no-dep
+
+ find-target
+ make-at-dir
+ provide-targets
+ bounce-to-targets
+
+ command-target?
+ command-target->target
+
+ make-targets)
+
+;; ------------------------------------------------------------
+;; Targets and rules
+
+;; A token represents a build in progress, used by a target's `get-rule` or `build`
+;; function to make recursive call or get SHA-1s (possibly cached)
+(struct token (target ; the target that received this token
+ ch ; a channel to access the build state
+ seen ; to detect dependency cycles
+ resource-ch ; build state's resource channel
+ uni?)) ; build state's `uni?` flag
+
+(struct target (key ; shortcut: `string->symbol` of the path
+ name ; a symbol or path relative to the current directory
+ get-rule ; (name token -> rule), where `name` is relative to current directory
+ kind ; 'normal, 'input, or 'phony
+ options)) ; keys include 'precious?, 'command?, and 'co-outputs
+
+;; A rule is a result from `get-rule`:
+(struct rule (deps ; list of targets
+ build ; (-> any), called when deps SHA-1s different than recorded
+ sha1)) ; #f => computed via `file-sha1`
+
+;; A phony target returns a phony-rule, instead:
+(struct phony-rule (deps
+ build))
+
+;; During a target's `get-rule` or `build`, calls to `build/dep`
+;; trigger recording of additional dependencies
+
+(define no-sha1 "")
+(define phony-sha1 (string->uninterned-symbol "x")) ; internal use
+(define (sha1? s)
+ (or (and (string? s)
+ (or (= (string-length s) 40)
+ (string=? s no-sha1)
+ ;; also allow a concatenation of SHA-1s for multi-file targets
+ (and (>= (string-length s) 40)
+ (= 0 (modulo (string-length s) 40)))))
+ (eq? s phony-sha1)))
+
+;; public constructor
+(define make-target
+ (let ([target
+ (lambda (name get-rule [options (hash)])
+ (unless (or (symbol? name) (path-string? name))
+ (arg-error 'target "path string or symbol" name))
+ (unless (procedure? get-rule) (arg-error 'target "procedure" get-rule))
+ (unless (hash? options) (arg-error 'target "hash table" options))
+ (cond
+ [(symbol? name)
+ (let ([key (string->uninterned-symbol (symbol->string name))]
+ [get-rule (get-phony-rule->get-rule get-rule)])
+ (target key name get-rule 'phony options))]
+ [else
+ (let ([key (string->symbol name)])
+ (target key name get-rule 'normal options))]))])
+ target))
+
+;; public constructor
+(define make-rule
+ (let ([rule
+ (lambda (deps [build #f] [sha1 #f])
+ (let ([norm-deps (and (list? deps) (map coerce-to-target deps))])
+ (unless (and norm-deps (andmap target? norm-deps))
+ (arg-error 'rule "list of targets" deps))
+ (unless (or (not build)
+ (procedure? build))
+ (arg-error 'rule "procedure or #f" build))
+ (unless (or (not sha1) (sha1? sha1))
+ (arg-error 'rule "sha1 or #f" sha1))
+ (rule norm-deps build sha1)))])
+ rule))
+
+;; An input-file target has no dependencies
+(define (input-file-target path)
+ (unless (path-string? path) (arg-error 'input-file-target "path string" path))
+ (target (string->symbol path)
+ path
+ (lambda (path token)
+ (rule '()
+ (lambda () (error "missing input file" path))
+ #f))
+ 'input
+ (hash)))
+
+(define (coerce-to-target t)
+ (if (path-string? t)
+ (input-file-target t)
+ t))
+
+(define (coerce-to-target* t)
+ (if (list? t)
+ (let ([l (map coerce-to-target t)])
+ (if (andmap target? l)
+ (make-target (string->uninterned-symbol "multi")
+ (lambda (token)
+ (phony-rule l void)))
+ t))
+ (coerce-to-target t)))
+
+;; An input-data target supplies its SHA-1 up front
+(define (input-data-target name v)
+ (unless (symbol? name) (arg-error 'input-data-target "symbol" name))
+ (target (symbol->key name)
+ name
+ (lambda (path token) (make-rule '() #f (string-sha1 (~s v))))
+ 'input
+ (hash)))
+
+(define make-phony-rule
+ (let ([phony-rule
+ (lambda (deps build)
+ (unless (and (list? deps)
+ (andmap target? deps))
+ (arg-error 'phony-rule "list of targets" deps))
+ (unless (procedure? build)
+ (arg-error 'phony-rule "procedure" build))
+ (phony-rule deps build))])
+ phony-rule))
+
+(define (get-phony-rule->get-rule get-phony-rule)
+ (lambda (path token . args) ; extra args possible with 'command option
+ (define r (apply get-phony-rule (cons token args)))
+ (unless (phony-rule? r)
+ (error "build: target result is not a phony rule" r))
+ (rule (phony-rule-deps r)
+ (lambda ()
+ ((phony-rule-build r))
+ phony-sha1)
+ phony-sha1)))
+
+(define (target-path t)
+ (unless (target? t) (arg-error 'target-path "target" t))
+ (let ([n (target-name t)])
+ (if (symbol? n)
+ (error "target-path: target does not have a path name" t)
+ n)))
+
+(define (target-shell t)
+ (unless (target? t) (arg-error 'target-path "target" t))
+ (let ([n (target-name t)])
+ (if (symbol? n)
+ (error "target-shell: target does not have a path name" t)
+ (string->shell n))))
+
+(define (target-db-dir t)
+ (hash-ref (target-options t) 'db-dir #f))
+
+;; ------------------------------------------------------------
+;; Build state and loop
+
+;; When a target is built, the build result is recorded as
+;;
+;; (list sha1 (list dep-sym-or-path-rel-to-target sha1) ..)
+;;
+;; This result is in the `target-state` field of a build state, while
+;; `db` holds the same-shaped information from the previous build.
+;;
+;; The `time-cache` field of a build state is a shortcut for getting
+;; input-file SHA-1s on the assumption that a SHA-1 recorded last time
+;; is still right if the file's timestamp hasn't changed.
+
+;; Where the contracts below say "dep-sha1s", that's a hash table
+;; mapping a dependency's key to a SHA-1.
+
+(struct build-state (ch ; channel to hold the state while target is running
+ target-state ; key -> (cons sha1 dep-sha1s) | 'pending | channel
+ target-accum ; key -> dep-sha1s
+ db ; key -> (cons sha1 dep-sha1s) | #t [for db file itself]
+ time-cache ; key -> (cons timestamp sha1)
+ saw-targets ; key -> target [to detect multiple for same output]
+ resource-ch ; channel with available resources enqueued
+ log? ; logging enabled?
+ uni?)) ; just one job?
+
+;; Main entry point to build a target `t`
+(define (build t-in [token #f] [options (hash)])
+ (let ([t (coerce-to-target* t-in)])
+ (unless (target? t) (arg-error 'build "target or list of targets" t-in))
+ (unless (hash? options) (arg-error 'build "hash table" options))
+ (unless (or (not token) (token? token)) (arg-error 'build "build token or #f" token))
+ (let* ([resource-ch (and token (token-resource-ch token))]
+ [num-jobs (if token
+ ;; we only need whether it's 1 job or more:
+ (if (token-uni? token) 1 2)
+ (hash-ref options 'jobs (default-jobs)))]
+ [seen (if token
+ (token-seen token)
+ (hash))])
+ ;; Start a threading context, so we can have parallel build tasks
+ ((if token (lambda (th) (th)) call-in-main-thread)
+ (lambda ()
+ (define ch (channel))
+ (define state (build-state ch
+ (hash)
+ (hash)
+ (hash)
+ (hash)
+ (hash)
+ (or resource-ch
+ (make-resources num-jobs))
+ (or (hash-ref options 'log? #f)
+ (assoc "ZUO_BUILD_LOG" (hash-ref (runtime-env) 'env)))
+ (= num-jobs 1)))
+ (when resource-ch
+ (release-resource state "nested"))
+ (do-build t state seen #t)
+ (when resource-ch
+ (acquire-resource state "continue from nested")))))))
+
+(define (build/maybe-dep t-in token add-dep?)
+ (unless (token? token) (arg-error 'build/dep "build token" token))
+ (let ([t (coerce-to-target t-in)])
+ (unless (target? t) (arg-error 'build/dep "target" t-in))
+ (when (and (symbol? (target-name t))
+ (not (symbol? (target-name (token-target token)))))
+ (error "build/dep: cannot recur with a phony or data target"))
+ (let* ([state (get-state (token-ch token) "dep")]
+ [acquire? (cond
+ [(eq? 'input (target-kind t))
+ ;; This shortcut avoids release a resource that may
+ ;; be needed to complete a target and having other
+ ;; targets run (and potentially fail) meanwhile
+ #f]
+ [else
+ (release-resource state "dep")
+ #t])]
+ [state (do-build t state (token-seen token) #t)]
+ [state (if add-dep?
+ (record-target-accumulated state (token-target token) t)
+ state)])
+ (put-state (token-ch token) state "dep")
+ (when acquire?
+ (acquire-resource state "continue from dep")))))
+
+(define (build/dep t-in token)
+ (build/maybe-dep t-in token #t))
+
+(define (build/no-dep t-in token)
+ (build/maybe-dep t-in token #f))
+
+;; Detects already built or cycles, and waits for in-progress (as
+;; represented by a channel) to complete
+(define (do-build t state seen top?)
+ (cond
+ [(hash-ref seen (target-key t) #f)
+ (error "build: dependency cycle" (target-name t))]
+ [else
+ (let ([state (ensure-consistent state t)])
+ (define current (target-state state t))
+ (cond
+ [(not current) (force-build t (build-input-or-unbuilt t state seen top?))]
+ [(channel? current) (force-build t state)]
+ [else state]))]))
+
+;; Blocks until an in-progress target completes
+(define (force-build t state)
+ (define current (target-state state t))
+ (cond
+ [(channel? current)
+ ;; Waiting on the channel might block, so relinquish state
+ (put-state (build-state-ch state) state "force")
+ (channel-get current)
+ ;; Put value back to potentially satisfy some other waiting thread:
+ (channel-put current 'still-done)
+ (get-state (build-state-ch state) "force")]
+ [else state]))
+
+;; Shortcut for plain inputs, otherwise starts a build
+(define (build-input-or-unbuilt t state seen top?)
+ (when (build-state-log? state) (alert (~a "checking " (target-name t))))
+ (cond
+ [(eq? (target-kind t) 'input)
+ ;; no dependencies, not need for a thread to build, etc.
+ (define r ((target-get-rule t) (target-name t) #f))
+ (define sha1 (or (rule-sha1 r) (file-sha1/state (target-path t) state)))
+ (when (equal? sha1 no-sha1) ((rule-build r)))
+ (update-target-state state t (list sha1))]
+ [else (build-unbuilt t state seen top?)]))
+
+;; Starts a build for a specific target
+(define (build-unbuilt t state seen top?)
+ (define path (target-name t))
+ (define co-outputs (if (string? path)
+ (hash-ref (target-options t) 'co-outputs '())
+ '()))
+ (define alert-top? (and top? (not (hash-ref (target-options t) 'quiet? #f))))
+ (define dep-top? (and alert-top? (symbol? path)))
+ (define new-seen (hash-set seen (target-key t) #t))
+
+ ;; delete a target file if we don't finish:
+ (define path-handle (and (path-string? path)
+ (not (hash-ref (target-options t) 'precious? #f))
+ (cleanable-file path)))
+
+ ;; get previously recorded result, possibly loading from a file
+ ;; that is cached in the build state
+ (define loaded-state (load-sha1s state t path))
+ (define prev-ts (previous-target-state loaded-state (target-key t)))
+ (define prev-sha1 (car prev-ts))
+ (define prev-dep-sha1s/raw-symbols (cdr prev-ts))
+
+ ;; record a channel as the start's current build state
+ (define result-ch (channel))
+ (define queued-state (update-target-state loaded-state t result-ch))
+
+ (define tok (token t
+ (build-state-ch state)
+ new-seen
+ (build-state-resource-ch state)
+ (build-state-uni? state)))
+ (put-state (token-ch tok) queued-state "rule")
+
+ ;; first phase of the target: get a rule
+ (define r ((target-get-rule t) (target-name t) tok))
+ (unless (rule? r)
+ (error "build: target result is not a rule" r))
+ (define deps (rule-deps r))
+ (define sha1 (or (rule-sha1 r) (if (pair? co-outputs)
+ (files-sha1 (cons path co-outputs) tok)
+ (file-sha1 path tok))))
+ (define to-build (rule-build r))
+ (define build-to-sha1? (and (rule-sha1 r) #t))
+
+ ;; if we recorded any data targets, we need to fix up the keys
+ (define prev-dep-sha1s (foldl (lambda (dep-key dep-sha1s)
+ (cond
+ [(symbol-key? dep-key)
+ (let ([actual-key (translate-key dep-key deps t)])
+ (hash-set (hash-remove dep-sha1s dep-key)
+ actual-key
+ (hash-ref dep-sha1s dep-key)))]
+ [else dep-sha1s]))
+ prev-dep-sha1s/raw-symbols
+ (hash-keys prev-dep-sha1s/raw-symbols)))
+
+ (define rule-state (get-state (token-ch tok) "rule"))
+
+ ;; trigger builds of dependencies, but don't want for them to complete
+ (for-each (make-fetch-dep rule-state new-seen dep-top?) deps)
+
+ ;; now that they're all potentially started, wait for completions
+ (define new-state
+ (foldl (lambda (dep state) (do-build dep state new-seen dep-top?))
+ rule-state
+ deps))
+
+ ;; extract results, assemble in a hash table: <rel-path> -> <sha1>
+ (define dep-reported-sha1s
+ (foldl (lambda (dep dep-sha1s)
+ (add-dependent-target-state dep dep-sha1s new-state))
+ (hash)
+ deps))
+ (define dep-sha1s
+ (cdr (merge-target-accumulated new-state t (cons #f dep-reported-sha1s))))
+
+ ;; calling the build step for `t` might generate more dependencies, but those
+ ;; extra dependencies are supposed to be determined only by the ones declared
+ ;; so far; so, if the dependencies declares so far are consistent with recorded
+ ;; dependencies, and if the target's current hash matches the prvious result,
+ ;; then we can assume that the extra dependencies generated previously are still
+ ;; the extra dependencies this time
+ (define same-so-far?
+ (and (log-changed (and (equal? sha1 prev-sha1) (not (equal? sha1 no-sha1))) path state)
+ (andmap (lambda (dep-key)
+ (log-changed (equal? (hash-ref dep-sha1s dep-key)
+ (hash-ref prev-dep-sha1s dep-key #f))
+ dep-key
+ state))
+ (hash-keys dep-sha1s))))
+
+ (define more-deps
+ (if same-so-far?
+ (foldl (lambda (dep-key more-sha1s)
+ ;; currently, we assume that any additional dependencies
+ ;; added in the build phase were and would be inputs
+ (if (or (hash-ref dep-sha1s dep-key #f)
+ (symbol-key? dep-key))
+ more-sha1s
+ (cons (input-file-target (symbol->string dep-key))
+ more-sha1s)))
+ '()
+ (hash-keys prev-dep-sha1s))
+ '()))
+ (for-each (make-fetch-dep new-state new-seen dep-top?) more-deps)
+ (define newer-state
+ (foldl (lambda (dep state) (do-build dep state new-seen dep-top?))
+ new-state
+ more-deps))
+ (define all-dep-sha1s
+ (foldl (lambda (dep dep-sha1s)
+ (add-dependent-target-state dep dep-sha1s newer-state))
+ dep-sha1s
+ more-deps))
+
+ ;; compare to recorded result, and rebuild if different
+ (cond
+ [(and same-so-far?
+ (andmap (lambda (dep-key)
+ (log-changed (equal? (hash-ref all-dep-sha1s dep-key #f)
+ (hash-ref prev-dep-sha1s dep-key #f))
+ dep-key
+ state))
+ (hash-keys all-dep-sha1s)))
+ ;; no need to rebuild
+ (when path-handle (cleanable-cancel path-handle))
+ (when (and (or alert-top? (hash-ref (target-options t) 'noisy? #f))
+ (equal? prev-sha1 sha1)
+ (not (equal? sha1 phony-sha1)))
+ (alert (~a (target-name t) " is up to date")))
+ (define done-state (update-target-state newer-state t (cons sha1 all-dep-sha1s)))
+ (channel-put result-ch 'done)
+ done-state]
+ [else
+ (unless to-build
+ (error "build: out-of-date target has no build procedure" (target-name t)))
+ (define (build-one finish)
+ (let* ([maybe-sha1 (to-build)] ; build!
+ [sha1 (if build-to-sha1?
+ maybe-sha1
+ (if (pair? co-outputs)
+ (files-sha1 (cons path co-outputs) tok)
+ (file-sha1 path tok)))])
+ (unless (sha1? sha1)
+ (error "build: target-build result is not a sha1" sha1))
+ (when (equal? sha1 no-sha1)
+ (error "rule for target did not create it" (if (pair? co-outputs)
+ (cons path co-outputs)
+ path)))
+ (when path-handle (cleanable-cancel path-handle))
+ (finish
+ (lambda (state)
+ ;; record result:
+ (let* ([ts (if (eq? sha1 phony-sha1)
+ (cons no-sha1 (hash))
+ (cons sha1 dep-sha1s))]
+ [ts (merge-target-accumulated state t ts)]
+ [state (update-target-state/record-sha1s state t ts co-outputs)])
+ (channel-put result-ch 'done)
+ state)))))
+ (let ([state-ch (build-state-ch newer-state)])
+ (cond
+ [(hash-ref (target-options t) 'eager? #f)
+ ;; run build in this thread
+ (put-state state-ch newer-state "build")
+ (build-one (lambda (proc) (proc (get-state state-ch "build"))))]
+ [else
+ ;; run build in its own thread
+ (thread (lambda ()
+ (acquire-resource newer-state path) ; limits process parallelism
+ (build-one
+ (lambda (proc)
+ (release-resource newer-state path)
+ (let* ([state (get-state state-ch "tbuild")]
+ [state (proc state)])
+ (put-state state-ch state "tbuild"))))))
+ newer-state]))]))
+
+(define (make-fetch-dep state seen top?)
+ (if (build-state-uni? state)
+ void
+ (let ([state-ch (build-state-ch state)])
+ (lambda (dep)
+ ;; No one waits for the this thread's work, and it doesn't
+ ;; actually use the build result. It just creates a demand for
+ ;; the build result, so the demand exists concurrent to waiting
+ ;; on dependencies.
+ (thread (lambda ()
+ (let* ([state (get-state state-ch "fetch")]
+ [state (do-build dep state seen top?)])
+ (put-state state-ch state "fetch"))))))))
+
+;; Alternative entry point suitable for use from a script's `main`
+(define (build/command-line targets [opts (hash)])
+ (unless (and (list? targets) (andmap target? targets))
+ (arg-error 'build/command-line "list of targets" targets))
+ (unless (hash? opts)
+ (arg-error 'build/command-line "hash table" opts))
+ (command-line
+ :args-in (or (hash-ref opts 'args #f) (hash-ref (runtime-env) 'args))
+ :usage (or (hash-ref opts 'usage #f)
+ "[<option> ...] <target> ...")
+ :init opts
+ :once-each
+ [opts ("-j" "--jobs") n "Use <n> parallel jobs"+ (let ([v (string->integer n)])
+ (if (and v (> v 0))
+ (hash-set opts 'jobs v)
+ (error "not a positive integer" n)))]
+ :args
+ args
+ (lambda (opts)
+ (cond
+ [(null? args) (if (null? targets)
+ (error "no targets to build")
+ (build (car targets) #f opts))]
+ [else
+ (let ([target1 (find-target (car args) targets (lambda () #f))])
+ (cond
+ [(and target1 (hash-ref (target-options target1) 'command? #f))
+ ;; provide extra arguments to the target:
+ (build (command-target->target target1 (cdr args)) #f opts)]
+ [else
+ ;; treat all arguments as targets:
+ (let ([run-targets (map (lambda (arg)
+ (or (find-target arg targets (lambda () #f))
+ (error (~a "unknown target: " arg))))
+ args)])
+ (build (if (= (length run-targets) 1)
+ (car run-targets)
+ (make-target (string->uninterned-symbol "multi")
+ (lambda (token)
+ (make-phony-rule run-targets void))))
+ #f
+ opts))]))]))))
+
+(define (build/command-line* targets-at [at-dir build-path] [opts (hash)])
+ (let* ([args (or (hash-ref opts 'args #f) (hash-ref (runtime-env) 'args))])
+ (define (var-split str)
+ (let* ([alpha? (lambda (c) (or (and (>= c (char "a")) (<= c (char "z")))
+ (and (>= c (char "A")) (<= c (char "Z")))
+ (= c (char "_"))))]
+ [alphanum? (lambda (c) (or (alpha? c)
+ (and (>= c (char "0")) (<= c (char "9")))))])
+ (and (> (string-length str) 1)
+ (alpha? (string-ref str 0))
+ (let loop ([i 0])
+ (cond
+ [(= i (string-length str)) #f]
+ [(= (char "=") (string-ref str i))
+ (cons (string->symbol (substring str 0 i)) (substring str (+ i 1)))]
+ [(alphanum? (string-ref str i)) (loop (+ i 1))]
+ [else #f])))))
+ (let loop ([args args] [accum-args '()] [vars (hash)])
+ (cond
+ [(null? args) (build/command-line
+ (targets-at at-dir vars)
+ (let* ([opts (hash-set opts 'args (reverse accum-args))]
+ [opts (hash-set opts 'usage
+ "[<option> | <var>=<val>] ... [<target> | <var>=<val>] ...")])
+ opts))]
+ [(string=? (car args) "--") (loop '() (append (reverse args) accum-args) vars)]
+ [else
+ (let ([var+val (var-split (car args))])
+ (if var+val
+ (loop (cdr args) accum-args (hash-set vars (car var+val) (cdr var+val)))
+ (loop (cdr args) (cons (car args) accum-args) vars)))]))))
+
+(define (find-target name targets [fail-k (lambda () (error "target not found" name))])
+ (unless (path-string? name) (arg-error 'find-target "path string" name))
+ (unless (and (list? targets) (andmap target? targets))
+ (arg-error 'find-target "list of targets" targets))
+ (unless (procedure? fail-k) (arg-error 'find-target "procedure" fail-k))
+ (define len (string-length name))
+ (define (matches? t-name)
+ (let* ([t-name (~a t-name)]
+ [t-len (string-length t-name)])
+ (and (>= t-len len)
+ (let ([start (- t-len len)])
+ (and (string=? name (substring t-name start))
+ (or (= t-len len)
+ (= (char "/") (string-ref t-name (- start 1)))
+ (= (char "\\") (string-ref t-name (- start 1)))))))))
+ (or (ormap (lambda (t) (and (or (matches? (target-name t))
+ (ormap matches? (hash-ref (target-options t) 'co-outputs '())))
+ t))
+ targets)
+ (fail-k)))
+
+(define (command-target? t)
+ (and (target? t)
+ (and (hash-ref (target-options t) 'command? #f) #t)))
+
+(define (command-target->target t args)
+ (unless (command-target? t) (arg-error 'command-target->target "command target" t))
+ (unless (list? args) (arg-error 'command-target->target "list" args))
+ (let ([new-get-rule (let ([get-rule (target-get-rule t)])
+ (lambda (path token)
+ (apply get-rule (list* path token args))))])
+ (target-set-options (target-set-get-rule t new-get-rule)
+ (hash-remove (target-options t) 'command?))))
+
+(define (make-at-dir s)
+ (lambda paths
+ (unless (null? paths)
+ (unless (path-string? (car paths))
+ (arg-error 'at-dir "path string" (car paths))))
+ (for-each (lambda (path)
+ (unless (and (path-string? path)
+ (relative-path? path))
+ (arg-error 'at-dir "relative path string" path)))
+ (if (null? paths) '() (cdr paths)))
+ (if (and (pair? paths)
+ (not (relative-path? (car paths))))
+ (apply build-path paths)
+ (apply build-path (cons s paths)))))
+
+;; Exports `targets`, which is a function that takes an `at-dir`
+;; function, while also setting up a `main` submodule to call
+;; `build/command-line`
+(define-syntax (provide-targets stx)
+ (unless (and (list? stx) (= 2 (length stx)))
+ (bad-syntax stx))
+ (define targets-at-id (cadr stx))
+ (unless (identifier? targets-at-id) (bad-syntax stx))
+ (define args-id (string->uninterned-symbol "args"))
+ (list (quote-syntax begin)
+ `(,(quote-syntax provide) (,(quote-syntax rename-out)
+ [,targets-at-id targets-at]))
+ `(,(quote-syntax module+)
+ main
+ (,(quote-syntax build/command-line*)
+ ,targets-at-id
+ ;; builds to current directory by default:
+ build-path))))
+
+(define-syntax (bounce-to-targets stx)
+ (unless (and (list? stx) (= 4 (length stx)))
+ (bad-syntax stx))
+ `(,(quote-syntax do-bounce-to-targets)
+ ,(quote-syntax at-source)
+ ,(list-ref stx 1)
+ ,(list-ref stx 2)
+ ,(list-ref stx 3)))
+
+(define (do-bounce-to-targets at-source config-file config-key script-file)
+ (unless (path-string? config-file) (arg-error 'bounce-to-targets "path string" config-file))
+ (unless (symbol? config-key) (arg-error 'bounce-to-targets "symbol" config-key))
+ (unless (path-string? script-file) (arg-error 'bounce-to-targets "path string" script-file))
+ (define config (config-file->hash (at-source config-file)))
+ (build/command-line* (dynamic-require ((make-at-dir (or (car (split-path config-file)) "."))
+ (hash-ref config 'srcdir)
+ script-file)
+ 'targets-at)
+ at-source))
+
+;; ------------------------------------------------------------
+;; Helpers for reading and updating build state
+
+(define (target-state state t)
+ (hash-ref (build-state-target-state state) (target-key t) #f))
+
+(define (add-dependent-target-state dep dep-sha1s state)
+ (define ts (target-state state dep))
+ (define sha1 (car ts))
+ (hash-set dep-sha1s (target-key dep) (if (eq? sha1 phony-sha1) no-sha1 sha1)))
+
+(define (record-target-accumulated state for-t t)
+ (let* ([accum-key (target-key for-t)]
+ [dep-sha1s (hash-ref (build-state-target-accum state) accum-key (hash))]
+ [dep-sha1s (add-dependent-target-state t dep-sha1s state)])
+ (build-state-set-target-accum state (hash-set (build-state-target-accum state) accum-key dep-sha1s))))
+
+(define (merge-target-accumulated state t ts)
+ (let ([more-dep-sha1s (hash-ref (build-state-target-accum state) (target-key t) #f)])
+ (if more-dep-sha1s
+ (cons (car ts)
+ (foldl (lambda (dep-key dep-sha1s)
+ (hash-set dep-sha1s dep-key (hash-ref more-dep-sha1s dep-key)))
+ (cdr ts)
+ (hash-keys more-dep-sha1s)))
+ ts)))
+
+(define (update-target-state state t ts)
+ (build-state-set-target-state state
+ (hash-set (build-state-target-state state)
+ (target-key t)
+ ts)))
+
+(define (update-target-state/record-sha1s state t ts co-outputs)
+ (unless (eq? 'phony (target-kind t))
+ (db-record-target-sha1s (target-db-dir t) (target-name t) ts co-outputs))
+ (update-target-state state t ts))
+
+(define (load-sha1s state t path)
+ (cond
+ [(symbol? path) state]
+ [else
+ (define db+tc (db-load-sha1s (target-db-dir t)
+ path
+ (build-state-db state)
+ (build-state-time-cache state)))
+ (if db+tc
+ (let ([state (build-state-set-db state (car db+tc))])
+ (build-state-set-time-cache state (cdr db+tc)))
+ state)]))
+
+(define (previous-target-state state key)
+ (or (hash-ref (build-state-db state) key #f)
+ (cons no-sha1 (hash))))
+
+(define (ensure-consistent state t)
+ (let* ([saw (build-state-saw-targets state)]
+ [old-t (hash-ref saw (target-key t) #f)])
+ (cond
+ [old-t
+ (unless (or (eq? t old-t)
+ (eq? (target-kind t) 'input)
+ (eq? (target-kind old-t) 'input))
+ (error "build: multiple targets for same output" (target-name t)))
+ state]
+ [else
+ (build-state-set-saw-targets state (hash-set saw (target-key t) t))])))
+
+(define (file-sha1 path token)
+ (unless (path-string? path) (arg-error 'file-sha1 "path string" path))
+ (unless (or (not token) (token? token)) (error 'file-sha1 "build-token" token))
+ (let ([state (and token (get-state (token-ch token) "sha1"))])
+ (when state (put-state (token-ch token) state "sha1"))
+ (file-sha1/state path state)))
+
+(define (files-sha1 paths token)
+ (let ([sha1s (map (lambda (path) (file-sha1 path token)) paths)])
+ (if (ormap (lambda (s) (string=? s no-sha1)) sha1s)
+ no-sha1
+ (apply ~a sha1s))))
+
+(define (file-sha1/state path state)
+ (or (file-sha1/cached path (and state (build-state-time-cache state)))
+ no-sha1))
+
+;; translate a data key as loaded from a previous-run to a key as
+;; instantiated for this run
+(define (translate-key key deps t)
+ (let ([sym (symbol-key->symbol key)])
+ (or (ormap (lambda (dep)
+ (and (eq? (target-name dep) sym)
+ (target-key dep)))
+ deps)
+ key)))
+
+;; see also "private/build-db.zuo"
+
+;; ------------------------------------------------------------
+;; Generic helpers
+
+(define (get-state ch who)
+ (channel-get ch))
+
+(define (put-state ch state who)
+ (channel-put ch state))
+
+(define (make-resources n)
+ (define ch (channel))
+ (let loop ([n n])
+ (unless (= n 0)
+ (channel-put ch 'go)
+ (loop (- n 1))))
+ ch)
+
+(define (acquire-resource state who)
+ (channel-get (build-state-resource-ch state))
+ (void))
+
+(define (release-resource state who)
+ (channel-put (build-state-resource-ch state) 'go))
+
+(define (log-changed same? who state)
+ (unless same?
+ (when (build-state-log? state)
+ (let ([who (if (and (symbol? who) (symbol-key? who))
+ (~a "'" who)
+ who)])
+ (alert (~a who " changed")))))
+ same?)
+
+(define (default-jobs)
+ (let ([a (assoc "ZUO_JOBS" (hash-ref (runtime-env) 'env '()))])
+ (or (and a (string->integer (cdr a)))
+ 1)))
+
+;; ------------------------------------------------------------
+;; `make`-like target and dependency declaration
+
+(define (make-targets specs)
+ (unless (list? specs) (arg-error 'make-targets "list") specs)
+ (for-each (lambda (spec)
+ (unless (and (list? spec)
+ (pair? spec)
+ (or (and (eq? (car spec) ':db-dir)
+ (= 2 (length spec))
+ (path-string? (list-ref spec 1)))
+ (and
+ (or (and (eq? (car spec) ':target)
+ (>= (length spec) 4)
+ (procedure? (list-ref spec 3))
+ (or (path-string? (list-ref spec 1))
+ (symbol? (list-ref spec 1))
+ (and (pair? (list-ref spec 1))
+ (list? (list-ref spec 1))
+ (andmap path-string? (list-ref spec 1))))
+ (andmap (lambda (t) (hash-ref keyword-to-option t #f))
+ (list-tail spec 4)))
+ (and (eq? (car spec) ':depend)
+ (= 3 (length spec))
+ (or (path-string? (list-ref spec 1))
+ (and (list? (list-ref spec 1))
+ (andmap path-string? (list-ref spec 1))))))
+ (list? (list-ref spec 2))
+ (andmap (lambda (dep) (or (path-string? dep) (symbol? dep) (target? dep)))
+ (list-ref spec 2)))))
+ (error "make-targets: bad specification line" spec)))
+ specs)
+ (define target-specs (filter (lambda (spec) (eq? ':target (car spec))) specs))
+ (define phony-keys (foldl (lambda (spec phony-keys)
+ (let ([name (list-ref spec 1)])
+ (if (symbol? name)
+ (hash-set phony-keys name (string->uninterned-symbol (symbol->string name)))
+ phony-keys)))
+ (hash)
+ target-specs))
+ (define (name->key name) (if (symbol? name)
+ (or (hash-ref phony-keys name #f)
+ (error "make-targets: missing phony target for dependency" name))
+ (string->symbol name)))
+ (define deps (foldl (lambda (spec deps)
+ (cond
+ [(eq? (car spec) ':db-dir)
+ (when (hash-ref deps ':db-dir #f)
+ (error "make-targets: multiple `:db-dir` lines"))
+ (hash-set deps ':db-dir (list-ref spec 1))]
+ [else
+ (foldl (lambda (path deps)
+ (let ([key (name->key path)])
+ (hash-set deps key
+ (append (reverse (list-ref spec 2))
+ (hash-ref deps key '())))))
+ deps
+ (let ([ps (list-ref spec 1)])
+ (if (list? ps)
+ ps
+ (list ps))))]))
+ (hash)
+ specs))
+ (define target-vars (foldl (lambda (spec target-vars)
+ (let* ([names (list-ref spec 1)]
+ [name (if (pair? names) (car names) names)]
+ [key (name->key name)]
+ [var (variable key)])
+ (cond
+ [(pair? names)
+ (foldl (lambda (name target-vars)
+ (let ([key (name->key name)])
+ (when (hash-ref target-vars key #f)
+ (error "make-targets: duplicate target" name))
+ (hash-set target-vars key var)))
+ target-vars
+ (if (pair? names)
+ names
+ (list name)))]
+ [else
+ (when (hash-ref target-vars key #f)
+ (error "make-targets: duplicate target" name))
+ (hash-set target-vars key var)])))
+ (hash)
+ target-specs))
+ (define dep->target (lambda (dep)
+ (if (target? dep)
+ dep
+ (let ([var (hash-ref target-vars (name->key dep) #f)])
+ (if var
+ (variable-ref var)
+ (input-file-target dep))))))
+ (define shared-options (let ([db-dir (hash-ref deps ':db-dir #f)])
+ (if db-dir
+ (hash 'db-dir db-dir)
+ (hash))))
+ (define targets (foldl (lambda (spec targets)
+ (let* ([names (list-ref spec 1)]
+ [name (if (pair? names) (car names) names)]
+ [key (name->key name)]
+ [var (hash-ref target-vars key)]
+ [get-deps (lambda ()
+ (if (pair? names)
+ (apply append
+ (map (lambda (name)
+ (let ([key (name->key name)])
+ (map dep->target (reverse (hash-ref deps key '())))))
+ names))
+ (map dep->target (reverse (hash-ref deps key '())))))]
+ [t (make-target name
+ (if (symbol? name)
+ (lambda (token . args)
+ (make-phony-rule (get-deps)
+ (lambda ()
+ (apply (list-ref spec 3) (cons token args)))))
+ (lambda (path token)
+ (make-rule (get-deps)
+ (lambda ()
+ ((list-ref spec 3) path token)))))
+ (foldl (lambda (tag options)
+ (hash-set options (hash-ref keyword-to-option tag) #t))
+ (let* ([options shared-options]
+ [options (if (pair? names)
+ (hash-set options 'co-outputs (cdr names))
+ options)])
+ options)
+ (if (eq? (car spec) ':target)
+ (list-tail spec 4)
+ '())))])
+ (variable-set! var t)
+ (cons t targets)))
+ '()
+ target-specs))
+ (reverse targets))
+
+(define keyword-to-option
+ (hash ':precious 'precious?
+ ':command 'command?
+ ':noisy 'noisy?
+ ':quiet 'quiet?
+ ':eager 'eager?))
--- /dev/null
+++ b/lib/zuo/c.zuo
@@ -1,0 +1,122 @@
+#lang zuo/base
+(require "shell.zuo")
+
+(provide c-compile
+ c-link
+ c-ar
+
+ .c->.o
+ .exe
+ .a
+
+ config-include
+ config-define
+ config-merge)
+
+(define (c-compile .o .c config)
+ (unless (path-string? .o) (arg-error 'c-compile "path string" .o))
+ (unless (or (path-string? .c)
+ (and (list? .c) (andmap path-string? .c)))
+ (arg-error 'c-compile "path string or list of paths strings" .c))
+ (unless (hash? config) (arg-error 'c-compile "hash table" config))
+ (define windows? (eq? (hash-ref (runtime-env) 'system-type) 'windows))
+ (define lookup (make-lookup config))
+ (define command
+ (build-shell (or (lookup 'CC)
+ (if windows?
+ "cl.exe"
+ "cc"))
+ (or (lookup 'CPPFLAGS) "")
+ (or (lookup 'CFLAGS) "")
+ (if windows? (if (path-string? .c) "/Fo:" "/Fe:") "-o") (string->shell .o)
+ (if (string? .c)
+ (build-shell "-c" (string->shell .c))
+ (apply build-shell (map string->shell .c)))
+ (if (string? .c)
+ ""
+ (build-shell (or (lookup 'LDFLAGS) "")
+ (or (lookup 'LIBS) "")))))
+ (shell/wait command (hash 'desc "compile")))
+
+(define (c-link .exe ins config)
+ (unless (path-string? .exe) (arg-error 'c-link "path string" .exe))
+ (unless (and (list? ins) (andmap path-string? ins)) (arg-error 'c-link "list of path strings" ins))
+ (unless (hash? config) (arg-error 'c-link "hash table" config))
+ (define windows? (eq? (hash-ref (runtime-env) 'system-type) 'windows))
+ (define lookup (make-lookup config))
+ (define command
+ (build-shell (or (lookup 'CC)
+ (if windows?
+ "cl.exe"
+ "cc"))
+ (or (lookup 'CFLAGS) "")
+ (if windows? "/Fe:" "-o") (string->shell .exe)
+ (string-join (map string->shell ins))
+ (or (lookup 'LDFLAGS) "")
+ (or (lookup 'LIBS) "")))
+ (shell/wait command (hash 'desc "link")))
+
+(define (c-ar .a ins config)
+ (unless (path-string? .a) (arg-error 'c-ar "path string" .exe))
+ (unless (and (list? ins) (andmap path-string? ins)) (arg-error 'c-ar "list of path strings" ins))
+ (unless (hash? config) (arg-error 'c-ar "hash table" config))
+ (define windows? (eq? (hash-ref (runtime-env) 'system-type) 'windows))
+ (define lookup (make-lookup config))
+ (shell/wait
+ (build-shell (or (lookup 'AR)
+ (if windows?
+ "lib.exe"
+ "ar"))
+ (or (lookup 'ARFLAGS) "")
+ (string->shell (if windows? (~a "/OUT:" .a) .a))
+ (string-join (map string->shell ins)))
+ (hash 'desc
+ "library creation")))
+
+(define (make-lookup config)
+ (lambda (key) (hash-ref config key #f)))
+
+(define (.c->.o .c)
+ (unless (path-string? .c) (arg-error '.c->.o "path string" .c))
+ (path-replace-extension .c (if (eq? (hash-ref (runtime-env) 'system-type) 'windows)
+ ".obj"
+ ".o")))
+
+(define (.exe name)
+ (unless (path-string? name) (arg-error '.exe "string" name))
+ (if (eq? (hash-ref (runtime-env) 'system-type) 'windows)
+ (~a name ".exe")
+ name))
+
+(define (.a name)
+ (unless (path-string? name) (arg-error '.a "string" name))
+ (if (eq? (hash-ref (runtime-env) 'system-type) 'windows)
+ (~a name ".lib")
+ (let ([l (split-path name)])
+ (build-path (or (car l) ".") (~a "lib" (cdr l) ".a")))))
+
+(define (config-include config . paths)
+ (unless (hash? config) (arg-error 'config-include "hash table" config))
+ (foldl (lambda (path config)
+ (unless (path-string? path) (arg-error 'config-include "path string" path))
+ (do-config-merge config 'CPPFLAGS (~a "-I" (string->shell path))))
+ config
+ paths))
+
+(define (config-define config . defs)
+ (unless (hash? config) (arg-error 'config-define "hash table" config))
+ (foldl (lambda (def config)
+ (unless (string? def) (arg-error 'config-define "string" def))
+ (do-config-merge config 'CPPFLAGS (~a "-D" (string->shell def))))
+ config
+ defs))
+
+(define (config-merge config key shell-str)
+ (unless (hash? config) (arg-error 'config-merge "hash table" config))
+ (unless (symbol? key) (arg-error 'config-merge "symbol" key))
+ (unless (string? shell-str) (arg-error 'config-merge "string" shell-str))
+ (do-config-merge config key shell-str))
+
+(define (do-config-merge config key shell-str)
+ (define now-str (hash-ref config key ""))
+ (hash-set config key (build-shell now-str shell-str)))
--- /dev/null
+++ b/lib/zuo/cmdline.zuo
@@ -1,0 +1,172 @@
+#lang zuo/base
+(require "private/cmdline-run.zuo"
+ (only-in "private/base/define-help.zuo"
+ check-args))
+
+(provide command-line)
+
+(define-syntax (command-line stx)
+ (unless (list? stx) (bad-syntax stx))
+ (define all-stx stx)
+ (define cmd-id 'cmd)
+
+ (define (formals->spec stx)
+ (define (id->desc id) (~a "<" (syntax-e id) ">"))
+ (let loop ([stx stx] [rev-reqd '()] [rev-opt '()])
+ (cond
+ [(identifier? stx) (list (reverse rev-reqd)
+ (reverse (cons (id->desc stx) rev-opt))
+ '...)]
+ [(null? stx) (list (reverse rev-reqd) (reverse rev-opt))]
+ [(identifier? (car stx)) (loop (cdr stx)
+ (cons (id->desc (car stx))
+ rev-reqd)
+ rev-opt)]
+ [else (loop (cdr stx)
+ rev-reqd
+ (cons (id->desc (caar stx))
+ rev-opt))])))
+
+ (define (parse-flag-line mode group-id accum line-stx)
+ (define maybe-cmd-id (and (and (pair? all-stx)
+ (identifier? (car all-stx)))
+ (car line-stx)))
+ (define stx (if maybe-cmd-id
+ (cdr line-stx)
+ line-stx))
+ (unless (and (list? stx)
+ (>= (length stx) 2))
+ (syntax-error "command-line: bad syntax for flag" line-stx))
+ (unless (or (string? (car stx))
+ (and (list? (car stx))
+ (andmap string? (car stx))))
+ (syntax-error "command-line: bad flag-string list for flag" line-stx))
+ ;; check identifiers and then help string/sequence, with at least one more:
+ (unless (let loop ([stx (cdr stx)])
+ (cond
+ [(null? (cdr stx)) #f]
+ [(string? (car stx)) #t]
+ [(list? (car stx)) #t]
+ [(identifier? (car stx)) (loop (cdr stx))]
+ [else #f]))
+ (syntax-error "command-line: missing or misplaced help string/sequence for flag" line-stx))
+ (define flags (if (string? (car stx)) (list (car stx)) (car stx)))
+ (define ids (let loop ([stx (cdr stx)])
+ (if (identifier? (car stx))
+ (cons (car stx) (loop (cdr stx)))
+ '())))
+ (define help-str (let loop ([stx (cdr stx)])
+ (if (identifier? (car stx))
+ (loop (cdr stx))
+ (car stx))))
+ (define body (let loop ([stx (cdr stx)])
+ (if (identifier? (car stx))
+ (loop (cdr stx))
+ (cdr stx))))
+ (define flag-id (string->uninterned-symbol "flag-handler"))
+ (define key (or group-id (and (not (eq? mode 'multi)) flag-id)))
+ (define proc `(,(quote-syntax flag-parser)
+ ',key
+ (,(quote-syntax lambda)
+ ,ids
+ ,@(if maybe-cmd-id
+ `((,(quote-syntax lambda) (,maybe-cmd-id) ,@body))
+ body))
+ ',(formals->spec ids)))
+ (define spec (list (map (lambda (id) (~a "<" (syntax-e id) ">")) ids)
+ '()))
+ (define accum+expr
+ (hash-set accum 'flags-expr
+ `(,(quote-syntax let)
+ ((,flag-id ,proc))
+ ,(let loop ([flags flags])
+ (if (null? flags)
+ (hash-ref accum 'flags-expr)
+ `(,(quote-syntax cons)
+ (,(quote-syntax cons) ,(car flags) ,flag-id)
+ ,(loop (cdr flags))))))))
+ (hash-set accum+expr 'help
+ (cons (list (quote-syntax list)
+ (list (quote-syntax quote) key)
+ (list (quote-syntax quote) flags)
+ (list (quote-syntax quote) spec)
+ (if (string? help-str)
+ (list (quote-syntax list) help-str)
+ (cons (quote-syntax list) help-str)))
+ (hash-ref accum 'help '()))))
+
+ (define (expected-mode stx)
+ (syntax-error "command-line: expected tag like `:multi` or `:args`" (car stx)))
+
+ (define (check-already accum what)
+ (when (hash-ref accum what #f)
+ (syntax-error (~a "command-line: multiple `:" what "` clauses") all-stx)))
+
+ (let loop ([stx (cdr stx)] [mode #f] [group-id #f] [accum (hash 'flags-expr (quote-syntax '()))])
+ (cond
+ [(null? stx)
+ (list (quote-syntax run-cmdline)
+ (hash-ref accum 'program (quote-syntax (hash-ref (runtime-env) 'script "[script]")))
+ (hash-ref accum 'init (quote-syntax (hash)))
+ (hash-ref accum 'args-in (quote-syntax (hash-ref (runtime-env) 'args '())))
+ (hash-ref accum 'flags-expr)
+ (hash-ref accum 'finish (quote-syntax (lambda () (lambda (cmd) cmd))))
+ (hash-ref accum 'finish-spec (quote-syntax '(() ())))
+ (hash-ref accum 'usage #f)
+ (cons (quote-syntax list) (reverse (hash-ref accum 'help '()))))]
+ [(identifier? (car stx))
+ (define head (syntax-e (car stx)))
+ (cond
+ [(eq? head ':multi) (loop (cdr stx) 'multi #f accum)]
+ [(eq? head ':once-each) (loop (cdr stx) 'once #f accum)]
+ [(eq? head ':once-any) (loop (cdr stx) 'once (string->uninterned-symbol "once") accum)]
+ [(eq? head ':init)
+ (unless (pair? (cdr stx))
+ (syntax-error "command-line: missing expression for `:init`" all-stx))
+ (check-already accum 'init)
+ (loop (cddr stx) #f #f (hash-set accum 'init (cadr stx)))]
+ [(eq? head ':args)
+ (unless (>= (length stx) 3)
+ (syntax-error "command-line: bad syntax at `:args`" all-stx))
+ (check-args all-stx (cadr stx))
+ (loop '() #f #f (hash-set (hash-set accum
+ 'finish `(,(quote-syntax lambda)
+ ,(cadr stx)
+ ,@(cddr stx)))
+ 'finish-spec `(,(quote-syntax quote)
+ ,(formals->spec (cadr stx)))))]
+ [(eq? head ':args-in)
+ (unless (pair? (cdr stx))
+ (syntax-error "command-line: bad syntax at `:args-in`" all-stx))
+ (check-already accum 'args-in)
+ (loop (cddr stx) #f #f (hash-set accum 'args-in (list (quote-syntax check-args-in) (cadr stx))))]
+ [(eq? head ':program)
+ (unless (pair? (cdr stx))
+ (syntax-error "command-line: bad syntax at `:program`" all-stx))
+ (check-already accum 'program)
+ (loop (cddr stx) #f #f (hash-set accum 'program (list (quote-syntax check-program) (cadr stx))))]
+ [(eq? head ':usage)
+ (unless (pair? (cdr stx))
+ (syntax-error "command-line: bad syntax at `:usage`" all-stx))
+ (check-already accum 'usage)
+ (loop (cddr stx) #f #f (hash-set accum 'usage (list (quote-syntax check-usage) (cadr stx))))]
+ [else (expected-mode stx)])]
+ [(not mode)
+ (expected-mode stx)]
+ [else
+ (loop (cdr stx) mode group-id (parse-flag-line mode group-id accum (car stx)))])))
+
+(define (check-args-in args)
+ (unless (and (list? args) (andmap string? args))
+ (error "command-line: result for `:args-in` is not a list of strings" args))
+ args)
+
+(define (check-program prog)
+ (unless (string? prog)
+ (error "command-line: result for `:program` is not a string" prog))
+ prog)
+
+(define (check-usage usage)
+ (unless (string? usage)
+ (error "command-line: result for `:usage` is not a string" usage))
+ usage)
--- /dev/null
+++ b/lib/zuo/config.zuo
@@ -1,0 +1,46 @@
+#lang zuo/base
+
+(provide config-file->hash)
+
+(define (config-file->hash path [vars (hash)])
+ (unless (path-string? path) (arg-error 'config->hash "path string" path))
+ (unless (hash? vars) (arg-error 'config->hash "hash table" vars))
+ (define content (file->string path))
+ (define no-cr-content (string-join (string-split content "\r") ""))
+ (define lines (string-split (string-join (string-split no-cr-content "\\\n") "") "\n"))
+ (define config
+ (foldl (lambda (line accum)
+ (define positions ; (list var-start var-end =-pos) or #f
+ (let loop ([i 0] [start #f] [end #f])
+ (cond
+ [(= i (string-length line)) #f]
+ [else
+ (let ([c (string-ref line i)])
+ (cond
+ [(= (char "=") c) (and start (list start (or end i) i))]
+ [(or (= (char "_") c)
+ (and (<= (char "a") c)
+ (<= c (char "z")))
+ (and (<= (char "A") c)
+ (<= c (char "Z")))
+ (and (<= (char "0") c)
+ (<= c (char "9"))))
+ (and (not end)
+ (loop (+ i 1) (or start i) #f))]
+ [(= (char " ") c)
+ (if start
+ (loop (+ i 1) start (or end i))
+ (loop (+ i 1) #f #f))]
+ [else #f]))])))
+ (cond
+ [positions
+ (define var (string->symbol (substring line (car positions) (cadr positions))))
+ (define rhs (substring line (+ (list-ref positions 2) 1) (string-length line)))
+ (hash-set accum var (string-trim rhs))]
+ [else accum]))
+ (hash)
+ lines))
+ (foldl (lambda (key config)
+ (hash-set config key (hash-ref vars key) ))
+ config
+ (hash-keys vars)))
--- /dev/null
+++ b/lib/zuo/datum.zuo
@@ -1,0 +1,10 @@
+#lang zuo/kernel
+
+;; `#lang zuo/datum` creates a module that just exports S-expressions,
+;; which can useful with `include` for building `zuo` and `zuo/hygienic`
+;; from a shared source
+
+(hash 'read-and-eval
+ (lambda (str start mod-path)
+ (let ([es (string-read str start mod-path)])
+ (hash 'datums es))))
--- /dev/null
+++ b/lib/zuo/glob.zuo
@@ -1,0 +1,156 @@
+#lang zuo/base
+
+(provide glob-match?
+ glob->matcher)
+
+(define (glob-match? glob str)
+ (unless (string? glob) (arg-error 'glob-match? "string" glob))
+ (unless (string? str) (arg-error 'glob-match? "string" str))
+ ((compile-glob 'glob-match? glob #f) str))
+
+(define (glob->matcher glob)
+ (unless (string? glob) (arg-error 'glob->matcher "string" glob))
+ (let ([m (compile-glob 'glob->matcher glob #f)])
+ (lambda (str)
+ (unless (string? str) (error "glob matcher: not a string" str))
+ (m str))))
+
+(define (compile-glob who glob no-dot?)
+ (let ([glen (string-length glob)])
+ (let loop ([i 0] [k (lambda (pred len)
+ (if len
+ (lambda (str)
+ (and (= len (string-length str))
+ (pred str 0)))
+ (lambda (str)
+ (pred str 0))))])
+ (cond
+ [(= i (string-length glob))
+ (k (lambda (str pos) #t)
+ 0)]
+ [(literal? glob i glen)
+ (let ([literal (substring glob i glen)])
+ (k (lambda (str pos)
+ (string=? literal (substring str pos (string-length str))))
+ (- glen i)))]
+ [else
+ (let ([c (string-ref glob i)])
+ (cond
+ [(= (char "?") c)
+ (loop (+ i 1)
+ (lambda (next len)
+ (if len
+ (k (if (and no-dot? (= i 0))
+ (lambda (str pos) (if (= (char ".") (string-ref str pos))
+ #f
+ (next str (+ pos 1))))
+ (lambda (str pos) (next str (+ pos 1))))
+ (+ len 1))
+ (k (if (and no-dot? (= i 0))
+ (lambda (str pos) (and (< pos (string-length str))
+ (if (= (char ".") (string-ref str pos))
+ #f
+ (next str (+ pos 1)))))
+ (lambda (str pos) (and (< pos (string-length str))
+ (next str (+ pos 1)))))
+ #f))))]
+ [(= (char "*") c)
+ (loop (+ i 1)
+ (lambda (next len)
+ (k (let ([here (if len
+ (lambda (str pos)
+ (and (>= (string-length str) (+ pos len))
+ (next str (- (string-length str) len))))
+ (letrec ([star (lambda (str pos)
+ (or (next str pos)
+ (and (< pos (string-length str))
+ (star str (+ pos 1)))))])
+ star))])
+ (if (and no-dot? (= i 0))
+ (lambda (str pos) (and (> (string-length str) pos)
+ (not (= (char ".") (string-ref str pos)))
+ (here str pos)))
+ here))
+ #f)))]
+ [(= (char "[") c)
+ (let* ([j (let loop ([j (+ i 1)] [mode 'start])
+ (if (= j glen)
+ (error (~a who ": unclosed square bracket in glob" glob))
+ (let ([c (string-ref glob j)])
+ (cond
+ [(= (char "]") c)
+ (if (eq? mode 'inside)
+ j
+ (loop (+ j 1) 'inside))]
+ [(= (char "^") c)
+ (if (eq? mode 'start)
+ (loop (+ j 1) 'second)
+ (loop (+ j 1) 'inside))]
+ [else (loop (+ j 1) 'inside)]))))]
+ [invert? (and (> j (+ i 1))
+ (= (char "^") (string-ref glob (+ i 1))))]
+ [ranges (substring glob (+ i (if invert? 2 1)) j)]
+ [make-str (lambda (n c)
+ (let loop ([n n])
+ (cond
+ [(= n 0) ""]
+ [(= n 1) (string c)]
+ [else (let ([a (quotient n 2)])
+ (~a (loop a) (loop (- n a))))])))]
+ [table (make-str 256 (if invert? (char "y") (char "n")))]
+ [table (if (and no-dot? (= i 0))
+ (~a (substring table 0 (char ".")) "n" (substring table (+ (char ".") 1) 256))
+ table)]
+ [table (let loop ([table table] [k 0])
+ (cond
+ [(= k (string-length ranges)) table]
+ [(and (<= k (- (string-length ranges) 3))
+ (= (char "-") (string-ref ranges (+ k 1))))
+ (let ([start (string-ref ranges k)]
+ [end (string-ref ranges (+ k 2))])
+ (unless (<= start end)
+ (error (~a who ": bad range in glob") glob))
+ (loop (~a (substring table 0 start)
+ (make-str (- (+ end 1) start) (if invert? (char "n") (char "y")))
+ (substring table (+ end 1) 256))
+ (+ k 3)))]
+ [else (let ([c (string-ref ranges k)])
+ (loop (~a (substring table 0 c)
+ (if invert? "n" "y")
+ (substring table (+ c 1) 256))
+ (+ k 1)))]))])
+ (loop (+ j 1)
+ (lambda (next len)
+ (if len
+ (k (lambda (str pos)
+ (and (= (char "y") (string-ref table (string-ref str pos)))
+ (next str (+ pos 1))))
+ (+ len 1))
+ (k (lambda (str pos)
+ (and (< pos (string-length str))
+ (= (char "y") (string-ref table (string-ref str pos)))
+ (next str (+ pos 1))))
+ #f)))))]
+ [else (loop (+ i 1)
+ (lambda (next len)
+ (if len
+ (k (lambda (str pos)
+ (and (= c (string-ref str pos))
+ (next str (+ pos 1))))
+ (+ len 1))
+ (k (lambda (str pos)
+ (and (< pos (string-length str))
+ (= c (string-ref str pos))
+ (next str (+ pos 1))))
+ #f))))]))]))))
+
+(define (literal? glob start end)
+ (let loop ([start start])
+ (cond
+ [(= start end) #t]
+ [else
+ (let ([c (string-ref glob start)])
+ (and (not (or (= c (char "*"))
+ (= c (char "?"))
+ (= c (char "["))))
+ (loop (+ start 1))))])))
--- /dev/null
+++ b/lib/zuo/hygienic.zuo
@@ -1,0 +1,5 @@
+#lang zuo/kernel
+
+(let ([maker (hash-ref (module->hash 'zuo/private/base-hygienic) 'make-language #f)])
+ ;; `zuo/hygenic` is analogous to `zuo/base`, not `zuo`
+ (maker 'zuo/private/base-hygienic/main))
--- /dev/null
+++ b/lib/zuo/main.zuo
@@ -1,0 +1,4 @@
+#lang zuo/kernel
+
+(let ([maker (hash-ref (module->hash 'zuo/private/base) 'make-language #f)])
+ (maker 'zuo/private/main))
--- /dev/null
+++ b/lib/zuo/private/base-common/and-or.zuo
@@ -1,0 +1,82 @@
+#lang zuo/datum
+
+(require "../pair.zuo"
+ "syntax-error.zuo")
+
+(provide or
+ and
+ cond else
+ when
+ unless)
+
+(define-syntax or
+ (lambda (stx)
+ (if (list? stx)
+ (if (null? (cdr stx))
+ #f
+ (if (null? (cddr stx))
+ (cadr stx)
+ (list (quote-syntax let) (list (list 'tmp (cadr stx)))
+ (list (quote-syntax if) 'tmp
+ 'tmp
+ (cons (quote-syntax or) (cddr stx))))))
+ (bad-syntax stx))))
+
+(define-syntax and
+ (lambda (stx)
+ (if (list? stx)
+ (if (null? (cdr stx))
+ #t
+ (if (null? (cddr stx))
+ (cadr stx)
+ (list (quote-syntax if) (cadr stx)
+ (cons (quote-syntax and) (cddr stx))
+ #f)))
+ (bad-syntax stx))))
+
+(define-syntax else misplaced-syntax)
+
+(define-syntax cond
+ (context-consumer
+ (lambda (stx free-id=? name)
+ (if (and (list? stx)
+ (letrec ([ok-clauses?
+ (lambda (l)
+ (or (null? l)
+ (let ([cl (car l)])
+ (and (list? cl)
+ (>= (length cl) 2)
+ (ok-clauses? (cdr l))))))])
+ (ok-clauses? (cdr stx))))
+ (if (null? (cdr stx))
+ (list (quote-syntax void))
+ (let ([cl1 (cadr stx)]
+ [cls (cddr stx)])
+ (list 'if (if (and (null? cls)
+ (identifier? (car cl1))
+ (free-id=? 'else (car cl1)))
+ #t
+ (car cl1))
+ (cons (quote-syntax let) (cons '() (cdr cl1)))
+ (if (null? cls)
+ '(void)
+ (cons (quote-syntax cond) cls)))))
+ (bad-syntax stx)))))
+
+(define-syntax when
+ (lambda (stx)
+ (if (and (list? stx)
+ (>= (length stx) 3))
+ (list 'if (cadr stx)
+ (cons (quote-syntax let) (cons '() (cddr stx)))
+ '(void))
+ (bad-syntax stx))))
+
+(define-syntax unless
+ (lambda (stx)
+ (if (and (list? stx)
+ (>= (length stx) 3))
+ (list 'if (cadr stx)
+ '(void)
+ (cons (quote-syntax let) (cons '() (cddr stx))))
+ (bad-syntax stx))))
--- /dev/null
+++ b/lib/zuo/private/base-common/bind-struct.zuo
@@ -1,0 +1,91 @@
+#lang zuo/datum
+
+;; simple transparent structs
+(define (make-maker tag) (lambda (v) (cons tag v)))
+(define (make-? tag) (lambda (v) (and (pair? v) (eq? tag (car v)))))
+(define (make-?? tag1 tag2) (lambda (v) (and (pair? v) (or (eq? tag1 (car v))
+ (eq? tag2 (car v))))))
+(define any-ref cdr) ; not bothering to check a tag
+
+;; A binding that's a core form recognized by the expander
+(define make-core-form (make-maker 'core-form))
+(define core-form? (make-? 'core-form))
+(define form-id any-ref)
+
+;; A binding for a local variable
+(define make-local (make-maker 'local))
+(define local? (make-? 'local))
+(define local-id any-ref)
+
+;; A binding for a definition
+(define make-defined (make-maker 'defined))
+(define defined? (make-? 'defined))
+
+;; A `letrec` bindind or an imported definition
+(define make-local-variable (make-maker 'local-variable))
+
+;; A `variable` is a definition or `letrec`
+(define variable? (make-?? 'local-variable 'defined))
+(define variable-var any-ref)
+
+;; A macro is specifically an imported macro:
+(define make-macro (make-maker macro-protocol))
+(define macro-implementation any-ref)
+
+;; A macro defined in the current moddule:
+(define make-defined-macro (make-maker 'defined-macro))
+(define defined-macro? (make-? 'defined-macro))
+(define defined-macro-proc any-ref)
+
+;; Imported or current-module macro
+(define macro? (make-?? macro-protocol 'defined-macro))
+
+;; A `literal` wrapper is needed for a pair as a value; any
+;; other kind of value is distinct from our "record"s
+(define make-literal (make-maker 'literal))
+(define literal? (make-? 'literal))
+(define literal-val any-ref)
+
+;; Wraps a binding to indicate that's from the initial import,
+;; so it's shadowable by `require`
+(define make-initial-import (make-maker 'initial))
+(define initial-import? (make-? 'initial))
+(define initial-import-bind any-ref)
+
+;; Wraps a binding to give it an identity that persists across
+;; imports
+(define make-specific (make-maker 'specific))
+(define specific? (make-? 'specific))
+(define (specific-label s) (cdr (any-ref s)))
+
+(define (unwrap-specific v)
+ (if (specific? v)
+ (car (any-ref v))
+ v))
+
+(define (as-specific v)
+ (make-specific (cons v (string->uninterned-symbol "u"))))
+
+(define (specific=? a b)
+ (if (specific? a)
+ (if (specific? b)
+ (eq? (specific-label a) (specific-label b))
+ #f)
+ (eq? a b)))
+
+;; bubbles `specific` outside `initial-import`
+(define (initial-import bind)
+ (let* ([label (and (specific? bind)
+ (specific-label bind))]
+ [bind (unwrap-specific bind)]
+ [bind (make-initial-import bind)])
+ (if label
+ (make-specific (cons bind label))
+ bind)))
+
+(define context-consumer-key (string->uninterned-symbol "ctxer"))
+(define (context-consumer proc)
+ (unless (procedure? proc) (error "context-consumer: not a procedure" proc))
+ (opaque context-consumer-key proc))
+(define (context-consumer? v) (and (opaque-ref context-consumer-key v #f) #t))
+(define (context-consumer-procedure v) (opaque-ref context-consumer-key v #f))
--- /dev/null
+++ b/lib/zuo/private/base-common/bind.zuo
@@ -1,0 +1,67 @@
+#lang zuo/datum
+
+;; Creation of the initial bindings and managing imports/exports
+
+;; A binding can be any non-pair value or one of the record
+;; types described in "struct.zuo"
+
+(define (make-core-initial-bind bind)
+ (as-specific (make-initial-import bind)))
+
+;; Start with kernel-supplied primitives
+(define kernel-provides
+ (let* ([ht (kernel-env)])
+ (foldl (lambda (sym provides)
+ (hash-set provides sym (make-core-initial-bind (hash-ref ht sym #f))))
+ (hash)
+ (hash-keys ht))))
+
+;; Add expander-defined syntactic forms
+(define top-form-provides
+ (foldl (lambda (sym provides)
+ (hash-set provides sym (make-core-initial-bind (make-core-form sym))))
+ kernel-provides
+ '(lambda let letrec quote if begin
+ define define-syntax require provide module+
+ quote-syntax quote-module-path
+ include)))
+
+;; Add some functions/constants defined in the expander
+(define top-provides
+ (let* ([provides top-form-provides]
+ [add (lambda (provides name val) (hash-set provides name (make-core-initial-bind val)))]
+ [provides (add provides 'identifier? identifier?)]
+ [provides (add provides 'syntax-e checked-syntax-e)]
+ [provides (add provides 'syntax->datum checked-syntax->datum)]
+ [provides (add provides 'datum->syntax checked-datum->syntax)]
+ [provides (add provides 'bound-identifier=? bound-identifier=?)]
+ [provides (add provides 'context-consumer context-consumer)]
+ [provides (add provides 'context-consumer? context-consumer?)]
+ [provides (add provides 'dynamic-require dynamic-require)])
+ provides))
+
+;; Used to convert a local binding into one that goes in a provides
+;; table, so suitable to import into another module
+(define (export-bind bind ctx binds)
+ (let* ([label (and (specific? bind)
+ (specific-label bind))]
+ [bind (unwrap-specific bind)]
+ [bind (if (initial-import? bind)
+ (initial-import-bind bind)
+ bind)]
+ [bind (cond
+ [(defined? bind)
+ (make-local-variable (variable-var bind))]
+ [(defined-macro? bind)
+ (make-exported-macro (defined-macro-proc bind) ctx)]
+ [else bind])])
+ (if label
+ (make-specific (cons bind label))
+ bind)))
+
+;; in case `all-from-out` is used on the initial import,
+;; adds all the current ids in `binds` as nominally imported
+(define (initial-nominals mod-path provides)
+ (list (cons mod-path
+ (map (lambda (sym) (cons sym (hash-ref provides sym #f)))
+ (hash-keys provides)))))
--- /dev/null
+++ b/lib/zuo/private/base-common/check-dups.zuo
@@ -1,0 +1,18 @@
+#lang zuo/datum
+
+(require "and-or.zuo"
+ "syntax-error.zuo"
+ "../list.zuo")
+
+(provide check-duplicates)
+
+(define check-duplicates
+ (lambda (args)
+ (foldl (lambda (id seen)
+ (when (ormap (lambda (seen-id)
+ (bound-identifier=? id seen-id))
+ seen)
+ (duplicate-identifier id))
+ (cons id seen))
+ '()
+ args)))
--- /dev/null
+++ b/lib/zuo/private/base-common/define-help.zuo
@@ -1,0 +1,53 @@
+#lang zuo/datum
+
+(require "../pair.zuo"
+ "and-or.zuo"
+ "syntax-error.zuo"
+ "../list.zuo"
+ "let.zuo"
+ "check-dups.zuo")
+
+(provide check-args
+ make-define)
+
+(define check-args
+ (lambda (stx args)
+ (let ([arg-names
+ (let loop ([args args] [must-opt? #f])
+ (cond
+ [(identifier? args) ; rest arg
+ (list args)]
+ [(pair? args)
+ (cond
+ [(and (identifier? (car args))
+ (not must-opt?))
+ (cons (car args) (loop (cdr args) #f))]
+ [(and (list? (car args))
+ (= 2 (length (car args)))
+ (identifier? (caar args)))
+ (cons (caar args) (loop (cdr args) #t))]
+ [else
+ (syntax-error (~a (syntax-e (car stx)) ": bad syntax at argument")
+ (car args))])]
+ [(null? args) '()]
+ [else (bad-syntax stx)]))])
+ (check-duplicates arg-names)
+ arg-names)))
+
+(define make-define
+ (lambda (orig-define opt-lambda)
+ (lambda (stx)
+ (unless (and (list? stx) (>= (length stx) 3)) (bad-syntax stx))
+ (let ([head (cadr stx)])
+ (cond
+ [(identifier? head)
+ ;; regular define
+ (cons orig-define (cdr stx))]
+ [(and (pair? head)
+ (identifier? (car head)))
+ ;; procedure shorthand
+ (let* ([name (car head)]
+ [args (cdr head)])
+ (check-args stx args)
+ (list orig-define name (list* opt-lambda args (cddr stx))))]
+ [else (bad-syntax stx)])))))
--- /dev/null
+++ b/lib/zuo/private/base-common/define.zuo
@@ -1,0 +1,13 @@
+#lang zuo/datum
+
+(require "define-help.zuo"
+ "opt-lambda.zuo")
+
+(provide (rename-out [define-var-or-proc define]
+ [define-syntax-var-or-proc define-syntax]))
+
+(define-syntax define-var-or-proc
+ (make-define (quote-syntax define) (quote-syntax lambda)))
+
+(define-syntax define-syntax-var-or-proc
+ (make-define (quote-syntax define-syntax) (quote-syntax lambda)))
--- /dev/null
+++ b/lib/zuo/private/base-common/dynamic.zuo
@@ -1,0 +1,16 @@
+#lang zuo/datum
+
+(define (dynamic-require mod-path sym)
+ (unless (module-path? mod-path) (arg-error 'dynamic-require "module-path" mod-path))
+ (unless (symbol? sym) (arg-error 'dynamic-require "symbol" sym))
+ (let* ([ht (module->hash mod-path)]
+ [provides (hash-ref ht 'macromod-provides #f)])
+ (unless provides
+ (error "dynamic-require: not a compatible module" mod-path))
+ (let* ([bind (hash-ref provides sym #f)])
+ (unless bind (error "dynamic-require: no such provide" sym))
+ (let ([bind (unwrap-specific bind)])
+ (cond
+ [(variable? bind) (variable-ref (variable-var bind))]
+ [(literal? bind) (literal-val bind)]
+ [else bind])))))
--- /dev/null
+++ b/lib/zuo/private/base-common/entry.zuo
@@ -1,0 +1,45 @@
+#lang zuo/datum
+
+;; The `read-and-eval` entry point for a language using the expander
+
+(define (make-read-and-eval make-initial-state)
+ (lambda (str start mod-path)
+ (let* ([es (string-read str start mod-path)]
+ [ctx (make-module-context mod-path)]
+ [es (map (lambda (e) (datum->syntax ctx e)) es)]
+ [parse (make-parse ctx mod-path)]
+ [initial-state (make-initial-state ctx)]
+ [es+state+modtop (expand-sequence es initial-state empty-modtop mod-path ctx parse)]
+ [es (car es+state+modtop)]
+ [state (cadr es+state+modtop)]
+ [modtop (cadr (cdr es+state+modtop))]
+ [outs (resolve-provides (modtop-provides modtop) state ctx mod-path)]
+ [body (map (lambda (e) (add-print (parse e #f state))) es)]
+ [submods (parse-submodules (modtop-modules modtop) state mod-path ctx parse)])
+ (kernel-eval (cons 'begin (cons '(void) body)))
+ (hash 'macromod-provides outs
+ 'submodules submods
+ merge-bindings-export-key (make-export-merge-binds ctx (state-binds state))))))
+
+(hash
+ ;; makes `#lang zuo/private/base[-hygienic] work:
+ 'read-and-eval (make-read-and-eval (lambda (ctx)
+ (make-state (binds-create top-provides ctx)
+ (initial-nominals language-mod-path top-provides))))
+ ;; makes `(require zuo/private/base[hygienic])` work:
+ 'macromod-provides top-provides
+ ;; for making a new `#lang` with initial imports from `mod-path`:
+ 'make-language
+ (lambda (mod-path)
+ (let* ([mod (module->hash mod-path)]
+ [provides (hash-ref mod 'macromod-provides #f)]
+ [m-binds (hash-ref mod merge-bindings-export-key #f)])
+ (unless provides
+ (syntax-error "not a compatible module for initial imports" mod-path))
+ (hash 'read-and-eval
+ (make-read-and-eval
+ (lambda (ctx)
+ (merge-binds (make-state (binds-create provides ctx)
+ (initial-nominals mod-path provides))
+ m-binds)))
+ 'macromod-provides (hash-ref (module->hash mod-path) 'macromod-provides #f)))))
--- /dev/null
+++ b/lib/zuo/private/base-common/free-id-eq.zuo
@@ -1,0 +1,16 @@
+#lang zuo/datum
+
+(define free-id=?
+ (lambda (binds id1 id2)
+ (let* ([bind1 (resolve* binds id1 #f)]
+ [bind2 (resolve* binds id2 #f)])
+ (or (specific=? bind1 bind2)
+ (and (not bind1)
+ (not bind2)
+ (eq? (syntax-e id1) (syntax-e id2)))))))
+
+(define (apply-macro* proc s name free-id=?)
+ (let ([c-proc (context-consumer-procedure proc)])
+ (if c-proc
+ (c-proc s free-id=? (and name (symbol->string (syntax-e name))))
+ (proc s))))
--- /dev/null
+++ b/lib/zuo/private/base-common/let.zuo
@@ -1,0 +1,60 @@
+#lang zuo/datum
+
+(require "../pair.zuo"
+ "and-or.zuo"
+ "syntax-error.zuo"
+ "../list.zuo"
+ "check-dups.zuo")
+
+(provide (rename-out [let-or-named-let let])
+ let*)
+
+(define-syntax let-or-named-let
+ (lambda (stx)
+ (cond
+ [(not (pair? stx)) (bad-syntax stx)]
+ [(and (pair? (cdr stx))
+ (identifier? (cadr stx)))
+ ;; named `let`
+ (unless (and (list? stx)
+ (>= (length stx) 4))
+ (bad-syntax stx))
+ (let ([name (cadr stx)]
+ [bindings (cadr (cdr stx))])
+ (for-each (lambda (binding)
+ (unless (and (list? binding)
+ (= 2 (length binding))
+ (identifier? (car binding)))
+ (syntax-error "named let: bad syntax at binding" binding)))
+ bindings)
+ (let ([args (map car bindings)]
+ [inits (map cadr bindings)])
+ (check-duplicates args)
+ (cons (list (quote-syntax letrec)
+ (list (list name
+ (list* (quote-syntax lambda)
+ args
+ (cddr (cdr stx)))))
+ name)
+ inits)))]
+ [else (cons (quote-syntax let) (cdr stx))])))
+
+(define-syntax let*
+ (lambda (stx)
+ (unless (and (list? stx) (>= (length stx) 3))
+ (bad-syntax stx))
+ (let ([bindings (cadr stx)])
+ (unless (list? bindings) (bad-syntax stx))
+ (for-each (lambda (binding)
+ (unless (and (list? binding)
+ (= 2 (length binding))
+ (identifier? (car binding)))
+ (syntax-error "let*: bad syntax at binding" binding)))
+ bindings)
+ (letrec ([nest-bindings
+ (lambda (bindings)
+ (if (null? bindings)
+ (cons (quote-syntax begin) (cddr stx))
+ (list (quote-syntax let) (list (car bindings))
+ (nest-bindings (cdr bindings)))))])
+ (nest-bindings bindings)))))
--- /dev/null
+++ b/lib/zuo/private/base-common/lib.zuo
@@ -1,0 +1,43 @@
+#lang zuo/datum
+
+(define (caar p) (car (car p)))
+(define (cadr p) (car (cdr p)))
+(define (cdar p) (cdr (car p)))
+(define (cddr p) (cdr (cdr p)))
+
+(define map
+ (letrec ([map (lambda (f vs)
+ (if (null? vs)
+ '()
+ (cons (f (car vs)) (map f (cdr vs)))))])
+ map))
+
+(define map2
+ (letrec ([map2 (lambda (f vs v2s)
+ (if (null? vs)
+ '()
+ (cons (f (car vs) (car v2s))
+ (map2 f (cdr vs) (cdr v2s)))))])
+ map2))
+
+(define (foldl f init vs)
+ (letrec ([fold (lambda (vs accum)
+ (if (null? vs)
+ accum
+ (fold (cdr vs) (f (car vs) accum))))])
+ (fold vs init)))
+
+(define (ormap f vs)
+ (letrec ([ormap (lambda (vs)
+ (if (null? vs)
+ #f
+ (or (f (car vs)) (ormap (cdr vs)))))])
+ (ormap vs)))
+
+(define (mod-path=? a b)
+ (if (or (symbol? a) (symbol? b))
+ (eq? a b)
+ (string=? a b)))
+
+(define (gensym sym)
+ (string->uninterned-symbol (symbol->string sym)))
--- /dev/null
+++ b/lib/zuo/private/base-common/main.zuo
@@ -1,0 +1,25 @@
+#lang zuo/datum
+
+(require "and-or.zuo"
+ "syntax-error.zuo"
+ "../pair.zuo"
+ "../list.zuo"
+ "let.zuo"
+ "define.zuo"
+ "opt-lambda.zuo"
+ "quasiquote.zuo"
+ "more-syntax.zuo"
+ "../more.zuo"
+ "struct.zuo")
+
+(provide (all-from-out "and-or.zuo"
+ "syntax-error.zuo"
+ "../pair.zuo"
+ "../list.zuo"
+ "let.zuo"
+ "define.zuo"
+ "opt-lambda.zuo"
+ "quasiquote.zuo"
+ "more-syntax.zuo"
+ "../more.zuo"
+ "struct.zuo"))
--- /dev/null
+++ b/lib/zuo/private/base-common/more-syntax.zuo
@@ -1,0 +1,44 @@
+#lang zuo/datum
+
+(require "and-or.zuo"
+ "../pair.zuo"
+ "../list.zuo"
+ "define.zuo"
+ "syntax-error.zuo")
+
+(provide char
+ at-source)
+
+(define-syntax (char stx)
+ (if (and (list? stx)
+ (= 2 (length stx))
+ (string? (cadr stx))
+ (= 1 (string-length (cadr stx))))
+ (string-ref (cadr stx) 0)
+ (bad-syntax stx)))
+
+(define (combine-path base)
+ (lambda paths
+ (cond
+ [(pair? paths)
+ (unless (path-string? (car paths))
+ (arg-error 'at-source "path string" (car paths)))
+ (for-each (lambda (path)
+ (unless (and (path-string? path)
+ (relative-path? path))
+ (arg-error 'at-source "relative path string" path)))
+ (cdr paths))
+ (if (relative-path? (car paths))
+ (apply build-path (cons (or (car (split-path base)) ".") paths))
+ (apply build-path paths))]
+ [else
+ (or (car (split-path base)) ".")])))
+
+(define-syntax (at-source stx)
+ (if (list? stx)
+ (cons (quote-syntax (combine-path (quote-module-path)))
+ (cdr stx))
+ (if (identifier? stx)
+ (quote-syntax (combine-path (quote-module-path)))
+ (bad-syntax stx))))
+
--- /dev/null
+++ b/lib/zuo/private/base-common/opt-lambda.zuo
@@ -1,0 +1,67 @@
+#lang zuo/datum
+
+(require "../pair.zuo"
+ "and-or.zuo"
+ "syntax-error.zuo"
+ "define-help.zuo"
+ "let.zuo")
+
+(provide (rename-out [opt-lambda lambda]))
+
+(define-syntax opt-lambda
+ (context-consumer
+ (lambda (stx free=? name)
+ (unless (and (list? stx) (>= (length stx) 3)) (bad-syntax stx))
+ (let* ([args (cadr stx)]
+ [plain? (let loop ([args args])
+ (cond
+ [(null? args) #t]
+ [(identifier? args) #t]
+ [else (and (pair? args)
+ (identifier? (car args))
+ (loop (cdr args)))]))])
+ (cond
+ [plain?
+ (cons (quote-syntax lambda) (cdr stx))]
+ [else
+ (let ([all-args (check-args stx args)])
+ (let loop ([args args] [rev-plain-args '()])
+ (cond
+ [(identifier? (car args))
+ (loop (cdr args) (cons (car args) rev-plain-args))]
+ [else
+ (let* ([args-id (string->uninterned-symbol "args")])
+ (list (quote-syntax lambda)
+ (append (reverse rev-plain-args) args-id)
+ (let loop ([args args])
+ (cond
+ [(null? args)
+ (list (quote-syntax if) (list (quote-syntax null?) args-id)
+ (cons (quote-syntax let) (cons (list) (cddr stx)))
+ (list (quote-syntax opt-arity-error)
+ (list (quote-syntax quote) name)
+ (cons (quote-syntax list)
+ all-args)
+ args-id))]
+ [(identifier? args)
+ (cons (quote-syntax let)
+ (cons (list (list args args-id))
+ (cddr stx)))]
+ [else
+ (list (quote-syntax let)
+ (list (list (caar args)
+ (list (quote-syntax if)
+ (list (quote-syntax null?) args-id)
+ (car (cdar args))
+ (list (quote-syntax car) args-id))))
+ (list (quote-syntax let)
+ (list (list args-id
+ (list (quote-syntax if)
+ (list (quote-syntax null?) args-id)
+ (quote-syntax '())
+ (list (quote-syntax cdr) args-id))))
+ (loop (cdr args))))]))))])))])))))
+
+(define opt-arity-error
+ (lambda (name base-args extra-args)
+ (arity-error name (append base-args extra-args))))
--- /dev/null
+++ b/lib/zuo/private/base-common/parse-lib.zuo
@@ -1,0 +1,65 @@
+#lang zuo/datum
+
+;; Helpers for "parse.zuo" that depends on the implementation of
+;; syntax objects
+
+(define (name-lambda name form)
+ (if name
+ ;; `zuo/kernel` recognizes this pattern to name the form
+ (cons 'lambda (cons (cadr form) (cons (symbol->string (syntax-e name)) (cddr form))))
+ form))
+
+(define (syntax-error msg s)
+ (error (~a msg ": " (~s (syntax->datum s)))))
+
+(define (bad-syntax s)
+ (syntax-error "bad syntax" s))
+
+(define (duplicate-identifier id s)
+ (error "duplicate identifier:" (syntax-e id) (syntax->datum s)))
+
+(define (id-sym-eq? id sym)
+ (and (identifier? id)
+ (eq? (syntax-e id) sym)))
+
+(define (unwrap-mod-path mod-path)
+ (if (identifier? mod-path)
+ (syntax-e mod-path)
+ mod-path))
+
+(define (add-binding state id binding)
+ (state-set-binds state (add-binding* (state-binds state) id binding)))
+
+(define (resolve state id same-defn-ctx?)
+ (let* ([bind (resolve* (state-binds state) id same-defn-ctx?)]
+ [bind (unwrap-specific bind)])
+ (if (initial-import? bind)
+ (initial-import-bind bind)
+ bind)))
+
+(define (merge-binds state m-binds)
+ (if m-binds
+ (state-set-binds state (merge-binds* (state-binds state) m-binds))
+ state))
+
+(define (new-defn-context state)
+ (state-set-binds state (new-defn-context* (state-binds state))))
+
+(define (nest-bindings new-cls body)
+ (letrec ([nest-bindings (lambda (new-cls)
+ (if (null? new-cls)
+ body
+ (list 'let (list (car new-cls))
+ (nest-bindings (cdr new-cls)))))])
+ (nest-bindings (reverse new-cls))))
+
+;; Use to communicate a `variable-set!` form from `define` to `parse`:
+(define set-var-tag (string->uninterned-symbol "setvar"))
+
+(define (print-result v)
+ (unless (eq? v (void))
+ (alert (~v v))))
+
+(define (add-print s)
+ (list print-result s))
+(define (no-wrap s) s)
--- /dev/null
+++ b/lib/zuo/private/base-common/parse.zuo
@@ -1,0 +1,489 @@
+#lang zuo/datum
+
+;; This is the main parser/expander, to be included in a context that
+;; plugs in the implementation of syntax objects and macros (so,
+;; hygienic or not)
+
+;; The `expand-...` functions handle the top-level sequence, while
+;; `parse-...` is for expressions
+
+(include "parse-lib.zuo")
+
+(define (expand-define s state k)
+ (unless (and (list? s) (= 3 (length s)) (identifier? (cadr s)))
+ (bad-syntax s))
+ (let* ([id (cadr s)]
+ [id-bind (resolve state id #t)])
+ (when (or (defined? id-bind)
+ (defined-macro? id-bind))
+ (syntax-error "duplicate definition" id))
+ (let* ([sym (syntax-e id)]
+ [def-id (gensym sym)]
+ [id+rhs (list id (cadr (cdr s)))]
+ [vars (state-variables state)])
+ (cond
+ [(not vars) ; => at module top
+ ;; generate inlined variable
+ (let* ([var (variable sym)]
+ [state (add-binding state id (as-specific (make-defined var)))]
+ ;; construct an expression with the var inlined:
+ [new-s (cons set-var-tag (cons var id+rhs))])
+ (k new-s state))]
+ [else
+ ;; generate local-variable creation
+ (let* ([state (add-binding state id (make-defined def-id))]
+ [state (state-set-variables state
+ (cons (list def-id (list variable (list 'quote sym)))
+ vars))]
+ ;; construct an expression to set the var:
+ [new-s (cons set-var-tag (cons def-id id+rhs))])
+ (k new-s state))]))))
+
+(define (expand-define-syntax s state parse)
+ (unless (and (list? s) (= 3 (length s)) (identifier? (cadr s)))
+ (bad-syntax s))
+ (let* ([id (cadr s)]
+ [id-bind (resolve state id #t)])
+ (when (or (defined? id-bind)
+ (defined-macro? id-bind))
+ (syntax-error "duplicate definition" id))
+ (let* ([e (parse (cadr (cdr s)) id state)]
+ [proc (kernel-eval e)])
+ (unless (or (procedure? proc) (context-consumer? proc))
+ (error "define-syntax: not a procedure or context consumer" proc))
+ (add-binding state id (as-specific (make-defined-macro proc))))))
+
+(define (expand-require s state mod-path)
+ (let* ([check-renames
+ ;; syntax check on renaming clauses `ns`
+ (lambda (r ns id-ok?)
+ (map (lambda (n) (unless (or (and id-ok?
+ (identifier? n))
+ (and (list? n)
+ (= 2 (length n))
+ (identifier? (car n))
+ (identifier? (cadr n))))
+ (bad-syntax r)))
+ ns))]
+ [make-rename-filter
+ ;; used to apply `ns` renaming clauses to an imported identifier
+ (lambda (ns only?)
+ (lambda (sym)
+ (letrec ([loop (lambda (ns)
+ (cond
+ [(null? ns) (if only? #f sym)]
+ [(id-sym-eq? (car ns) sym) sym]
+ [(and (pair? (car ns))
+ (id-sym-eq? (caar ns) sym))
+ (syntax-e (cadr (car ns)))]
+ [else (loop (cdr ns))]))])
+ (loop ns))))]
+ [make-provides-checker
+ ;; used to check whether set of provided is consistent with `ns`
+ (lambda (ns)
+ (lambda (provides)
+ (map (lambda (n)
+ (let ([id (if (pair? n) (car n) n)])
+ (unless (hash-ref provides (syntax-e id) #f)
+ (syntax-error "identifier is not in required set" id))))
+ ns)))])
+ ;; parse each `require` clause `r:
+ (foldl (lambda (r state)
+ (let* ([req-ctx (car s)]
+ [req-path+filter+check
+ (cond
+ [(string? r) (list r (lambda (sym) sym) void)]
+ [(identifier? r) (list (syntax-e r) (lambda (sym) sym) void)]
+ [(pair? r)
+ (unless (and (list? r) (pair? (cdr r))) (bad-syntax r))
+ (let* ([ns (cddr r)])
+ (cond
+ [(id-sym-eq? (car r) 'only-in)
+ (check-renames r ns #t)
+ (list (cadr r) (make-rename-filter ns #t) (make-provides-checker ns))]
+ [(id-sym-eq? (car r) 'rename-in)
+ (check-renames r ns #f)
+ (list (cadr r) (make-rename-filter ns #f) (make-provides-checker ns))]
+ [else (bad-syntax r)]))]
+ [else (bad-syntax r)])]
+ [req-path (car req-path+filter+check)]
+ [filter (cadr req-path+filter+check)]
+ [check (cadr (cdr req-path+filter+check))]
+ [in-mod-path (build-module-path mod-path req-path)]
+ [mod (module->hash in-mod-path)]
+ [provides (hash-ref mod 'macromod-provides #f)]
+ [m-binds (hash-ref mod merge-bindings-export-key #f)]
+ [state (merge-binds state m-binds)]
+ [state (init-nominal state (unwrap-mod-path req-path))])
+ (unless provides (syntax-error "not a compatible module" r))
+ (check provides)
+ ;; add each provided binding (except as filtered)
+ (foldl (lambda (sym state)
+ (let* ([as-sym (filter sym)])
+ (cond
+ [(not as-sym) state]
+ [else
+ ;; check whether it's bound already
+ (let* ([as-id (datum->syntax req-ctx as-sym)]
+ [current-bind (resolve* (state-binds state) as-id #f)]
+ [req-bind (hash-ref provides sym #f)]
+ [add-binding/record-nominal
+ (lambda ()
+ (let* ([state (add-binding state as-id req-bind)])
+ (record-nominal state (unwrap-mod-path req-path) as-sym req-bind)))])
+ (cond
+ [(not current-bind)
+ ;; not already bound, so import is ok
+ (add-binding/record-nominal)]
+ [(initial-import? (unwrap-specific current-bind))
+ ;; `require` can shadow an initial import
+ (add-binding/record-nominal)]
+ [(specific=? current-bind req-bind)
+ ;; re-import of same variable or primitive, also ok
+ state]
+ [(or (defined? current-bind)
+ (defined-macro? current-bind))
+ ;; definition shadows import
+ state]
+ [else
+ (syntax-error "identifier is already imported" as-id)]))])))
+ state
+ (hash-keys provides))))
+ state
+ (cdr s))))
+
+(define (expand-include s mod-path)
+ (unless (and (list? s) (= 2 (length s)))
+ (bad-syntax s))
+ (let* ([include-ctx (car s)]
+ [in-mod-path (unwrap-mod-path (cadr s))]
+ [in-mod-path (build-module-path mod-path in-mod-path)]
+ [mod (module->hash in-mod-path)]
+ [datums (hash-ref mod 'datums #f)])
+ (unless datums (error "not an includable module" in-mod-path))
+ (map (lambda (e) (datum->syntax include-ctx e)) datums)))
+
+;; expand top-level forms and gather imports and definitions
+(define (expand-sequence es state modtop mod-path ctx parse)
+ (letrec ([expand-seq
+ (lambda (es accum state modtop)
+ (cond
+ [(null? es) (list (reverse accum) state modtop)]
+ [else
+ (let* ([s (car es)])
+ (cond
+ [(pair? s)
+ (let* ([rator (car s)]
+ [bind (and (identifier? rator)
+ (resolve state rator #f))])
+ (cond
+ [(macro? bind)
+ (apply-macro bind s ctx (state-binds state) #f
+ (lambda (new-s new-binds)
+ (let ([new-state (state-set-binds state new-binds)])
+ (expand-seq (cons new-s (cdr es)) accum new-state modtop))))]
+ [(core-form? bind)
+ (let ([bind (form-id bind)])
+ (cond
+ [(eq? bind 'begin)
+ (unless (list? s) (bad-syntax s))
+ (expand-seq (append (cdr s) (cdr es)) accum state modtop)]
+ [(eq? bind 'define)
+ (expand-define s
+ state
+ (lambda (new-s new-state)
+ (expand-seq (cdr es) (cons new-s accum) new-state modtop)))]
+ [(eq? bind 'define-syntax)
+ (let ([new-state (expand-define-syntax s state parse)])
+ (expand-seq (cdr es) accum new-state modtop))]
+ [(eq? bind 'provide)
+ (if modtop
+ ;; save provides to handle at the end:
+ (let ([new-modtop (modtop-set-provides modtop (cons s (modtop-provides modtop)))])
+ (expand-seq (cdr es) accum state new-modtop))
+ (syntax-error "nested provides not allowed" s))]
+ [(eq? bind 'module+)
+ (if modtop
+ ;; save submodules to handle at the end:
+ (let ([new-modtop (modtop-set-modules modtop (cons s (modtop-modules modtop)))])
+ (expand-seq (cdr es) accum state new-modtop))
+ (syntax-error "nested submodules not allowed" s))]
+ [(eq? bind 'require)
+ (let ([new-state (expand-require s state mod-path)])
+ (expand-seq (cdr es) accum new-state modtop))]
+ [(eq? bind 'include)
+ (let ([new-es (append (expand-include s mod-path) (cdr es))])
+ (expand-seq new-es accum state modtop))]
+ [else
+ (expand-seq (cdr es) (cons s accum) state modtop)]))]
+ [else (expand-seq (cdr es) (cons s accum) state modtop)]))]
+ [else (expand-seq (cdr es) (cons s accum) state modtop)]))]))])
+ (expand-seq es '() state modtop)))
+
+;; parse a provide form after the module body has been expanded
+(define (resolve-provide s state ctx mod-path outs)
+ (unless (list? s) (bad-syntax s))
+ (foldl (lambda (p outs)
+ (let* ([add-provide (lambda (outs id as-sym)
+ (let* ([binds (resolve* (state-binds state) id #f)]
+ [bind binds]
+ [old-bind (hash-ref outs as-sym #f)])
+ (unless bind
+ (syntax-error "provided identifier not bound" id))
+ (when (and old-bind
+ (not (specific=? bind old-bind)))
+ (syntax-error "already provided as different binding" as-sym))
+ (hash-set outs as-sym (export-bind bind ctx binds))))]
+ [bad-provide-form (lambda () (syntax-error "bad provide clause" p))])
+ (cond
+ [(identifier? p) (add-provide outs p (syntax-e p))]
+ [(pair? p)
+ (unless (list? p) (bad-provide-form))
+ (let ([form (car p)])
+ (cond
+ [(id-sym-eq? form 'rename-out)
+ (foldl (lambda (rn outs)
+ (unless (and (list? rn) (= 2 (length rn))
+ (identifier? (car rn)) (identifier? (cadr rn)))
+ (bad-provide-form))
+ (add-provide outs (car rn) (syntax-e (cadr rn))))
+ outs
+ (cdr p))]
+ [(id-sym-eq? form 'all-from-out)
+ (foldl (lambda (req-path outs)
+ (let* ([prov-ctx (car s)]
+ [sym+binds (lookup-nominal state (unwrap-mod-path req-path))])
+ (unless sym+binds (syntax-error "module not required" req-path))
+ (foldl (lambda (sym+bind outs)
+ (let* ([sym (car sym+bind)]
+ [id (datum->syntax prov-ctx sym)]
+ [bind (resolve* (state-binds state) id #f)])
+ (cond
+ [(not (specific=? bind (cdr sym+bind)))
+ ;; shadowed by definition or other import
+ outs]
+ [else
+ (add-provide outs id sym)])))
+ outs
+ sym+binds)))
+ outs
+ (cdr p))]
+ [else (bad-provide-form)]))]
+ [else (bad-provide-form)])))
+ outs
+ (cdr s)))
+
+(define (resolve-provides provides state ctx mod-path)
+ (foldl (lambda (s outs)
+ (resolve-provide s state ctx mod-path outs))
+ (hash)
+ (reverse provides)))
+
+(define (parse-body orig-s es name state mod-path ctx parse wrap-e)
+ ;; It could be natural and correct to create a new scope for this
+ ;; body's definition context. That turns out to be unnecessary, though,
+ ;; due to the way our binding table is accumulated in `state` instead of
+ ;; a global mutable table like Racket's; that functional accumulator, plus
+ ;; the fact that all body positions are just inside a binding, combine to act
+ ;; as a kind of "outside edge" scope.
+ (let* ([outside-vars (state-variables state)]
+ [state (state-set-variables state '())] ; inital empty vars for this body
+ [es+state+modtop (expand-sequence es state #f mod-path ctx parse)]
+ [es (car es+state+modtop)]
+ [state (cadr es+state+modtop)]
+ [vars (state-variables state)] ; get var binding clauses for this body
+ [state (state-set-variables state outside-vars)]
+ [body (cond
+ [(null? es) (syntax-error "empty body after expansion" orig-s)]
+ [(null? (cdr es)) (wrap-e (parse (car es) name state))]
+ [else (cons 'begin (map (lambda (s) (wrap-e (parse s #f state))) es))])])
+ (nest-bindings vars body)))
+
+(define (parse-lambda s name state mod-path ctx parse)
+ (unless (>= (length s) 3) (bad-syntax s))
+ (let* ([formals (cadr s)]
+ [new-formals (letrec ([reformal (lambda (f seen)
+ (cond
+ [(null? f) '()]
+ [(identifier? f)
+ (when (ormap (lambda (sn) (bound-identifier=? f sn)) seen)
+ (duplicate-identifier f s))
+ (gensym (syntax-e f))]
+ [(pair? f)
+ (let* ([a (car f)])
+ (unless (identifier? a) (bad-syntax s))
+ (cons (reformal a seen)
+ (reformal (cdr f) (cons a seen))))]
+ [else (bad-syntax s)]))])
+ (reformal formals '()))]
+ [new-scope (make-scope "lambda")]
+ [state (new-defn-context state)]
+ [state (letrec ([add-formals (lambda (state formals new-formals)
+ (cond
+ [(identifier? formals)
+ (let* ([id (add-scope formals new-scope)])
+ (add-binding state id (make-local new-formals)))]
+ [(pair? new-formals)
+ (add-formals (add-formals state (cdr formals) (cdr new-formals))
+ (car formals)
+ (car new-formals))]
+ [else state]))])
+ (add-formals state formals new-formals))])
+ (name-lambda name
+ (list 'lambda
+ new-formals
+ (parse-body s (add-scope (cddr s) new-scope) #f state mod-path ctx parse no-wrap)))))
+
+(define (parse-let s name state mod-path ctx parse)
+ (unless (>= (length s) 3) (bad-syntax s))
+ (let* ([cls (cadr s)]
+ [orig-state state]
+ [new-scope (make-scope "let")]
+ [state (new-defn-context state)])
+ (unless (list? cls) (bad-syntax s))
+ (letrec ([parse-clauses
+ (lambda (cls new-cls state seen)
+ (cond
+ [(null? cls)
+ (nest-bindings (reverse new-cls)
+ (parse-body s (add-scope (cddr s) new-scope) name state mod-path ctx parse no-wrap))]
+ [else
+ (let* ([cl (car cls)])
+ (unless (and (list? cl) (= 2 (length cl))) (bad-syntax s))
+ (let* ([id (car cl)])
+ (unless (identifier? id) (bad-syntax s))
+ (when (ormap (lambda (sn) (bound-identifier=? id sn)) seen)
+ (duplicate-identifier id s))
+ (let* ([new-id (gensym (syntax-e id))])
+ (parse-clauses (cdr cls)
+ (cons (list new-id (parse (cadr cl) id orig-state))
+ new-cls)
+ (add-binding state (add-scope id new-scope) (make-local new-id))
+ (cons id seen)))))]))])
+ (parse-clauses cls '() state '()))))
+
+(define (parse-letrec s name state mod-path ctx parse)
+ (unless (>= (length s) 3) (bad-syntax s))
+ (let* ([cls (cadr s)]
+ [new-scope (make-scope "letrec")]
+ [state (new-defn-context state)])
+ (unless (list? cls) (bad-syntax s))
+ ;; use mutable variables to tie knots
+ (letrec ([bind-all (lambda (x-cls new-ids state seen)
+ (cond
+ [(null? x-cls)
+ (nest-bindings
+ (map (lambda (new-id)
+ (list new-id (list variable (list 'quote new-id))))
+ new-ids)
+ (cons 'begin
+ (append (map2 (lambda (cl new-id)
+ (list variable-set! (car new-ids)
+ (let ([rhs (cadr (car cls))])
+ (parse (add-scope rhs new-scope) (caar cls) state))))
+ cls
+ (reverse new-ids))
+ (list
+ (parse-body s (add-scope (cddr s) new-scope) name state mod-path ctx parse no-wrap)))))]
+ [else
+ (let* ([cl (car x-cls)])
+ (unless (and (list? cl) (= 2 (length cl))) (bad-syntax s))
+ (let* ([id (car cl)])
+ (unless (identifier? id) (bad-syntax s))
+ (when (ormap (lambda (sn) (bound-identifier=? id sn)) seen)
+ (duplicate-identifier id s))
+ (let ([new-id (gensym (syntax-e id))])
+ (bind-all (cdr x-cls)
+ (cons new-id new-ids)
+ (add-binding state (add-scope id new-scope) (make-local-variable new-id))
+ (cons id seen)))))]))])
+ (bind-all cls '() state '()))))
+
+(define (parse-submodules modules state mod-path ctx parse)
+ ;; each submodule become a thunk in the result table
+ (let ([combined (foldl (lambda (mod accum)
+ (unless (and (list? mod) (>= (length mod) 2) (identifier? (cadr mod)))
+ (bad-syntax mod))
+ (let ([name (syntax-e (cadr mod))]
+ [body (cddr mod)])
+ (hash-set accum name (append body (hash-ref accum name (list (void)))))))
+ (hash)
+ modules)])
+ (foldl (lambda (name mods)
+ (let* ([es (hash-ref combined name)]
+ [body (parse-body es es name state mod-path ctx parse add-print)])
+ (hash-set mods name
+ (kernel-eval (list 'lambda '() body)))))
+ (hash)
+ (hash-keys combined))))
+
+(define (make-parse ctx mod-path)
+ (letrec ([parse
+ (lambda (s name state)
+ (cond
+ [(pair? s)
+ (let* ([rator (car s)]
+ [bind (and (identifier? rator)
+ (resolve state rator #f))])
+ (cond
+ [(macro? bind)
+ (apply-macro bind s ctx (state-binds state) name
+ (lambda (new-s new-binds)
+ (parse new-s name (state-set-binds state new-binds))))]
+ [(core-form? bind)
+ (unless (list? s) (bad-syntax s))
+ (let ([bind (form-id bind)])
+ (cond
+ [(eq? bind 'lambda)
+ (parse-lambda s name state mod-path ctx parse)]
+ [(eq? bind 'let)
+ (parse-let s name state mod-path ctx parse)]
+ [(eq? bind 'letrec)
+ (parse-letrec s name state mod-path ctx parse)]
+ [(eq? bind 'quote)
+ (unless (= 2 (length s)) (bad-syntax s))
+ (list 'quote (syntax->datum (cadr s)))]
+ [(eq? bind 'quote-syntax)
+ (unless (= 2 (length s)) (bad-syntax s))
+ (syntax-quote (cadr s) ctx (state-binds state))]
+ [(eq? bind 'quote-module-path)
+ (unless (= 1 (length s)) (bad-syntax s))
+ (list 'quote mod-path)]
+ [(eq? bind 'if)
+ (unless (= 4 (length s)) (bad-syntax s))
+ (list 'if
+ (parse (cadr s) #f state)
+ (parse (cadr (cdr s)) name state)
+ (parse (cadr (cddr s)) name state))]
+ [(eq? bind 'begin)
+ (unless (pair? (cdr s)) (bad-syntax s))
+ (let ([es (map (lambda (e) (parse e #f state)) (cdr s))])
+ (if (null? (cdr es))
+ (car es)
+ (cons 'begin es)))]
+ [else
+ (map (lambda (e) (parse e #f state)) s)]))]
+ [(eq? rator set-var-tag) ; form created by `expand-define`
+ (let ([rhs (parse (cadr (cddr s)) (cadr (cdr s)) state)])
+ (list variable-set! (cadr s) rhs))]
+ [(and (eq? bind void) (null? (cdr s))) (void)] ; ad hoc optimization
+ [(and (eq? bind hash) (null? (cdr s))) (hash)] ; ad hoc optimization
+ [(list? s) (map (lambda (e) (parse e #f state)) s)]
+ [else (bad-syntax s)]))]
+ [(identifier? s)
+ (let* ([bind (resolve state s #f)])
+ (cond
+ [(core-form? bind) (bad-syntax s)]
+ [(local? bind) (local-id bind)]
+ [(variable? bind) (list variable-ref (variable-var bind))]
+ [(literal? bind) (literal-val bind)]
+ [(macro? bind)
+ (apply-macro bind s ctx state name
+ (lambda (new-s new-state)
+ (parse new-s name state)))]
+ [(not bind) (syntax-error "unbound identifier" s)]
+ [(pair? bind) (syntax-error "cannot expand foreign syntax" s)]
+ [else bind]))]
+ [(null? s) (bad-syntax s)]
+ [else s]))])
+ parse))
--- /dev/null
+++ b/lib/zuo/private/base-common/quasiquote.zuo
@@ -1,0 +1,63 @@
+#lang zuo/datum
+
+(require "../pair.zuo"
+ "and-or.zuo"
+ "syntax-error.zuo"
+ "../list.zuo"
+ "let.zuo")
+
+(provide quasiquote
+ unquote
+ unquote-splicing)
+
+(define-syntax quasiquote
+ (context-consumer
+ (lambda (stx free-id=? name)
+ (unless (and (list? stx) (= (length stx) 2))
+ (bad-syntax stx))
+ (let ([quot (quote-syntax quote)])
+ (let loop ([s (cadr stx)] [depth 0])
+ (let ([loop-pair (lambda (combine combine-name a d depth)
+ (let ([a (loop a depth)]
+ [d (loop d depth)])
+ (if (and (pair? a)
+ (eq? (car a) quot)
+ (pair? d)
+ (eq? (car d) quot))
+ (list quot (combine (cadr a) (cadr d)))
+ (list combine-name a d))))])
+ (cond
+ [(pair? s)
+ (let ([a (car s)])
+ (cond
+ [(and (identifier? a)
+ (free-id=? (syntax-e a) 'unquote))
+ (unless (= (length s) 2)
+ (bad-syntax s))
+ (if (= depth 0)
+ (cadr s)
+ (loop-pair list (quote-syntax list) a (cadr s) (- depth 1)))]
+ [(and (identifier? a)
+ (free-id=? (syntax-e a) 'unquote-splicing))
+ (syntax-error "misplaced splicing unquote" s)]
+ [(and (pair? a)
+ (identifier? (car a))
+ (free-id=? (syntax-e (car a)) 'unquote-splicing))
+ (unless (= (length a) 2)
+ (bad-syntax a))
+ (if (= depth 0)
+ (if (null? (cdr s))
+ (cadr a)
+ (list (quote-syntax append) (cadr a) (loop (cdr s) depth)))
+ (loop-pair cons (quote-syntax cons) a (cdr s) depth))]
+ [(and (identifier? a)
+ (free-id=? (syntax-e a) 'quasiquote))
+ (unless (= (length s) 2)
+ (bad-syntax s))
+ (loop-pair list (quote-syntax list) a (cadr s) (+ depth 1))]
+ [else
+ (loop-pair cons (quote-syntax cons) a (cdr s) depth)]))]
+ [else (list quot s)])))))))
+
+(define-syntax unquote misplaced-syntax)
+(define-syntax unquote-splicing misplaced-syntax)
--- /dev/null
+++ b/lib/zuo/private/base-common/state.zuo
@@ -1,0 +1,59 @@
+#lang zuo/datum
+
+;; The state of expansion is a combinion of
+;; * bindings
+;; * defined variables being lifted, or #f for a module top
+;; * "nominals", which is information about `require`s that is
+;; used to implement `(provide (all-from-out ....))`
+
+(define make-state (lambda (binds nominals) (cons binds (cons #f nominals))))
+(define state-binds car)
+(define state-variables cadr)
+(define state-nominals cddr)
+(define (state-set-binds state binds) (cons binds (cdr state)))
+(define (state-set-nominals state nominals) (cons (car state) (cons (cadr state) nominals)))
+(define (state-set-variables state variables) (cons (car state) (cons variables (cddr state))))
+
+;; helper to lookup or update nominals:
+(define (call-with-nominal state mod-path default-ids k)
+ (let* ([fronted
+ (letrec ([assoc-to-front
+ (lambda (l)
+ (cond
+ [(null? l) (list (cons mod-path default-ids))]
+ [(mod-path=? mod-path (caar l)) l]
+ [else (let ([new-l (assoc-to-front (cdr l))])
+ (cons (car new-l) (cons (car l) (cdr new-l))))]))])
+ (assoc-to-front (state-nominals state)))])
+ (k (cdar fronted)
+ (lambda (new-sym+bs)
+ (let* ([new-noms (cons (cons (caar fronted) new-sym+bs)
+ (cdr fronted))])
+ (state-set-nominals state new-noms))))))
+
+(define (init-nominal state mod-path)
+ (call-with-nominal state mod-path '()
+ (lambda (sym+binds install)
+ (install sym+binds))))
+
+(define (record-nominal state mod-path sym bind)
+ (call-with-nominal state mod-path '()
+ (lambda (sym+binds install)
+ (install (cons (cons sym bind) sym+binds)))))
+
+(define (lookup-nominal state mod-path)
+ (call-with-nominal state mod-path #f
+ (lambda (sym+binds install)
+ sym+binds)))
+
+;; in case `all-from-out` is used on the initial import,
+;; adds all the current ids in `binds` as nominally imported
+(define (initial-nominals mod-path sym+bs)
+ (list (cons mod-path sym+bs)))
+
+;; Module top-level state contains provides and submodules
+(define empty-modtop (cons '() '()))
+(define modtop-provides car)
+(define modtop-modules cdr)
+(define (modtop-set-provides modtop provides) (cons provides (cdr modtop)))
+(define (modtop-set-modules modtop modules) (cons (car modtop) modules))
--- /dev/null
+++ b/lib/zuo/private/base-common/struct.zuo
@@ -1,0 +1,64 @@
+#lang zuo/datum
+(require "and-or.zuo"
+ "syntax-error.zuo"
+ "../pair.zuo"
+ "../list.zuo"
+ "define.zuo"
+ "let.zuo"
+ "quasiquote.zuo"
+ "../more.zuo")
+
+(provide struct)
+
+(define-syntax struct
+ (lambda (stx)
+ (unless (and (list? stx)
+ (= (length stx) 3)
+ (identifier? (cadr stx)))
+ (bad-syntax stx))
+ (define name (cadr stx))
+ (define fields (cadr (cdr stx)))
+ (unless (and (list? fields)
+ (andmap identifier? fields))
+ (bad-syntax stx))
+ (define key `(,(quote-syntax quote)
+ ,(string->uninterned-symbol (symbol->string (syntax-e name)))))
+ (define name? (string->symbol (datum->syntax name (~a (syntax-e name) "?"))))
+ `(,(quote-syntax begin)
+ (,(quote-syntax define) ,name
+ (,(quote-syntax lambda)
+ ,fields
+ (,(quote-syntax opaque) ,key
+ (,(quote-syntax list) ,@fields))))
+ (,(quote-syntax define) (,name? v) (,(quote-syntax and)
+ (,(quote-syntax opaque-ref) ,key v #f)
+ #t))
+ ,@(let loop ([fields fields] [index 0])
+ (cond
+ [(null? fields) '()]
+ [else
+ (let ([field (car fields)])
+ (let ([ref (datum->syntax field (string->symbol (~a (syntax-e name)
+ "-"
+ (syntax-e field))))]
+ [set (datum->syntax field (string->symbol (~a (syntax-e name)
+ "-set-"
+ (syntax-e field))))])
+ (define mk
+ (lambda (head res)
+ `(,(quote-syntax define) ,head
+ (,(quote-syntax let)
+ ([c (,(quote-syntax opaque-ref) ,key v #f)])
+ (,(quote-syntax if)
+ c
+ ,res
+ (,(quote-syntax arg-error)
+ (,(quote-syntax quote) ,(car head))
+ ,(symbol->string (syntax-e name))
+ v))))))
+ (cons
+ `(,(quote-syntax begin)
+ ,(mk `(,ref v) `(,(quote-syntax list-ref) c ,index))
+ ,(mk `(,set v a) `(,(quote-syntax opaque) ,key (,(quote-syntax list-set) c ,index a))))
+ (loop (cdr fields)
+ (+ index 1)))))])))))
--- /dev/null
+++ b/lib/zuo/private/base-common/syntax-error.zuo
@@ -1,0 +1,22 @@
+#lang zuo/datum
+
+(provide syntax-error
+ bad-syntax
+ misplaced-syntax
+ duplicate-identifier)
+
+(define syntax-error
+ (lambda (msg stx)
+ (error (~a msg ": " (~s (syntax->datum stx))))))
+
+(define bad-syntax
+ (lambda (stx)
+ (syntax-error "bad syntax" stx)))
+
+(define misplaced-syntax
+ (lambda (stx)
+ (syntax-error "misplaced syntax" stx)))
+
+(define duplicate-identifier
+ (lambda (stx)
+ (syntax-error "duplicate identifier" stx)))
--- /dev/null
+++ b/lib/zuo/private/base-hygienic.zuo
@@ -1,0 +1,18 @@
+#lang zuo/private/stitcher
+
+;; Instantiates the expander for hygienic, set-of-scopes macros
+
+(define macro-protocol 'scope-sets)
+(define merge-bindings-export-key 'scope-sets-bindings)
+(define language-mod-path 'zuo/private/base-hygienic)
+
+(include "base-common/lib.zuo")
+(include "base-common/bind-struct.zuo")
+(include "base-common/state.zuo")
+
+(include "base-hygienic/syntax.zuo")
+
+(include "base-common/dynamic.zuo")
+(include "base-common/bind.zuo")
+(include "base-common/parse.zuo")
+(include "base-common/entry.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/and-or.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/and-or.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/check-dups.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/check-dups.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/define-help.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/define-help.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/define.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/define.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/let.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/let.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/main.zuo
@@ -1,0 +1,5 @@
+#lang zuo/private/base-hygienic
+
+(provide (all-from-out zuo/private/base-hygienic))
+
+(include "../base-common/main.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/more-syntax.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/more-syntax.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/opt-lambda.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/opt-lambda.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/quasiquote.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/quasiquote.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/struct.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/struct.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/syntax-error.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base-hygienic
+
+(include "../base-common/syntax-error.zuo")
--- /dev/null
+++ b/lib/zuo/private/base-hygienic/syntax.zuo
@@ -1,0 +1,227 @@
+#lang zuo/datum
+
+;; This set-of-scopes implementation is based on the "pico" branch of
+;;
+;; https://github.com/mflatt/expander/
+
+(define (make-scope name) (string->uninterned-symbol name))
+(define (set-add ht v) (hash-set ht v #t))
+(define set-remove hash-remove)
+(define (set-flip ht v)
+ (let ([ht2 (hash-remove ht v)])
+ (if (eq? ht ht2)
+ (hash-set ht v #t)
+ ht2)))
+
+(define (scope-set=? sc1 sc2)
+ (and (hash-keys-subset? sc1 sc2)
+ (hash-keys-subset? sc2 sc1)))
+
+;; A syntax object is an opaque record combining a symbol with scopes
+(define syntax-tag (string->uninterned-symbol "syntax"))
+(define identifier (lambda (sym scopes) (opaque syntax-tag (cons sym scopes))))
+(define identifier? (lambda (v) (symbol? (car (opaque-ref syntax-tag v '(#f . #f))))))
+(define syntax-e (lambda (v) (car (opaque-ref syntax-tag v #f))))
+(define identifier-scopes (lambda (v) (cdr (opaque-ref syntax-tag v #f))))
+
+(define datum->syntax
+ (letrec ([datum->syntax (lambda (ctx v)
+ (cond
+ [(symbol? v) (identifier v (identifier-scopes ctx))]
+ [(pair? v) (cons (datum->syntax ctx (car v))
+ (datum->syntax ctx (cdr v)))]
+ [else v]))])
+ datum->syntax))
+
+(define syntax->datum
+ (letrec ([syntax->datum (lambda (s)
+ (cond
+ [(identifier? s) (syntax-e s)]
+ [(pair? s) (cons (syntax->datum (car s))
+ (syntax->datum (cdr s)))]
+ [else s]))])
+ syntax->datum))
+
+(define checked-syntax-e
+ (let ([syntax-e (lambda (stx)
+ (unless (identifier? stx)
+ (arg-error 'syntax-e "syntax object" stx))
+ (syntax-e stx))])
+ syntax-e))
+(define checked-datum->syntax
+ (let ([datum->syntax (lambda (ctx v)
+ (unless (identifier? ctx)
+ (arg-error 'datum->syntax "syntax object" ctx))
+ (datum->syntax ctx v))])
+ datum->syntax))
+(define checked-syntax->datum syntax->datum)
+
+;; Note: no lazy propagation, so this isn't going to scale well
+(define adjust-scope
+ (letrec ([adjust-scope
+ (lambda (s scope op)
+ (cond
+ [(pair? s) (cons (adjust-scope (car s) scope op)
+ (adjust-scope (cdr s) scope op))]
+ [(identifier? s) (identifier (syntax-e s)
+ (op (identifier-scopes s) scope))]
+ [else s]))])
+ adjust-scope))
+
+(define (add-scope s scope) (adjust-scope s scope set-add))
+(define (remove-scope s scope) (adjust-scope s scope set-remove))
+(define (flip-scope s scope) (adjust-scope s scope set-flip))
+
+;; Unlike the "pico" expander, this one has some support for modules.
+;; To avoid a global mutable table (which the kernel does not allow!),
+;; we pull in binding information from another module whenever we
+;; require a module. That merge is somewhat expensive, so as a
+;; shortcut, a `binds` pairs the binding table with a "merged" table
+;; to record when a merge has already been performed from each module.
+(define make-binds cons)
+(define binds-hash car)
+(define binds-merged cdr)
+(define (binds-set-hash binds ht) (cons ht (cdr binds)))
+
+(define (add-binding* binds id binding)
+ (let* ([sym (syntax-e id)]
+ [sc (identifier-scopes id)]
+ [ht (binds-hash binds)]
+ [sym-binds (hash-ref ht sym (hash))]
+ [k-scope (car (hash-keys sc))] ; relying on deterministic order
+ [sc+bs (hash-ref sym-binds k-scope '())]
+ [sym-binds (hash-set sym-binds k-scope (cons (cons sc binding) sc+bs))])
+ (binds-set-hash binds (hash-set ht sym sym-binds))))
+
+(define (find-all-matching-bindings binds id)
+ (let* ([sym (syntax-e id)]
+ [id-sc (identifier-scopes id)]
+ [sym-binds (hash-ref (binds-hash binds) sym #f)])
+ (if (not sym-binds)
+ '()
+ (foldl (lambda (scope lst)
+ (foldl (lambda (sc+b lst)
+ (let* ([sc (car sc+b)])
+ (if (hash-keys-subset? sc id-sc)
+ (cons sc+b lst)
+ lst)))
+ lst
+ (hash-ref sym-binds scope '())))
+ '()
+ (hash-keys sym-binds)))))
+
+(define (check-unambiguous id max-sc+b candidate-sc+bs)
+ (map (lambda (sc+b)
+ (unless (hash-keys-subset? (car sc+b)
+ (car max-sc+b))
+ (error "ambiguous" (syntax-e id))))
+ candidate-sc+bs))
+
+(define (resolve* binds id same-defn-ctx?)
+ (let* ([candidate-sc+bs (find-all-matching-bindings binds id)])
+ (cond
+ [(pair? candidate-sc+bs)
+ (let* ([max-sc+binding (foldl (lambda (sc+b max-sc+b)
+ (if (> (hash-count (car max-sc+b))
+ (hash-count (car sc+b)))
+ max-sc+b
+ sc+b))
+ (car candidate-sc+bs)
+ (cdr candidate-sc+bs))])
+ (check-unambiguous id max-sc+binding candidate-sc+bs)
+ (if same-defn-ctx?
+ (and (scope-set=? (identifier-scopes id)
+ (car max-sc+binding))
+ (cdr max-sc+binding))
+ (cdr max-sc+binding)))]
+ [else #f])))
+
+(define (bound-identifier=? id1 id2)
+ (unless (identifier? id1) (arg-error 'bound-identifier=? "syntax object" id1))
+ (unless (identifier? id2) (arg-error 'bound-identifier=? "syntax object" id2))
+ (and (eq? (syntax-e id1) (syntax-e id2))
+ (scope-set=? (identifier-scopes id1)
+ (identifier-scopes id2))))
+
+(include "../base-common/free-id-eq.zuo")
+
+;; Definition-context tracking is covered by scopes
+(define (new-defn-context* binds)
+ binds)
+
+;; The merge step described above at `make-binds`
+(define (merge-binds* binds key+m-binds)
+ (let* ([merged (binds-merged binds)]
+ [key (car key+m-binds)])
+ (cond
+ [(hash-ref merged key #f)
+ ;; already merged
+ binds]
+ [else
+ (let* ([merged (hash-set merged key #t)]
+ [ht (binds-hash binds)]
+ [m-ht (binds-hash (cdr key+m-binds))]
+ [new-ht (foldl (lambda (sym ht)
+ (let* ([sym-ht (hash-ref ht sym (hash))]
+ [m-sym-ht (hash-ref m-ht sym #f)]
+ [new-sym-ht
+ (foldl (lambda (s sym-ht)
+ (hash-set sym-ht
+ s
+ (append (hash-ref m-sym-ht s '())
+ (hash-ref sym-ht s '()))))
+ sym-ht
+ (hash-keys m-sym-ht))])
+ (hash-set ht sym new-sym-ht)))
+ ht
+ (hash-keys m-ht))])
+ (make-binds new-ht merged))])))
+
+;; Convert an expansion context plus bindings to mergable key+binds
+(define (make-export-merge-binds ctx binds)
+ (cons (car (hash-keys (identifier-scopes ctx))) binds))
+
+;; A fresh module context has a fresh scope
+(define (make-module-context mod-path)
+ (let* ([mod-scope (make-scope "module")]
+ [ctx (identifier 'module (hash mod-scope #t))])
+ ctx))
+
+;; Creates a binding table from an initial imports and a
+;; context that was just created from `make-module-context`
+(define (binds-create provides ctx)
+ (let* ([sc (identifier-scopes ctx)]
+ [scope (car (hash-keys sc))])
+ (let ([binds-ht (foldl (lambda (sym binds-ht)
+ (let ([bind (hash-ref provides sym #f)])
+ (hash-set binds-ht sym (hash scope (list (cons sc bind))))))
+ (hash)
+ (hash-keys provides))])
+ (make-binds binds-ht (hash)))))
+
+;; Implements the `quote-syntax` form
+(define (syntax-quote v mod-ctx binds)
+ (list 'quote v))
+
+(define (apply-macro m s ctx binds name k)
+ (let* ([apply-macro
+ (lambda (proc ctx)
+ (let* ([new-scope (make-scope "macro")]
+ [s (add-scope s new-scope)]
+ [s (apply-macro* proc s name (lambda (a b)
+ (free-id=? binds (datum->syntax ctx a)
+ (datum->syntax ctx b))))]
+ [s (datum->syntax ctx s)]
+ [s (flip-scope s new-scope)])
+ (k s binds)))])
+ (cond
+ [(defined-macro? m) (apply-macro (defined-macro-proc m) ctx)]
+ [else
+ (let* ([implementation (macro-implementation m)]
+ [proc (car implementation)]
+ [ctx (cdr implementation)])
+ (apply-macro proc ctx))])))
+
+;; Convert a local macro to one that can be used as imported elsewhere
+(define (make-exported-macro proc ctx)
+ (make-macro (cons proc ctx)))
--- /dev/null
+++ b/lib/zuo/private/base.zuo
@@ -1,0 +1,18 @@
+#lang zuo/private/stitcher
+
+;; Instantiates the expander for non-hygenic-by-default macros
+
+(define macro-protocol 'defmacro)
+(define merge-bindings-export-key 'defmacro-bindings)
+(define language-mod-path 'zuo/private/base)
+
+(include "base-common/lib.zuo")
+(include "base-common/bind-struct.zuo")
+(include "base-common/state.zuo")
+
+(include "base/s-exp.zuo")
+
+(include "base-common/dynamic.zuo")
+(include "base-common/bind.zuo")
+(include "base-common/parse.zuo")
+(include "base-common/entry.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/and-or.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/and-or.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/check-dups.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/check-dups.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/define-help.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/define-help.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/define.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/define.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/let.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/let.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/main.zuo
@@ -1,0 +1,5 @@
+#lang zuo/private/base
+
+(provide (all-from-out zuo/private/base))
+
+(include "../base-common/main.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/more-syntax.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/more-syntax.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/opt-lambda.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/opt-lambda.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/quasiquote.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/quasiquote.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/s-exp.zuo
@@ -1,0 +1,157 @@
+#lang zuo/datum
+
+;; A context is just a distinct identity used in binding tables
+(define (make-module-context mod-path)
+ (string->uninterned-symbol "module"))
+
+;; A syntactic-closure syntax object pairs a symbol with a context
+(define syntactic-closure-tag (string->uninterned-symbol "identifier"))
+(define (syntactic-closure sym ctx) (opaque syntactic-closure-tag (cons sym ctx)))
+(define (syntactic-closure? v) (and (opaque-ref syntactic-closure-tag v #f) #t))
+(define (syntactic-closure-sym sc) (car (opaque-ref syntactic-closure-tag sc #f)))
+(define (syntactic-closure-ctx sc) (cdr (opaque-ref syntactic-closure-tag sc #f)))
+
+(define (identifier? v)
+ (or (symbol? v)
+ (syntactic-closure? v)))
+(define (syntax-e x)
+ (if (symbol? x)
+ x
+ (syntactic-closure-sym x)))
+
+(define (datum->syntax ctx d) d)
+(define syntax->datum
+ (letrec ([syntax->datum
+ (lambda (stx)
+ (cond
+ [(pair? stx) (cons (syntax->datum (car stx))
+ (syntax->datum (cdr stx)))]
+ [(identifier? stx) (syntax-e stx)]
+ [else stx]))])
+ syntax->datum))
+
+(define checked-syntax-e
+ (let ([syntax-e (lambda (x)
+ (unless (identifier? x) (arg-error 'syntax-e "syntax object" x))
+ (syntax-e x))])
+ syntax-e))
+(define checked-datum->syntax
+ (let ([datum->syntax (lambda (ctx d)
+ (unless (identifier? ctx) (arg-error 'datum->syntax "syntax object" ctx))
+ d)])
+ datum->syntax))
+(define checked-syntax->datum syntax->datum)
+
+;; Binding information has three parts:
+;; * ctx : the current binding context
+;; * sym -> ctx : the per-symbol default context for plain symbols
+;; * ctx -> sym -> bind : the binding table
+(define (make-binds ctx sym-hash ctx-hash) (cons ctx (cons sym-hash ctx-hash)))
+(define binds-ctx car)
+(define binds-sym-hash cadr)
+(define binds-ctx-hash cddr)
+(define (binds-set-ctx binds ctx) (cons ctx (cdr binds)))
+(define (binds-set-ctx-hash binds ctx-hash) (cons (car binds) (cons (cadr binds) ctx-hash)))
+
+(define (binds-create ht ctx)
+ (make-binds ctx
+ (foldl (lambda (sym sym-hash)
+ (hash-set sym-hash sym ctx))
+ (hash)
+ (hash-keys ht))
+ (hash ctx ht)))
+
+;; We don't need scopes, but these functions are here to line
+;; up with the set-of-scopes API
+(define (make-scope name) #f)
+(define (add-scope e scope) e)
+
+;; Install a new binding
+(define (add-binding-at binds sym ctx bind)
+ (let* ([sym-hash (binds-sym-hash binds)]
+ [ctx-hash (binds-ctx-hash binds)])
+ (make-binds (binds-ctx binds)
+ (hash-set sym-hash sym ctx)
+ (hash-set ctx-hash ctx (hash-set (hash-ref ctx-hash ctx (hash)) sym bind)))))
+(define (add-binding* binds id bind)
+ (if (symbol? id)
+ (add-binding-at binds
+ id (binds-ctx binds)
+ bind)
+ (add-binding-at binds
+ (syntactic-closure-sym id) (syntactic-closure-ctx id)
+ bind)))
+
+;; Find the binding for an identifier
+(define (resolve-at binds sym ctx same-defn-ctx?)
+ (and (or (not same-defn-ctx?)
+ (eq? ctx (binds-ctx binds)))
+ (hash-ref (hash-ref (binds-ctx-hash binds) ctx (hash)) sym #f)))
+(define (resolve* binds id same-defn-ctx?)
+ (if (symbol? id)
+ (resolve-at binds
+ id (hash-ref (binds-sym-hash binds) id (binds-ctx binds))
+ same-defn-ctx?)
+ (resolve-at binds
+ (syntactic-closure-sym id) (syntactic-closure-ctx id)
+ same-defn-ctx?)))
+
+(define (new-defn-context* binds)
+ (binds-set-ctx binds (string->uninterned-symbol "def")))
+
+;; When we require a module, we need to pull in binding information
+;; from the macro's module; the separate module contexts keep different binding
+;; information from getting mixed up
+(define (merge-binds* binds ctx+m-binds)
+ (let* ([ctx-hash (binds-ctx-hash binds)]
+ [ctx (car ctx+m-binds)])
+ (if (hash-ref ctx-hash ctx #f)
+ ;; must be merged already
+ binds
+ (let* ([m-ctx-hash (binds-ctx-hash (cdr ctx+m-binds))]
+ [new-ctx-hash (foldl (lambda (ctx ctx-hash)
+ (hash-set ctx-hash ctx (hash-ref m-ctx-hash ctx #f)))
+ ctx-hash
+ (hash-keys m-ctx-hash))])
+ (binds-set-ctx-hash binds new-ctx-hash)))))
+
+;; Convert an expansion context plus bindings to mergable ctx+binds
+(define (make-export-merge-binds ctx binds)
+ (cons ctx binds))
+
+(define (bound-identifier=? a b)
+ (unless (identifier? a) (arg-error 'bound-identifier=? "syntax object" a))
+ (unless (identifier? b) (arg-error 'bound-identifier=? "syntax object" b))
+ (or (and (syntactic-closure? a)
+ (syntactic-closure? b)
+ (eq? (syntactic-closure-sym a) (syntactic-closure-sym b))
+ (eq? (syntactic-closure-ctx a) (syntactic-closure-ctx b)))
+ (eq? a b)))
+
+(include "../base-common/free-id-eq.zuo")
+
+;; syntax-quote turns a symbol into a syntactic closure, and leaves everything
+;; else alone; the closure captures the enclosing context where the symbol is
+;; currently bound, or the module context if it's not bound
+(define (syntax-quote v mod-ctx binds)
+ (letrec ([syntax-quote
+ (lambda (v)
+ (cond
+ [(pair? v) (list 'cons (syntax-quote (car v)) (syntax-quote (cdr v)))]
+ [(null? v) '()]
+ [(symbol? v)
+ (list 'quote (syntactic-closure v (hash-ref (binds-sym-hash binds) v mod-ctx)))]
+ [else v]))])
+ (syntax-quote v)))
+
+(define (apply-macro m s ctx binds name k)
+ (let ([proc (if (defined-macro? m)
+ (defined-macro-proc m)
+ (macro-implementation m))])
+ (k (apply-macro* proc s name (lambda (a b) (free-id=? binds a b)))
+ binds)))
+
+;; Convert a local macro to one that can be used as imported elsewhere
+(define (make-exported-macro proc ctx)
+ (make-macro proc))
+
--- /dev/null
+++ b/lib/zuo/private/base/struct.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/struct.zuo")
--- /dev/null
+++ b/lib/zuo/private/base/syntax-error.zuo
@@ -1,0 +1,3 @@
+#lang zuo/private/base
+
+(include "../base-common/syntax-error.zuo")
--- /dev/null
+++ b/lib/zuo/private/build-db.zuo
@@ -1,0 +1,230 @@
+#lang zuo/base
+
+;; Build results for each target are stored in the target's directory
+;; in "_zuo.db". Since multiple targets are likely to be in the same
+;; directory, the goal here is to be able to load information for all
+;; the targets at once.
+
+;; A timestamp-based SHA-1 cache for input files is stored in
+;; "_zuo_tc.db" alongside "_zuo.db" --- in the directory of a target
+;; that depends on the input files, not in the input file's directory
+;; (which is likely to be in the source tree). An input used by
+;; targets in different directories will have information cached in
+;; each of those directories. The cache may also include information
+;; for non-input targets that are dependencies, just because it's
+;; easier to not distinguish when writing.
+
+;; Paths are stored in the ".db" files as absolute (when they started
+;; that way in a target) or relative to the file's directory. The
+;; format of each file is a top-level sequence of
+;; (<rel-path> . <info>)
+;; For "_zuo.db", it's more specifically
+;; (<rel-path> <sha1> (<dep-rel-path> <sha1>) ...)
+;; For "_zuo_tc.db", it's
+;; (<rel-path> (<time-secs> . <time-msec>) <sha1>)
+
+(provide db-record-target-sha1s
+ db-load-sha1s
+
+ file-sha1/cached
+ path->absolute-path
+ dir-part
+
+ symbol->key
+ symbol-key?
+ symbol-key->symbol)
+
+;; for serialization and deserialization of dep-sha1s tables
+(define (hash->list ht db-dir)
+ (map (lambda (k) (list (serialize-key k db-dir) (hash-ref ht k)))
+ (hash-keys ht)))
+(define (list->hash l db-dir)
+ (foldl (lambda (p ht) (hash-set ht (deserialize-key (car p) db-dir) (cadr p)))
+ (hash)
+ l))
+(define (serialize-key key db-dir)
+ (if (symbol-key? key)
+ (symbol-key->symbol key)
+ ;; otherwise, represents a path
+ (let ([path (symbol->string key)])
+ (if (relative-path? path)
+ (find-relative-path db-dir
+ (if (relative-path? db-dir)
+ path
+ (path->complete-path path)))
+ path))))
+(define (deserialize-key key db-dir)
+ (if (string? key)
+ (string->symbol (if (relative-path? key)
+ (build-path db-dir key)
+ key))
+ (symbol->key key)))
+
+;; All relative file names are stored relative to `db-dir`, which
+;; defaults to the directory of target-path. Meanwhile, `target-path`
+;; and keys in an incoming ts are (or outgoing ts must be) relative to
+;; the current directory.
+(define (db-paths maybe-db-dir target-path k)
+ (define target-dir+name (split-path target-path))
+ (define target-dir (or (car target-dir+name) "."))
+ (define db-dir (or maybe-db-dir target-dir))
+ (define rel-target-path
+ (if (relative-path? target-path)
+ (if maybe-db-dir
+ (find-relative-path maybe-db-dir target-path)
+ (cdr target-dir+name))
+ target-path))
+ (define db-path (build-path db-dir "_zuo.db"))
+ (define tc-path (build-path db-dir "_zuo_tc.db"))
+ (k rel-target-path db-dir db-path tc-path))
+
+;; Records the result of a build of `name`, mainly storing the
+;; SHA-1 and dep SHA-1s in "_zuo.db", but also recording a timestamp
+;; plus SHA-1 for dependencies in "_zuo_tc.db".
+;; All relative file names are stored relative to `db-dir`, which
+;; defaults to the directory of target-path. On entry, `target-path`
+;; and keys in `ts` are relative to the current directory.
+(define (db-record-target-sha1s maybe-db-dir target-path ts co-outputs)
+ (db-paths
+ maybe-db-dir target-path
+ (lambda (rel-target-path db-dir db-path tc-path)
+ (define db-content
+ (if (file-exists? db-path)
+ (string-read (file->string db-path) 0 db-path)
+ '()))
+ (define dep-sha1s-l (hash->list (cdr ts) db-dir))
+ (define new-db-content (reassoc (list* rel-target-path (car ts) dep-sha1s-l) db-content))
+ (update-file db-path new-db-content)
+ (unless (ormap (lambda (p) (string=? (car p) "SOURCE_DATE_EPOCH")) (hash-ref (runtime-env) 'env))
+ (define tc-content
+ (if (file-exists? tc-path)
+ (string-read (file->string tc-path) 0 tc-path)
+ '()))
+ (define new-tc-content
+ (foldl (lambda (dep tc-content)
+ (define dep-name (car dep))
+ (cond
+ [(symbol? dep-name) tc-content]
+ [else
+ (define time (file-timestamp (if (relative-path? dep-name)
+ (build-path db-dir dep-name)
+ dep-name)))
+ (cond
+ [time (reassoc (list dep-name time (substring (cadr dep) 0 40)) tc-content)]
+ [else tc-content])]))
+ tc-content
+ (if (pair? co-outputs)
+ (append (split-sha1s rel-target-path co-outputs (car ts) db-dir)
+ dep-sha1s-l)
+ (cons (list rel-target-path (car ts)) dep-sha1s-l))))
+ (update-file tc-path new-tc-content)))))
+
+;; Loads previous-build information for `abs-path`, as well as cached
+;; SHA-1s for things that might be dependencies; loading needs to
+;; happen only once per directory that has a (non-input) build target
+(define (db-load-sha1s maybe-db-dir target-path db tc)
+ (db-paths
+ maybe-db-dir target-path
+ (lambda (name db-dir db-path tc-path)
+ (define key (string->symbol db-path))
+ (cond
+ [(hash-ref db key #f)
+ ;; already loaded
+ #f]
+ [else
+ ;; if loading fails, then we'll delete files on the
+ ;; grounds that they must be in bad shape
+ (define (read-in path table deserialize)
+ (suspend-signal) ; don't lose the file as a result of Ctl-C
+ (define c-handle (cleanable-file path))
+ (define content (if (file-exists? path)
+ (string-read (file->string path) 0 path)
+ '()))
+ (define new
+ (foldl (lambda (name+val table)
+ (define name (car name+val))
+ (define key (string->symbol (if (relative-path? name)
+ (build-path db-dir name)
+ name)))
+ (hash-set table key (deserialize (cdr name+val))))
+ table
+ content))
+ (cleanable-cancel c-handle)
+ (resume-signal)
+ new)
+ (define new-db (read-in db-path (hash-set db key #t)
+ (lambda (v)
+ (cons (car v)
+ (list->hash (cdr v) db-dir)))))
+ (define new-tc (read-in tc-path tc (lambda (v) v)))
+ (cons new-db new-tc)]))))
+
+;; Helpers to get an input file's SHA-1, possibly cached
+(define (file-sha1/cached path time-cache)
+ (let ([timestamp (file-timestamp path)])
+ (and timestamp
+ (let ([cached (and time-cache
+ (hash-ref time-cache
+ (string->symbol path)
+ #f))])
+ (if (and cached
+ (equal? (car cached) timestamp))
+ (cadr cached)
+ (string-sha1 (file->string path)))))))
+
+;; Split "sha1", which should have a sha1 for each of `rel-target-path`
+;; and each element of `co-outputs`, into a list of sha1s
+(define (split-sha1s rel-target-path co-outputs sha1 db-dir)
+ (cons (list rel-target-path (substring sha1 0 40))
+ (let loop ([co-outputs co-outputs] [start 40])
+ (cond
+ [(null? co-outputs) '()]
+ [else
+ (let ([co-output (car co-outputs)])
+ (cons (list (if (relative-path? co-output)
+ (find-relative-path db-dir co-output)
+ co-output)
+ (substring sha1 start (+ start 40)))
+ (loop (cdr co-outputs) (+ start 40))))]))))
+
+;; Atomic write by write-to-temporary-and-move
+(define (update-file path new-content)
+ (define path-tmp (~a path "-tmp"))
+ (display-to-file (string-join (map ~s new-content) "\n") path-tmp :truncate)
+ (when (eq? 'windows (hash-ref (runtime-env) 'system-type))
+ (when (file-exists? path) (rm path)))
+ (mv path-tmp path))
+
+;; Like `hash-set`, but for an association list
+(define (reassoc pr content)
+ (cond
+ [(null? content) (list pr)]
+ [(string=? (caar content) (car pr)) (cons pr (cdr content))]
+ [else (cons (car content) (reassoc pr (cdr content)))]))
+
+(define (file-timestamp path)
+ (define s (stat path))
+ (and s (list (hash-ref s 'modify-time-seconds)
+ (hash-ref s 'modify-time-nanoseconds))))
+
+(define (path->absolute-path p)
+ (if (relative-path? p)
+ (build-path (hash-ref (runtime-env) 'dir) p)
+ p))
+
+(define (dir-part path)
+ (if (symbol? path)
+ "."
+ (or (car (split-path path)) ".")))
+
+(define (symbol->key name)
+ (string->uninterned-symbol (~a "!" (symbol->string name))))
+
+(define (symbol-key? sym)
+ (let ([str (symbol->string sym)])
+ (and (= (char "!") (string-ref str 0))
+ (not (eq? sym (string->symbol str))))))
+
+(define (symbol-key->symbol sym)
+ (let ([str (symbol->string sym)])
+ (string->symbol (substring str 1 (string-length str)))))
--- /dev/null
+++ b/lib/zuo/private/cmdline-run.zuo
@@ -1,0 +1,159 @@
+#lang zuo/base
+
+(provide run-cmdline
+ flag-parser)
+
+(define (run-cmdline program cmd args flags finish-handler finish-spec usage help-specs)
+
+ (define (finish cmd args)
+ (define expected (+ (length (car finish-spec))
+ (length (cdr finish-spec))))
+ (unless (if (null? (cddr finish-spec))
+ (and (>= (length args) (length (car finish-spec)))
+ (<= (length args) (+ (length (car finish-spec))
+ (length (cadr finish-spec)))))
+ (>= (length args) (length (car finish-spec))))
+ (error (~a program
+ ": expected "
+ (let ([s (spec->expected-string finish-spec)])
+ (if (string=? "" s)
+ "no command-line arguments"
+ (~a "arguments " s)))
+ (if (null? args)
+ ""
+ (~a "\n given arguments:\n "
+ (string-join (map ~a args) "\n "))))))
+ (apply-cmd "arguments handler" (apply finish-handler args) cmd))
+
+ (let loop ([pend-flags '()] [args args] [saw (hash)] [cmd cmd])
+ (cond
+ [(and (null? args) (null? pend-flags)) (finish cmd args)]
+ [else
+ (let* ([arg (if (pair? pend-flags) (car pend-flags) (car args))]
+ [pend-flags (if (pair? pend-flags) (cdr pend-flags) '())]
+ [args (if (pair? pend-flags) args (cdr args))]
+ [a (assoc arg flags)])
+ (cond
+ [a ((cdr a) program pend-flags (cons arg args) cmd saw loop)]
+ [(string=? arg "--") (if (null? pend-flags)
+ (finish cmd args)
+ (loop (append pend-flags (list arg)) args saw cmd))]
+ [(or (string=? arg "--help")
+ (string=? arg "-h"))
+ (show-help program finish-spec usage help-specs flags)
+ (exit 0)]
+ [(and (> (string-length arg) 2)
+ (= (string-ref arg 0) (char "-"))
+ (not (= (string-ref arg 1) (char "-"))))
+ (loop (split-flags arg) args saw cmd)]
+ [(and (> (string-length arg) 0)
+ (or (= (string-ref arg 0) (char "-"))
+ (= (string-ref arg 0) (char "+"))))
+ (error (~a program ": unrecognized flag " arg))]
+ [else (finish cmd (cons arg args))]))])))
+
+(define (split-flags s)
+ (let loop ([i 1])
+ (if (= i (string-length s))
+ '()
+ (cons (string (char "-") (string-ref s i))
+ (loop (+ i 1))))))
+
+(define (spec->expected-string spec)
+ (~a (string-join (car spec))
+ (let ([dots (if (null? (cddr spec)) "" " ...")])
+ (if (null? (cadr spec))
+ dots
+ (~a " [" (string-join (cadr spec)) dots "]")))))
+
+(define (flag-parser key handler spec)
+ (lambda (program pend-flags flag+args cmd saw k)
+ (when key
+ (when (hash-ref saw key #f)
+ (error (~a program ": redundant or conflicting flag " (car flag+args)))))
+ (define new-saw (if key (hash-set saw key #t) saw))
+ (define args (cdr flag+args))
+ (unless (>= (length args) (length (car spec)))
+ (error (~a program
+ ": expected more arguments for "
+ (car flag+args)
+ " "
+ (spec->expected-string spec))))
+ (define consumed (if (= 3 (length spec))
+ args
+ (let loop ([args args] [need (length (car spec))] [allow (length (cadr spec))])
+ (cond
+ [(= (+ need allow) 0) '()]
+ [(null? args) '()]
+ [else (cons (car args)
+ (loop (cdr args)
+ (if (= need 0) 0 (- need 1))
+ (if (= need 0) (- allow 1) allow)))]))))
+ (define rest-args (list-tail args (length consumed)))
+ (k pend-flags rest-args new-saw (apply-cmd (~a "handler for " (car flag+args))
+ (apply handler consumed)
+ cmd))))
+
+(define (apply-cmd who handler cmd)
+ (if (procedure? handler)
+ (handler cmd)
+ (error (~a " did not produce a procedure to receive accumulated state"))))
+
+(define (show-help program finish-spec usage help-specs flags)
+ (displayln
+ (~a "usage: " program " "
+ (or usage
+ (~a "[<option> ...]"
+ (let ([s (spec->expected-string finish-spec)])
+ (if (string=? s "")
+ ""
+ (~a " " s)))))))
+ (display "\n<option> is one of\n\n")
+ (let loop ([help-specs help-specs] [in-key #f])
+ (unless (null? help-specs)
+ (define next-key (and (pair? (cdr help-specs))
+ (caar (cdr help-specs))))
+ (define help-spec (car help-specs))
+ (define key (car help-spec))
+ (define flags (list-ref help-spec 1))
+ (define spec (list-ref help-spec 2))
+ (define text (list-ref help-spec 3))
+ (displayln (~a (cond
+ [(not key) "*"]
+ [(eq? key in-key) "|"]
+ [(eq? key next-key) "/"]
+ [(eq? key next-key) "|"]
+ [else " "])
+ " "
+ (string-join flags ", ")))
+ (let loop ([text text])
+ (when (pair? text)
+ (displayln (~a (cond
+ [(eq? key next-key) "|"]
+ [(and key (eq? key in-key))
+ (if (null? (cdr text))
+ "\\"
+ "|")]
+ [else " "])
+ " "
+ (car text)))
+ (loop (cdr text))))
+ (loop (cdr help-specs) key)))
+ (display (~a " --help" (if (assoc "-h" flags) "" ", -h") "\n"
+ " Show this help\n"
+ " --\n"
+ " Do not treat any remaining argument as a switch (at this level)\n"
+ "\n"))
+ (define any-mult? (ormap (lambda (help-spec) (not (car help-spec))) help-specs))
+ (define any-excl? (let loop ([help-specs help-specs] [key #f])
+ (and (pair? help-specs)
+ (or (and key (eq? key (caar help-specs)))
+ (loop (cdr help-specs) (caar help-specs))))))
+ (when any-mult?
+ (display " * Asterisks indicate options allowed multiple times.\n"))
+ (when any-excl?
+ (display " /|\\ Brackets indicate mutually exclusive options.\n"))
+ (when (or any-mult? any-excl?)
+ (display "\n"))
+ (display (~a " Multiple single-letter switches can be combined after\n"
+ " one `-`. For example, `-h-` is the same as `-h --`.\n")))
--- /dev/null
+++ b/lib/zuo/private/list.zuo
@@ -1,0 +1,115 @@
+#lang zuo/private/base
+
+;; See note in "pair.zuo" about language choice
+
+(require "base/and-or.zuo")
+
+(provide list*
+ list-tail
+ map
+ for-each
+ foldl
+ andmap
+ ormap
+ filter)
+
+(define list*
+ (lambda (val . vals)
+ (if (null? vals)
+ val
+ (cons val (apply list* vals)))))
+
+(define list-tail
+ (lambda (l n)
+ (unless (and (integer? n) (>= n 0)) (arg-error 'list-tail "index" n))
+ (letrec ([list-tail (lambda (n l)
+ (cond
+ [(= n 0) l]
+ [(pair? l) (list-tail (- n 1) (cdr l))]
+ [else (error "list-tail: encountered a non-pair" l)]))])
+ (list-tail n l))))
+
+(define foldl
+ (lambda (f init lst)
+ (unless (procedure? f) (arg-error 'foldl "procedure" f))
+ (unless (list? lst) (arg-error 'foldl "list" lst))
+ (letrec ([foldl (lambda (accum lst)
+ (if (null? lst)
+ accum
+ (foldl (f (car lst) accum) (cdr lst))))])
+ (foldl init lst))))
+
+;; Other functions could be written with `foldl`, but we write them
+;; directly so that a more helpful name shows up stack traces
+
+(define map
+ (lambda (f lst . lsts)
+ (unless (procedure? f) (arg-error 'map "procedure" f))
+ (unless (list? lst) (arg-error 'map "list" lst))
+ (cond
+ [(null? lsts)
+ (letrec ([map (lambda (lst)
+ (if (null? lst)
+ '()
+ (cons (f (car lst)) (map (cdr lst)))))])
+ (map lst))]
+ [else
+ (letrec ([check (lambda (lsts)
+ (unless (null? lsts)
+ (unless (list? (car lsts))
+ (arg-error 'map "list" (car lsts)))
+ (unless (= (length lst) (length (car lsts)))
+ (error "map: lists have different lengths" (cons lst lsts)))
+ (check (cdr lsts))))])
+ (check lsts))
+ (let ([map1 map])
+ (letrec ([map (lambda (lsts)
+ (if (null? (car lsts))
+ '()
+ (cons (apply f (map1 car lsts))
+ (map (map1 cdr lsts)))))])
+ (map (cons lst lsts))))])))
+
+(define for-each
+ (lambda (f lst)
+ (unless (procedure? f) (arg-error 'for-each "procedure" f))
+ (unless (list? lst) (arg-error 'for-each "list" lst))
+ (letrec ([for-each (lambda (lst)
+ (unless (null? lst)
+ (f (car lst))
+ (for-each (cdr lst))))])
+ (for-each lst))))
+
+(define andmap
+ (lambda (f lst)
+ (unless (procedure? f) (arg-error 'andmap "procedure" f))
+ (unless (list? lst) (arg-error 'andmap "list" lst))
+ (letrec ([andmap (lambda (lst)
+ (cond
+ [(null? lst) #t]
+ [(null? (cdr lst)) (f (car lst))]
+ [else (and (f (car lst)) (andmap (cdr lst)))]))])
+ (andmap lst))))
+
+(define ormap
+ (lambda (f lst)
+ (unless (procedure? f) (arg-error 'ormap "procedure" f))
+ (unless (list? lst) (arg-error 'ormap "list" lst))
+ (letrec ([ormap (lambda (lst)
+ (cond
+ [(null? lst) #f]
+ [(null? (cdr lst)) (f (car lst))]
+ [else (or (f (car lst)) (ormap (cdr lst)))]))])
+ (ormap lst))))
+
+(define filter
+ (lambda (f lst)
+ (unless (procedure? f) (arg-error 'filter "procedure" f))
+ (unless (list? lst) (arg-error 'filter "list" lst))
+ (letrec ([filter (lambda (lst)
+ (if (null? lst)
+ '()
+ (if (f (car lst))
+ (cons (car lst) (filter (cdr lst)))
+ (filter (cdr lst)))))])
+ (filter lst))))
--- /dev/null
+++ b/lib/zuo/private/looper.zuo
@@ -1,0 +1,108 @@
+#lang zuo/kernel
+
+;; The `zuo/private/looper` language is like `zuo/kernel`, but adds
+;; `letrec`, `cond`, and `let*` --- because implementing simple
+;; transformations like `or` and `and` is especially tedious without
+;; those. This language use is to implement `zuo/private/stitcher`.
+
+(let ([convert-var (variable 'convert)])
+ (let ([convert (lambda (s) ((variable-ref convert-var) s))])
+ (begin
+ (variable-set!
+ convert-var
+ (lambda (s)
+ (if (pair? s)
+ (if (eq? (car s) 'letrec)
+ (let ([no (lambda () (error (~a "letrec: bad looper syntax: " (~s s))))])
+ (let ([clauses (if (pair? (cdr s))
+ (car (cdr s))
+ #f)])
+ (if (if (list? clauses)
+ (if (= 1 (length clauses))
+ (= 2 (length (car clauses)))
+ #f)
+ #f)
+ (let ([id (car (car clauses))])
+ (let ([rhs (car (cdr (car clauses)))])
+ (if (if (pair? rhs)
+ (eq? 'lambda (car rhs))
+ #f)
+ (let ([var (string->uninterned-symbol "recvar")])
+ (list 'let
+ (list (list var (list 'variable (list 'quote id))))
+ (list 'let
+ (list (list id
+ (list 'lambda (car (cdr rhs))
+ (cons (list 'variable-ref var)
+ (car (cdr rhs))))))
+ (list 'begin
+ (list variable-set!
+ var
+ (let ([lam (convert rhs)])
+ (if #t ; keep-names?
+ (cons (car lam)
+ (cons (car (cdr lam))
+ (cons (symbol->string id)
+ (cdr (cdr lam)))))
+ lam)))
+ (let ([body (cdr (cdr s))])
+ (if (if (list? body)
+ (pair? body)
+ #f)
+ (convert (if (null? (cdr body))
+ (car body)
+ (cons 'begin body)))
+ (no)))))))
+ (no))))
+ (no))))
+ (if (eq? (car s) 'cond)
+ (if (not (list? s))
+ (error (~a "cond: bad looper syntax: " (~s s)))
+ (if (null? (cdr s))
+ '(void)
+ (let ([cl (car (cdr s))])
+ (if (if (list? cl)
+ (>= (length cl) 2)
+ #f)
+ (let ([rhs (convert (cons 'begin (cdr cl)))])
+ (if (null? (cdr (cdr s)))
+ (if (eq? (car cl) 'else)
+ rhs
+ (list 'if (car cl) rhs '(void)))
+ (list 'if (car cl) rhs
+ (convert (cons 'cond (cdr (cdr s)))))))
+ (error (~a "cond clause: bad looper syntax: " (~s cl)))))))
+ (if (eq? (car s) 'let*)
+ (if (if (list? s)
+ (if (= (length s) 3)
+ (list? (car (cdr s)))
+ #f)
+ #f)
+ (let ([clauses (car (cdr s))])
+ (if (null? clauses)
+ (convert (car (cdr (cdr s))))
+ (let ([cl (car clauses)])
+ (if (if (list? cl)
+ (if (= (length cl) 2)
+ (symbol? (car cl))
+ #f)
+ #f)
+ (convert (list 'let (list cl)
+ (cons 'let*
+ (cons (cdr clauses)
+ (cdr (cdr s))))))
+ (error (~a "let* clause: bad looper syntax: " (~s cl)))))))
+ (error (~a "let*: bad looper syntax: " (~s s))))
+ (if (eq? (car s) 'quote)
+ s
+ (cons (convert (car s))
+ (convert (cdr s)))))))
+ (if (eq? s 'looper-eval) ; this is how we expose looper's eval to the next layer
+ (lambda (e) (kernel-eval (convert e)))
+ s))))
+ (hash 'read-and-eval
+ (lambda (str start mod-path)
+ (let ([es (string-read str start mod-path)])
+ (if (= 1 (length es))
+ (kernel-eval (convert (car es)))
+ (error "looper: only one expression allowed"))))))))
--- /dev/null
+++ b/lib/zuo/private/main-hygienic.zuo
@@ -1,0 +1,6 @@
+#lang zuo/hygienic/base
+
+(require zuo/hygienic/cmdline)
+
+(provide (all-from-out zuo/private/base-hygienic/main
+ zuo/hygienic/cmdline))
--- /dev/null
+++ b/lib/zuo/private/main.zuo
@@ -1,0 +1,18 @@
+#lang zuo/base
+
+(require zuo/cmdline
+ zuo/config
+ zuo/thread
+ zuo/build
+ zuo/shell
+ zuo/c
+ zuo/glob)
+
+(provide (all-from-out zuo/private/base/main
+ zuo/cmdline
+ zuo/config
+ zuo/thread
+ zuo/build
+ zuo/shell
+ zuo/c
+ zuo/glob))
--- /dev/null
+++ b/lib/zuo/private/more.zuo
@@ -1,0 +1,418 @@
+#lang zuo/private/base
+
+(require "base/and-or.zuo"
+ "base/let.zuo"
+ "base/define.zuo"
+ "list.zuo"
+ "base/more-syntax.zuo")
+
+(provide void?
+ boolean?
+ string-tree?
+
+ equal?
+ assoc
+ member
+ remove
+ sort
+
+ file-exists?
+ directory-exists?
+ link-exists?
+
+ explode-path
+ simple-form-path
+ find-relative-path
+ path-replace-extension
+ path-only
+ file-name-from-path
+ path->complete-path
+
+ ls*
+ mkdir-p
+ rm*
+ cp*
+
+ :error :truncate :must-truncate :append :update :can-update
+
+ display
+ displayln
+ file->string
+ display-to-file
+
+ string<?
+ string->integer
+
+ string-join
+ string-trim
+
+ find-executable-path
+ system-type)
+
+(define (void? v) (eq? v (void)))
+
+(define (boolean? v) (or (eq? v #t) (eq? v #f)))
+
+(define (string-tree? v)
+ (or (string? v)
+ (and (list? v)
+ (andmap string-tree? v))))
+
+(define (equal? a b)
+ (or (eq? a b)
+ (cond
+ [(pair? a)
+ (and (pair? b)
+ (equal? (car a) (car b))
+ (equal? (cdr a) (cdr b)))]
+ [(string? a) (and (string? b)
+ (string=? a b))]
+ [(integer? a) (and (integer? b)
+ (= a b))]
+ [(hash? a) (and (hash? b)
+ (= (hash-count a) (hash-count b))
+ (hash-keys-subset? a b)
+ (andmap (lambda (k)
+ (equal? (hash-ref a k #f)
+ (hash-ref b k #f)))
+ (hash-keys a)))]
+ [else #f])))
+
+(define (assoc k lst)
+ (unless (list? lst) (arg-error 'assoc "list" lst))
+ (letrec ([assoc (lambda (lst)
+ (cond
+ [(null? lst) #f]
+ [else
+ (let ([a (car lst)])
+ (unless (pair? a)
+ (error "assoc: non-pair found in list" a))
+ (if (equal? (car a) k)
+ a
+ (assoc (cdr lst))))]))])
+ (assoc lst)))
+
+(define (member k lst)
+ (unless (list? lst) (arg-error 'member "list" lst))
+ (letrec ([member (lambda (lst)
+ (cond
+ [(null? lst) #f]
+ [else
+ (if (equal? k (car lst))
+ lst
+ (member (cdr lst)))]))])
+ (member lst)))
+
+(define (remove k lst)
+ (unless (list? lst) (arg-error 'remove "list" lst))
+ (letrec ([remove (lambda (lst)
+ (cond
+ [(null? lst) '()]
+ [else
+ (if (equal? k (car lst))
+ (cdr lst)
+ (cons (car lst) (remove (cdr lst))))]))])
+ (remove lst)))
+
+(define (sort ls less-than?)
+ (unless (list? ls) (arg-error 'sort "list" ls))
+ (unless (procedure? less-than?) (arg-error 'sort "procedure" less-than?))
+ (let sort ([ls ls] [len (length ls)])
+ (cond
+ [(< len 2) ls]
+ [else (let ([half (quotient len 2)])
+ (let merge ([a (sort (list-tail ls half) (- len half))]
+ [b (sort (list-tail (reverse ls) (- len half)) half)])
+ (cond
+ [(null? a) b]
+ [(null? b) a]
+ [(less-than? (car b) (car a)) (cons (car b) (merge a (cdr b)))]
+ [else (cons (car a) (merge (cdr a) b))])))])))
+
+(define (file-exists? p)
+ (unless (path-string? p) (arg-error 'file-exists? "path string" p))
+ (let ([s (stat p)])
+ (and s (eq? (hash-ref s 'type) 'file))))
+
+(define (directory-exists? p)
+ (unless (path-string? p) (arg-error 'directory-exists?: "path string" p))
+ (let ([s (stat p)])
+ (and s (eq? (hash-ref s 'type) 'dir))))
+
+(define (link-exists? p)
+ (unless (path-string? p) (arg-error 'link-exists? "path string" p))
+ (let ([s (stat p #f)])
+ (and s (eq? (hash-ref s 'type) 'link))))
+
+(define (explode-path p)
+ (unless (path-string? p) (arg-error 'explode-path "path string" p))
+ (define l (split-path p))
+ (if (not (car l))
+ (list (cdr l))
+ (append (explode-path (car l)) (list (cdr l)))))
+
+(define (simple-form-path p)
+ (apply build-path (explode-path p)))
+
+(define (convert-wrt wrts wrt ups)
+ (cond
+ [(equal? (car wrts) "..")
+ (let ([here (let loop ([here (hash-ref (runtime-env) 'dir)] [ups ups])
+ (cond
+ [(= ups 0) here]
+ [else
+ (let ([l (split-path here)])
+ (if (not (car l))
+ (error "find-relative-path: too many ups" wrt)
+ (loop (car l) (- ups 1))))]))])
+ (let loop ([wrts wrts] [here here] [accum '()])
+ (cond
+ [(and (pair? wrts)
+ (equal? (car wrts) ".."))
+ (let ([l (split-path here)])
+ (if (not (car l))
+ (error "find-relative-path: too many ups" wrt)
+ (loop (cdr wrts) (car l) (cons (cdr l) accum))))]
+ [else (append (map (lambda (p) "..") wrts) accum)])))]
+ [else (map (lambda (p) "..") wrts)]))
+
+(define (find-relative-path wrt p)
+ (unless (path-string? wrt)
+ (arg-error 'find-relative-path "path string" wrt))
+ (unless (path-string? p)
+ (arg-error 'find-relative-path "path string" p))
+ (cond
+ [(relative-path? wrt)
+ (if (relative-path? p)
+ (do-find-relative-path wrt p #t)
+ p)]
+ [else
+ (if (relative-path? p)
+ (do-find-relative-path wrt (path->complete-path p) #t)
+ (do-find-relative-path wrt p #f))]))
+
+(define (do-find-relative-path wrt p rel?)
+ (define wrts (explode-path wrt))
+ (cond
+ [(string=? (car wrts) ".") p]
+ [else
+ (define ps (explode-path p))
+ (if (or rel? (equal? (car ps) (car wrts)))
+ ;; The `ups` accumulator effectively counts shared ".."s at the front of `wrts`
+ ;; and `ps`, which is needed if `wrts` has more ".."s
+ (let loop ([ps (if (string=? (car ps) ".") (cdr ps) ps)] [wrts wrts] [ups 0])
+ (cond
+ [(null? wrts) (if (null? ps) "." (apply build-path ps))]
+ [(null? ps) (apply build-path (convert-wrt wrts wrt ups))]
+ [(equal? (car ps) (car wrts)) (loop (cdr ps) (cdr wrts) (+ ups 1))]
+ [else (apply build-path (append (convert-wrt wrts wrt ups) ps))]))
+ p)]))
+
+(define (path-replace-extension path-in suffix)
+ (unless (path-string? path-in) (arg-error 'path-replace-extension "path string" path-in))
+ (unless (string? suffix) (arg-error 'path-replace-extension "string" suffix))
+ (define l (split-path path-in))
+ (define path (cdr l))
+ (define new-path
+ (let loop ([i (string-length path)])
+ (cond
+ [(<= i 1) (~a path suffix)]
+ [else
+ (let ([i (- i 1)])
+ (if (= (string-ref path i) (char "."))
+ (~a (substring path 0 i) suffix)
+ (loop i)))])))
+ (if (car l)
+ (build-path (car l) new-path)
+ new-path))
+
+(define (split-file-path who p dir-k dir-file-k)
+ (unless (path-string? p) (arg-error who "path string" p))
+ (let ([c (string-ref p (- (string-length p) 1))])
+ (cond
+ [(or (= c (char "/"))
+ (and (= c (char "\\"))
+ (eq? 'windows (hash-ref (runtime-env) 'system-type))))
+ (dir-k p)]
+ [else
+ (define l (split-path p))
+ (if (or (and (not (car l))
+ (not (relative-path? p)))
+ (string=? (cdr l) ".")
+ (string=? (cdr l) ".."))
+ (dir-k p)
+ (dir-file-k l))])))
+
+(define (path-only p)
+ (split-file-path 'path-only p (lambda (d) d) (lambda (l) (or (car l) "."))))
+
+(define (file-name-from-path p)
+ (split-file-path 'file-name-from-path p (lambda (d) #f) (lambda (l) (cdr l))))
+
+(define (path->complete-path p)
+ (unless (path-string? p) (arg-error 'path->complete-path "path string" p))
+ (if (relative-path? p)
+ (build-path (hash-ref (runtime-env) 'dir) p)
+ p))
+
+(define (ls* dir)
+ (unless (path-string? dir) (arg-error 'ls* "path string" dir))
+ (map (lambda (p) (build-path dir p)) (ls dir)))
+
+(define (mkdir-p p)
+ (unless (path-string? p) (arg-error 'mkdir-p "path string" p))
+ (unless (directory-exists? p)
+ (let ([l (split-path p)])
+ (when (car l) (mkdir-p (car l)))
+ (mkdir p))))
+
+(define (rm* p)
+ (unless (path-string? p) (arg-error 'rm* "path string" p))
+ (define info (stat p #f))
+ (when info
+ (define type (hash-ref info 'type))
+ (cond
+ [(eq? type 'file) (rm p)]
+ [(eq? type 'link) (rm p)]
+ [else
+ (for-each (lambda (e)
+ (rm* (build-path p e)))
+ (ls p))
+ (rmdir p)])))
+
+(define (cp* src dest)
+ (unless (path-string? src) (arg-error 'cp* "path string" src))
+ (unless (path-string? dest) (arg-error 'cp* "path string" dest))
+ (define info (stat src #f))
+ (when info
+ (define type (hash-ref info 'type))
+ (cond
+ [(eq? type 'file) (cp src dest)]
+ [(eq? type 'link)
+ (when (stat dest #f) (rm dest))
+ (symlink (readlink src) dest)]
+ [else
+ (unless (directory-exists? dest) (mkdir dest))
+ (for-each (lambda (e)
+ (cp* (build-path src e) (build-path dest e)))
+ (ls src))])))
+
+(define :error (hash 'exists 'error))
+(define :truncate (hash 'exists 'truncate))
+(define :must-truncate (hash 'exists 'must-truncate))
+(define :append (hash 'exists 'append))
+(define :update (hash 'exists 'update))
+(define :can-update (hash 'exists 'can-update))
+
+(define (display v)
+ (fd-write (fd-open-output 'stdout) (~a v)))
+
+(define (displayln v)
+ (fd-write (fd-open-output 'stdout) (~a v "\n")))
+
+(define (file->string path)
+ (unless (path-string? path) (arg-error 'file->string "path string" path))
+ (define fd (fd-open-input path))
+ (define content (fd-read fd eof))
+ (fd-close fd)
+ content)
+
+(define (display-to-file str path [options (hash)])
+ (unless (string? str) (arg-error 'display-to-file "string" str))
+ (unless (path-string? path) (arg-error 'display-to-file "path string" path))
+ (define fd (fd-open-output path options))
+ (fd-write fd str)
+ (fd-close fd))
+
+(define (string<? a b)
+ (unless (string? a) (arg-error 'string<? "string" a))
+ (unless (string? b) (arg-error 'string<? "string" b))
+ (let string<? ([i 0])
+ (cond
+ [(= i (string-length a)) (< i (string-length b))]
+ [(= i (string-length b)) #t]
+ [(< (string-ref a i) (string-ref b i)) #t]
+ [(> (string-ref a i) (string-ref b i)) #f]
+ [else (string<? (+ i 1))])))
+
+(define (string->integer s)
+ (unless (string? s) (arg-error 'string->integer "string" s))
+ (let ([len (string-length s)])
+ (and (not (= len 0))
+ (let ([neg? (= (string-ref s 0) (char "-"))])
+ (and (not (and neg? (= len 1)))
+ (let string->integer ([n 0] [i (if neg? 1 0)])
+ (cond
+ [(= i (string-length s))
+ (if neg? (- n) n)]
+ [else
+ (let ([c (string-ref s i)])
+ (cond
+ [(and (>= c 48) (<= c 57))
+ (let ([n (+ (* n 10) (- c 48))])
+ (if (< n 0)
+ ;; overflow has one edge care where it's ok
+ (and neg? (= (+ i 1) (string-length s)) (= n -9223372036854775808) n)
+ (string->integer n (+ i 1))))]
+ [else #f]))])))))))
+
+(define (string-join strs [sep " "])
+ (unless (and (list? strs) (andmap string? strs))
+ (arg-error 'string-join "list of strings" strs))
+ (unless (string? sep) (arg-error 'string-join "string" strs))
+ (apply ~a (let loop ([strs strs])
+ (cond
+ [(null? strs) '()]
+ [(null? (cdr strs)) strs]
+ [else (list* (car strs) sep (loop (cdr strs)))]))))
+
+(define (string-trim str [sep-str " "])
+ (unless (string? str) (arg-error 'string-trim "string" str))
+ (unless (and (string? sep-str) (> (string-length sep-str) 0))
+ (arg-error 'string-trim "nonempty string" sep-str))
+ (let* ([len (string-length str)]
+ [sep-len (string-length sep-str)]
+ [match-at? (lambda (i)
+ (and (= (string-ref str i) (string-ref sep-str 0))
+ (string=? (substring str i (+ i sep-len)) sep-str)))])
+ (if (< len sep-len)
+ str
+ (let ([start (let loop ([i 0])
+ (cond
+ [(> i (- len sep-len)) i]
+ [(match-at? i) (loop (+ i sep-len))]
+ [else i]))]
+ [end (let loop ([i len])
+ (cond
+ [(< i sep-len) i]
+ [(match-at? (- i sep-len)) (loop (- i sep-len))]
+ [else i]))])
+ (if (> end start)
+ (substring str start end)
+ "")))))
+
+(define (find-executable-path exe)
+ (unless (path-string? exe) (arg-error 'find-executable-path "path string" exe))
+ (define windows? (eq? (hash-ref (runtime-env) 'system-type) 'windows))
+ (define (try-exe p)
+ (or (and (file-exists? p) p)
+ (and windows?
+ (let ([p (~a p ".exe")])
+ (and (file-exists? p) p)))))
+ (cond
+ [(and (relative-path? exe)
+ (not (car (split-path exe))))
+ (define PATH (ormap (lambda (p)
+ (and ((if windows? string-ci=? string=?) (car p) "PATH")
+ (cdr p)))
+ (hash-ref (runtime-env) 'env '())))
+ (and PATH
+ (ormap (lambda (dir)
+ (and (path-string? dir)
+ (try-exe (build-path dir exe))))
+ (cons (hash-ref (runtime-env) 'dir)
+ (string-split PATH (if windows? ";" ":")))))]
+ [else (try-exe exe)]))
+
+(define (system-type)
+ (hash-ref (runtime-env) 'system-type))
--- /dev/null
+++ b/lib/zuo/private/pair.zuo
@@ -1,0 +1,50 @@
+#lang zuo/private/base
+
+;; This module could be implemented in either `base` or
+;; `base-hygienic`, but use use `base` to keep it faster
+;; (at least for `base`-only programs)
+
+(provide caar
+ cadr
+ cdar
+ cddr)
+
+(define bad
+ (lambda (who v)
+ (error (~a who ": not a valid argument") v)))
+
+(define caar
+ (lambda (v)
+ (if (pair? v)
+ (let ([a (car v)])
+ (if (pair? a)
+ (car a)
+ (bad 'caar v)))
+ (bad 'caar v))))
+
+(define cadr
+ (lambda (v)
+ (if (pair? v)
+ (let ([d (cdr v)])
+ (if (pair? d)
+ (car d)
+ (bad 'cadr v)))
+ (bad 'cadr v))))
+
+(define cdar
+ (lambda (v)
+ (if (pair? v)
+ (let ([a (car v)])
+ (if (pair? a)
+ (cdr a)
+ (bad 'cdar v)))
+ (bad 'cdar v))))
+
+(define cddr
+ (lambda (v)
+ (if (pair? v)
+ (let ([d (cdr v)])
+ (if (pair? d)
+ (cdr d)
+ (bad 'cddr v)))
+ (bad 'cddr v))))
--- /dev/null
+++ b/lib/zuo/private/stitcher.zuo
@@ -1,0 +1,269 @@
+#lang zuo/private/looper
+
+;; A module in the `zuo/private/stitcher` language is a sequence of
+;; `define`s followed by a `hash` construction. Each `define` is like
+;; a `let*` clause in that it can only directly refer to earlier
+;; definitions.
+
+;; An `include` form is allowed at the same level as `define`s to
+;; substitute the S-expression content of a module that is implemented
+;; in the `zuo/datum` language.
+
+;; Grammar for the right-hand side of a definition:
+;;
+;; <expr> = <id>
+;; | <literal>
+;; | (quote <datum>)
+;; | (lambda <formals> <expr> ...+)
+;; | (let ([<id> <expr>] ...) <expr> ...+)
+;; | (let* ([<id> <expr>] ...) <expr> ...+)
+;; | (letrec ([<id> <expr>]) <expr> ...+) ; note: single <id>
+;; | (cond [<expr> <expr> ...+] ...) ; `else` ok as last
+;; | (if <expr> <expr> <expr>)
+;; | (and <expr> ...)
+;; | (or <expr> ...)
+;; | (when <expr> <expr> ...+)
+;; | (unless <expr> <expr> ...+)
+;; | (begin <expr> ...+)
+
+;; Like `zuo/kernel`, syntactic forms in the stitcher language are
+;; still referenced by "keyword" in the sense that the names cannot be
+;; shadowed.
+
+;; Definitions are evaluated one at a time, and defined values are
+;; inlined in place of references later in the module. So, this is
+;; something like top-level evaluation, and something like partial
+;; evaluation. Free identifiers are detected and rejected before each
+;; definition is evaluated.
+
+(let* ([bad-syntax (lambda (s)
+ (error (~a (car s) ": bad stitcher syntax: " (~s s))))]
+ [maybe-begin (lambda (l)
+ (if (null? (cdr l))
+ (car l)
+ (cons 'begin l)))]
+ [ok-binding-clause? (lambda (l)
+ (if (list? l)
+ (if (= (length l) 2)
+ (symbol? (car l))
+ #f)
+ #f))]
+ [local (string->uninterned-symbol "local")]
+ [cons-path (letrec ([cons-path (lambda (l path)
+ (if (null? l)
+ '()
+ (cons (cons (car l) path)
+ (cons-path (cdr l) path))))])
+ cons-path)])
+ (letrec ([compile
+ (lambda (s env maybe-name)
+ (let ([recur (lambda (e) (compile e env #f))])
+ (cond
+ [(list? s)
+ (cond
+ [(eq? (car s) 'quote)
+ (if (= 2 (length s))
+ s
+ (bad-syntax s))]
+ [(eq? (car s) 'lambda)
+ (if (>= (length s) 3)
+ (let ([keep-names? #t])
+ (let ([args (car (cdr s))])
+ (letrec ([extend-env (lambda (args env)
+ (cond
+ [(null? args) env]
+ [(symbol? args) (hash-set env args local)]
+ [(pair? args) (extend-env (cdr args)
+ (hash-set env (car args) local))]
+ [else (bad-syntax s)]))])
+ (let ([env (extend-env args env)])
+ (let ([body (compile (maybe-begin (cdr (cdr s))) env #f)])
+ (if (if keep-names? maybe-name #f)
+ (let ([name (symbol->string maybe-name)])
+ (list 'lambda args name body))
+ (list 'lambda args body)))))))
+ (bad-syntax s))]
+ [(eq? (car s) 'letrec) ; still restricted to a single binding
+ (if (>= (length s) 3)
+ (let ([clauses (car (cdr s))])
+ (if (if (list? clauses)
+ (if (= 1 (length clauses))
+ (ok-binding-clause? (car clauses))
+ #f)
+ #f)
+ (let ([id (car (car clauses))])
+ (let ([env (hash-set env id local)])
+ (list 'letrec (list (list id
+ (compile (car (cdr (car clauses))) env #f)))
+ (compile (maybe-begin (cdr (cdr s))) env maybe-name))))
+ (bad-syntax s)))
+ (bad-syntax s))]
+ [(eq? (car s) 'let)
+ (if (>= (length s) 3)
+ (letrec ([compile-clauses
+ (lambda (clauses body-env)
+ (cond
+ [(null? clauses)
+ (compile (maybe-begin (cdr (cdr s))) body-env maybe-name)]
+ [(pair? clauses)
+ (let ([clause (car clauses)])
+ (if (ok-binding-clause? clause)
+ (let ([id (car clause)])
+ (list 'let
+ (list (list id (compile (car (cdr clause)) env id)))
+ (compile-clauses (cdr clauses) (hash-set body-env id local))))
+ (bad-syntax s)))]
+ [else (bad-syntax s)]))])
+ (compile-clauses (car (cdr s)) env))
+ (bad-syntax s))]
+ [(eq? (car s) 'let*)
+ (if (>= (length s) 3)
+ (letrec ([expand-let* (lambda (clauses env)
+ (cond
+ [(null? clauses)
+ (compile (maybe-begin (cdr (cdr s))) env maybe-name)]
+ [(pair? clauses)
+ (let ([clause (car clauses)])
+ (if (ok-binding-clause? clause)
+ (let ([id (car clause)])
+ (list 'let
+ (list (list id (compile (car (cdr clause)) env id)))
+ (expand-let* (cdr clauses) (hash-set env id local))))
+ (bad-syntax s)))]
+ [else (bad-syntax s)]))])
+ (expand-let* (car (cdr s)) env))
+ (bad-syntax s))]
+ [(eq? (car s) 'or)
+ (letrec ([expand-or (lambda (l)
+ (cond
+ [(null? l) #f]
+ [(null? (cdr l)) (recur (car l))]
+ [else
+ (let ([tmp (string->uninterned-symbol "ortmp")])
+ (list 'let
+ (list (list tmp (recur (car l))))
+ (list 'if
+ tmp
+ tmp
+ (expand-or (cdr l)))))]))])
+ (expand-or (cdr s)))]
+ [(eq? (car s) 'and)
+ (letrec ([expand-and (lambda (l)
+ (cond
+ [(null? l) #t]
+ [(null? (cdr l)) (recur (car l))]
+ [else (list 'if
+ (recur (car l))
+ (expand-and (cdr l))
+ #f)]))])
+ (expand-and (cdr s)))]
+ [(eq? (car s) 'cond)
+ (letrec ([expand-cond (lambda (l)
+ (cond
+ [(null? l) (void)]
+ [(if (list? (car l))
+ (>= (length (car l)) 2)
+ #f)
+ (let ([lhs (car (car l))])
+ (let ([rhs (maybe-begin (cdr (car l)))])
+ (cond
+ [(eq? lhs 'else)
+ (if (null? (cdr l))
+ (recur rhs)
+ (bad-syntax s))]
+ [else (list 'if
+ (recur lhs)
+ (recur (maybe-begin (cdr (car l))))
+ (expand-cond (cdr l)))])))]
+ [else (bad-syntax s)]))])
+ (expand-cond (cdr s)))]
+ [(eq? (car s) 'when)
+ (if (>= (length s) 2)
+ (list 'if
+ (recur (car (cdr s)))
+ (recur (maybe-begin (cdr (cdr s))))
+ '(void))
+ (bad-syntax s))]
+ [(eq? (car s) 'unless)
+ (if (>= (length s) 2)
+ (list 'if
+ (recur (car (cdr s)))
+ '(void)
+ (recur (maybe-begin (cdr (cdr s)))))
+ (bad-syntax s))]
+ [(eq? (car s) 'if)
+ (if (= (length s) 4)
+ (list 'if
+ (recur (car (cdr s)))
+ (recur (car (cdr (cdr s))))
+ (recur (car (cdr (cdr (cdr s))))))
+ (bad-syntax s))]
+ [(if (eq? (car s) 'hash) (null? (cdr s)) #f) ; ad hoc optimization
+ (hash)]
+ [(if (eq? (car s) 'void) (null? (cdr s)) #f) ; ad hoc optimization
+ (void)]
+ [else (letrec ([do-app (lambda (s)
+ (if (null? s)
+ '()
+ (cons (recur (car s))
+ (do-app (cdr s)))))])
+ (if (eq? (car s) 'begin)
+ (cons 'begin (do-app (cdr s)))
+ (do-app s)))])]
+ [(pair? s) (error (~a "bad stitcher syntax: " (~s s)))]
+ [(symbol? s)
+ (let ([v (hash-ref env s env)]) ; using `env` as a "not there" value
+ (cond
+ [(eq? v env) (error (~a "unbound variable in stitcher: " (~s s)))]
+ [(eq? v local) s]
+ [(symbol? v) (list 'quote v)]
+ [(pair? v) (list 'quote v)]
+ [else v]))]
+ [else s])))])
+ (hash 'read-and-eval
+ (lambda (str start mod-path)
+ (let ([es (string-read str start mod-path)])
+ (letrec ([stitch
+ (lambda (es env)
+ (cond
+ [(null? es) (error "stitcher module did not end with hash")]
+ [else
+ (let* ([e+path (car es)]
+ [e (car e+path)]
+ [a (if (pair? e) (car e) #f)])
+ (cond
+ [(eq? a 'hash)
+ (if (null? (cdr es))
+ (looper-eval (compile e env #f))
+ (error (~a "stitcher hash is not last: " (~s e))))]
+ [(eq? a 'define)
+ (let ([lhs (if (>= (length e) 3)
+ (car (cdr e))
+ #f)])
+ (cond
+ [(symbol? lhs)
+ (if (= (length e) 3)
+ (let ([v (looper-eval (compile (car (cdr (cdr e))) env lhs))])
+ (stitch (cdr es) (hash-set env lhs v)))
+ (bad-syntax e))]
+ [(pair? lhs)
+ (let ([id (car lhs)])
+ (if (symbol? id)
+ (let ([v (looper-eval (compile (cons 'lambda (cons (cdr lhs) (cdr (cdr e)))) env id))])
+ (stitch (cdr es) (hash-set env id v)))
+ (bad-syntax e)))]
+ [else (bad-syntax e)]))]
+ [(eq? a 'include)
+ (if (= 2 (length e))
+ (let* ([name (car (cdr e))]
+ [mod-path (cdr e+path)]
+ [mod-path (build-module-path mod-path name)]
+ [mod (module->hash mod-path)])
+ (let ([inc-es (hash-ref mod 'datums #f)])
+ (if inc-es
+ (stitch (append (cons-path inc-es mod-path) (cdr es)) env)
+ (error "not stitcher-includable module" name))))
+ (bad-syntax e))]
+ [else
+ (error (~a "stitcher definition or include expected: " (~s e)))]))]))])
+ (stitch (cons-path es mod-path) (kernel-env))))))))
--- /dev/null
+++ b/lib/zuo/shell.zuo
@@ -1,0 +1,69 @@
+#lang zuo/base
+(require "thread.zuo")
+
+(provide shell
+ shell/wait
+ build-shell)
+
+(define (shell arg . args)
+ (call-with-command
+ 'shell
+ (cons arg args)
+ (lambda (command options)
+ (cond
+ [(eq? (hash-ref (runtime-env) 'system-type) 'unix)
+ (process "/bin/sh" "-c" command options)]
+ [else
+ (let ([cmd (build-path (hash-ref (runtime-env) 'sys-dir) "cmd.exe")])
+ (process cmd (~a cmd " /c \"" command "\"") (hash-set options 'exact? #t)))]))))
+
+(define (shell/wait arg . args)
+ (call-with-command
+ 'shell/wait
+ (cons arg args)
+ (lambda (command options)
+ (unless (hash-ref options 'quiet? #f)
+ (displayln (let ([dir (hash-ref options 'dir #f)])
+ (if dir
+ (~a "cd " (string->shell dir) " && " command)
+ command))))
+ (define p (shell command (hash-remove (hash-remove
+ (hash-remove options 'quiet?)
+ 'no-thread?)
+ 'desc)))
+ (if (hash-ref options 'no-thread? #f)
+ (process-wait (hash-ref p 'process))
+ (thread-process-wait (hash-ref p 'process)))
+ (unless (= 0 (process-status (hash-ref p 'process)))
+ (error (~a (hash-ref options 'desc "shell command") " failed"))))))
+
+(define (call-with-command who args k)
+ (let loop ([args args] [accum '()])
+ (cond
+ [(null? args)
+ (k (do-build-shell who (reverse accum))
+ (hash))]
+ [(and (hash? (car args))
+ (null? (cdr args))
+ (pair? accum))
+ (k (do-build-shell who (reverse accum))
+ (car args))]
+ [else
+ (loop (cdr args) (cons (car args) accum))])))
+
+(define (build-shell . strs)
+ (do-build-shell 'build-sehll strs))
+
+(define (do-build-shell who . strs)
+ (let ([strs (let loop ([strs strs])
+ (cond
+ [(null? strs) '()]
+ [else
+ (let ([a (car strs)])
+ (cond
+ [(string? a) (if (string=? a "")
+ (loop (cdr strs))
+ (cons a (loop (cdr strs))))]
+ [(list? a) (loop (append a (cdr strs)))]
+ [else (arg-error who "string or list" a)]))]))])
+ (string-join strs)))
--- /dev/null
+++ b/lib/zuo/thread.zuo
@@ -1,0 +1,199 @@
+#lang zuo/base
+
+(provide call-in-main-thread
+ (rename-out
+ [make-thread thread]
+ [make-channel channel])
+ thread?
+ channel?
+ channel-put
+ channel-get
+ thread-process-wait)
+
+(struct thread (id))
+
+(struct channel (id))
+(struct ch (hd tl w-hd w-tl)) ; channel state: queues of values and waiters
+
+;; a `state` represents the state of the thread scheduler, such as
+;; enqeued threads and channel contentl from a client perspective,
+;; channels offer a form of state among communicating threadsl this
+;; state is implemented through delimited continuations (i.e., in the
+;; style of effect handlers)
+(struct state (hd ; list of thunks
+ tl ; list of thunks
+ channels ; channel-id -> channel
+ processes)) ; list of (cons (list handle ...) k)
+
+;; state requests from threads, distinct from anything else a thread
+;; might return:
+(struct state-get-msg (k))
+(struct state-put-msg (state k))
+
+(define thread-tag (string->uninterned-symbol "thread"))
+(define (check-in-thread who)
+ (unless (continuation-prompt-available? thread-tag)
+ (error (~a who ": not in a thread context"))))
+
+;; a request is issued by discarding the current continuation
+(define empty-k (call/prompt (lambda () (call/cc (lambda (k) k))) thread-tag))
+
+;; runs thunk as a thread in a new scheduler; any created threads or
+;; channels are specific to the scheduler; returns the result of the
+;; main thread when no threads can run; waits on processes only if
+;; there's nothing else to do
+(define (call-in-main-thread thunk)
+ (raw-make-channel ; make a channel to hold the main thread's result
+ (state '() '() (hash) '())
+ (lambda (chl st)
+ ;; for the scheduler loop, it's convenient to break out the head
+ ;; thunk of the thread queue, which starts out as being the main
+ ;; thread's thunk
+ (let loop ([st st] [hd-thunk (lambda () (channel-put chl (thunk)))])
+ (cond
+ [hd-thunk
+ (let ([v (call/prompt hd-thunk thread-tag)])
+ ;; the thread either made a state request or has terminated
+ (cond
+ [(state-get-msg? v)
+ (loop st (lambda () ((state-get-msg-k v) st)))]
+ [(state-put-msg? v)
+ (loop (state-put-msg-state v) (lambda () ((state-put-msg-k v) (void))))]
+ [else (loop st #f)]))]
+ [(pair? (state-hd st))
+ (loop (state-set-hd st (cdr (state-hd st))) (car (state-hd st)))]
+ [(pair? (state-tl st))
+ (loop (state-set-hd (state-set-tl st '()) (reverse (state-tl st))) #f)]
+ [(pair? (state-processes st))
+ (let* ([ps+ks (state-processes st)]
+ [p (apply process-wait (apply append (map car ps+ks)))]
+ [ps+k (ormap (lambda (ps+k) (and (member p (car ps+k)) ps+k))
+ ps+ks)]
+ [st (state-set-processes st (filter (lambda (e) (not (eq? e ps+k)))
+ ps+ks))])
+ (loop st (lambda () ((cdr ps+k) p))))]
+ [else
+ (raw-channel-get st chl
+ (lambda (v st) v)
+ (lambda (st)
+ (error "call-in-thread: main thread is stuck")))])))))
+
+(define (enqueue-thread st thunk)
+ (state-set-tl st (cons thunk (state-tl st))))
+
+(define (raw-make-channel st k)
+ (let ([id (string->uninterned-symbol "ch")])
+ (k (channel id)
+ (state-set-channels st (hash-set (state-channels st)
+ id
+ (ch '() '() '() '()))))))
+
+;; gets or sets the state
+(define (current-state . st)
+ (cond
+ [(null? st)
+ (call/cc
+ (lambda (k)
+ (empty-k (state-get-msg k))))]
+ [(null? (cdr st))
+ (call/cc
+ (lambda (k)
+ (empty-k (state-put-msg (car st) k))))]
+ [else (arity-error 'current-state st)]))
+
+;; suspends the current thread; it must have been enqueued with
+;; a process or channel if it's going to be resumed
+(define (yield)
+ (empty-k (void)))
+
+(define make-thread
+ (let ([thread
+ (lambda (thunk)
+ (unless (procedure? thunk)
+ (arg-error 'thread "procedure" thunk))
+ (check-in-thread 'thread)
+ (define th (thread (string->uninterned-symbol "thread")))
+ (let ([st (current-state)])
+ (current-state (enqueue-thread st (lambda () (thunk)))))
+ th)])
+ thread))
+
+(define make-channel
+ (let ([channel
+ (lambda ()
+ (check-in-thread 'channel)
+ (raw-make-channel
+ (current-state)
+ (lambda (ch st)
+ (current-state st)
+ ch)))])
+ channel))
+
+(define (channel-put chl v)
+ (unless (channel? chl) (arg-error 'channel-put "channel" chl))
+ (check-in-thread 'channel-put)
+ (let* ([st (current-state)]
+ [chs (state-channels (current-state))]
+ [ch (hash-ref chs (channel-id chl) #f)])
+ (unless ch (error "channel-put: does not belong to the running thread group" ch))
+ (define (update-ch st ch) (state-set-channels st (hash-set chs (channel-id chl) ch)))
+ (let loop ([ch ch])
+ (let ([w-hd (ch-w-hd ch)])
+ (cond
+ [(pair? w-hd)
+ (let ([waiter (car (ch-w-hd ch))]
+ [ch (ch-set-w-hd ch (cdr (ch-w-hd ch)))])
+ (let* ([st (update-ch st ch)])
+ (current-state (enqueue-thread st (lambda () (waiter v))))
+ (void)))]
+ [else
+ (let* ([w-tl (ch-w-tl ch)])
+ (cond
+ [(null? w-tl)
+ (current-state (update-ch st (ch-set-tl ch (cons v (ch-tl ch)))))
+ (void)]
+ [else
+ (loop (ch-set-w-tl (ch-set-w-hd ch (reverse w-tl)) '()))]))])))))
+
+(define (raw-channel-get st chl k yield-k)
+ (let* ([chs (state-channels st)]
+ [ch (hash-ref chs (channel-id chl) #f)])
+ (unless ch (error "channel-get: does not belong to the running thread group" ch))
+ (define (update-ch st ch) (state-set-channels st (hash-set chs (channel-id chl) ch)))
+ (let loop ([ch ch])
+ (let ([hd (ch-hd ch)])
+ (cond
+ [(pair? hd)
+ (k (car hd)
+ (update-ch st (ch-set-hd ch (cdr hd))))]
+ [else
+ (let* ([tl (ch-tl ch)])
+ (cond
+ [(null? tl)
+ (call/cc
+ (lambda (k)
+ (yield-k (update-ch st (ch-set-w-tl ch (cons k (ch-w-tl ch)))))))]
+ [else
+ (loop (ch-set-tl (ch-set-hd ch (reverse tl)) '()))]))])))))
+
+(define (channel-get chl)
+ (unless (channel? chl) (arg-error 'channel-get "channel" chl))
+ (check-in-thread 'channel-get)
+ (raw-channel-get (current-state) chl
+ (lambda (v st)
+ (current-state st)
+ v)
+ (lambda (st)
+ (current-state st)
+ (yield))))
+
+(define (thread-process-wait p . ps)
+ (for-each (lambda (p)
+ (unless (handle? p) (arg-error 'thread-process-wait "handle" p)))
+ (cons p ps))
+ (check-in-thread 'thread-process-wait)
+ (call/cc
+ (lambda (k)
+ (let ([st (current-state)])
+ (current-state (state-set-processes st (cons (cons (cons p ps) k) (state-processes st))))
+ (yield)))))
--- /dev/null
+++ b/local/hello.zuo
@@ -1,0 +1,9 @@
+#lang zuo
+
+"Hello, world!"
+
+;; If you don't want the quotes:
+;; (alert "Hello, world!")
+
+;; If you don't want it in blue:
+;; (displayln "Hello, world!")
--- /dev/null
+++ b/local/image.zuo
@@ -1,0 +1,168 @@
+#lang zuo
+
+;; This module works in three modes:
+;; * as a library to provide `embed-image`
+;; - that's the `embed-image` provided function, obviously
+;; * as a script that parses command-line arguments to drive `embed-image`
+;; - that's the `(module+ main ...)` below
+;; * as a build component that provides a target to drive `embed-image`
+;; - that's the `image-target` provided function, which takes
+;; the same hash-table specification as `embed-image`, but returns a
+;; target instead of immediately generating output
+
+(provide embed-image ; hash? -> void?
+ image-target) ; hash? -> target?
+
+;; `embed-image` recognizes the following keys in its argument:
+;;
+;; * 'output : #f or destination path string; #f (default) means to stdout
+;;
+;; * 'libs: list of module-path symbols; default is '(zuo)
+;;
+;; * 'deps: a file to record files reda to create the image; presence
+;; along with non-#f 'output enables a potetial 'up-to-date result
+;;
+;; * 'keep-collects?: boolean for whether to keep the collection library
+;; path enabled; default is #f
+
+(module+ main
+ (define cmd
+ (command-line
+ :once-each
+ [cmd "-o" file "Output to <file> instead of stdout"
+ (hash-set cmd 'output file)]
+ :multi
+ [cmd "++lib" module-path "Embed <module-path> and its dependencies"
+ (hash-set cmd 'libs (cons (string->symbol module-path)
+ (hash-ref cmd 'libs '())))]
+ :once-each
+ [cmd "--deps" file "Write dependencies to <file>"
+ (hash-set cmd 'deps file)]
+ [cmd "--keep-collects" "Keep library collection path enabled"
+ (hash-set cmd 'keep-collects? #t)]))
+ (embed-image cmd))
+
+(define (image-target cmd)
+ (target
+ (hash-ref cmd 'output) ; the output file; `target` uses SHA-1 on this
+ (lambda (path token)
+ ;; when a target is demanded, we report dependencies and more via `rule`
+ (rule
+ ;; dependencies:
+ (list (at-source ".." "zuo.c") ; original "zuo.c" that is converted to embed libraries
+ (quote-module-path) ; this script
+ (input-data-target 'config (hash-remove cmd 'output))) ; configuration
+ ;; rebuild function (called if the output file is out of date):
+ (lambda ()
+ ;; get `embed-image` to tell us which module files it used:
+ (define deps-file (path-replace-extension path ".dep"))
+ ;; generated the output file
+ (embed-image (let* ([cmd (hash-set cmd 'output path)]
+ [cmd (hash-set cmd 'deps deps-file)])
+ cmd))
+ ;; register each source module as a discovered dependency:
+ (for-each (lambda (p) (build/dep p token))
+ (string-read (file->string deps-file) 0 deps-file)))))))
+
+(define (embed-image cmd)
+ (define given-libs (hash-ref cmd 'libs '()))
+ (define libs (if (null? given-libs)
+ '(zuo)
+ given-libs))
+
+ (define deps-file (hash-ref cmd 'deps #f))
+ (define c-file (hash-ref cmd 'output #f))
+
+ (when c-file
+ (displayln (~a "generating " c-file " embedding these libraries: " (string-join (map ~s libs)))))
+ (when deps-file
+ (display-to-file "" deps-file :truncate))
+
+ (define deps-h (and deps-file (cleanable-file deps-file)))
+
+ (define image
+ (let ([ht (apply process
+ (append
+ (list (hash-ref (runtime-env) 'exe))
+ (if deps-file
+ (list "-M" deps-file)
+ (list))
+ (list "" (hash 'stdin 'pipe 'stdout 'pipe))))])
+ (define p (hash-ref ht 'process))
+ (define in (hash-ref ht 'stdin))
+ (define out (hash-ref ht 'stdout))
+ (fd-write in "#lang zuo/kernel\n")
+ (fd-write in "(begin\n")
+ (for-each (lambda (lib)
+ (fd-write in (~a "(module->hash '" lib ")\n")))
+ libs)
+ (fd-write in "(dump-image-and-exit (fd-open-output 'stdout (hash))))\n")
+ (fd-close in)
+ (let ([image (fd-read out eof)])
+ (fd-close out)
+ (process-wait p)
+ (unless (= 0 (process-status p))
+ (error "image dump failed"))
+ image)))
+
+ (define zuo.c (fd-read (fd-open-input (at-source ".." "zuo.c")) eof))
+ (define out (if c-file
+ (fd-open-output c-file (hash 'exists 'truncate))
+ (fd-open-output 'stdout (hash))))
+
+ (define lines (let ([l (reverse (string-split zuo.c "\n"))])
+ ;; splitting on newlines should leave us with an empty last string
+ ;; that doesn't represent a line
+ (reverse (if (and (pair? l) (equal? "" (car l)))
+ (cdr l)
+ l))))
+
+ (define (~hex v)
+ (if (= v 0)
+ "0"
+ (let loop ([v v] [accum '()])
+ (if (= v 0)
+ (apply ~a accum)
+ (loop (quotient v 16)
+ (cons (let ([i (bitwise-and v 15)])
+ (substring "0123456789abcdef" i (+ i 1)))
+ accum))))))
+
+ (define embedded-image-line "#define EMBEDDED_IMAGE 0")
+ (define embedded-image-line/cr (~a embedded-image-line "\r"))
+
+ (for-each
+ (lambda (line)
+ (cond
+ [(or (string=? line embedded-image-line)
+ (string=? line embedded-image-line/cr))
+ (define nl (if (string=? line embedded-image-line/cr) "\r\n" "\n"))
+ (unless (hash-ref cmd 'keep-collects? #f)
+ (fd-write out (~a "#define ZUO_LIB_PATH NULL" nl)))
+ (fd-write out (~a "#define EMBEDDED_IMAGE 1" nl))
+ (fd-write out (~a "static zuo_uint32_t emedded_boot_image_len = "
+ (quotient (string-length image) 4)
+ ";" nl))
+ (fd-write out (~a "static zuo_uint32_t emedded_boot_image[] = {" nl))+ (let ([accum->line (lambda (accum) (apply ~a (reverse (cons nl accum))))])
+ (let loop ([i 0] [col 0] [accum '()])
+ (cond
+ [(= i (string-length image))
+ (unless (null? accum)
+ (fd-write out (accum->line accum)))]
+ [(= col 8)
+ (fd-write out (accum->line accum))
+ (loop i 0 '())]
+ [else
+ (loop (+ i 4) (+ col 1)
+ (cons (~a " 0x" (~hex (string-u32-ref image i)) ",")
+ accum))])))
+ (fd-write out (~a " 0 };" nl))]
+ [else
+ (fd-write out (~a line "\n"))]))
+ lines)
+
+ (when c-file (fd-close out))
+
+ (when deps-h
+ (cleanable-cancel deps-h)))
--- /dev/null
+++ b/local/repl.zuo
@@ -1,0 +1,29 @@
+#lang zuo
+
+;; Zuo is really not for interctive evaluation, but `kernel-eval` does
+;; exist...
+
+(alert "REPL for single-line kernel expressions:")
+(define in (fd-open-input 'stdin))
+(define out (fd-open-output 'stdout (hash)))
+(fd-write out "> ")
+(let loop ([pending ""])
+ (define line-end (let loop ([i 0])
+ (cond
+ [(= i (string-length pending)) #f]
+ [(= (string-ref pending i) (char "\n")) (+ i 1)]
+ [else (loop (+ i 1))])))
+ (define (read-and-eval s)
+ (for-each (lambda (e)
+ (alert (~v (kernel-eval e))))
+ (string-read s)))
+ (cond
+ [line-end
+ (read-and-eval (substring pending 0 line-end))
+ (fd-write out "> ")
+ (loop (substring pending line-end (string-length pending)))]
+ [else
+ (define input (fd-read in 1))
+ (if (eq? input eof)
+ (read-and-eval pending)
+ (loop (~a pending input)))]))
--- /dev/null
+++ b/local/tree.zuo
@@ -1,0 +1,78 @@
+#lang zuo
+
+;; This module implements a simple version of the `tree` program,
+;; which shows the content of a directory in tree form.
+
+;; Another script could use this `tree` function...
+(provide tree)
+
+;; ... but if this script is the main one passed to Zuo,
+;; then the `main` submodule is run, which parses command-line
+;; arguments and call `tree`.
+(module+ main
+ ;; Imitates Racket's `command-line` form, but we have to explicitly
+ ;; thread through `accum`, because there's no state
+ (command-line
+ :init (hash) ; initial accumulator (but `(hash)` is the default, anyway)
+ :once-each
+ ;; Each flag clause starts with the accumulator id
+ [accum ("-a") "Include names that start with `.`"+ (hash-set accum 'all? #t)]
+ [accum ("-h") "Show file sizes human-readable"+ (hash-set accum 'h-size? #t)]
+ :args ([dir "."])
+ (lambda (accum) ; args handler as procedure to receive the accumulator
+ (if (directory-exists? dir)
+ (tree dir
+ (hash-ref accum 'all? #f)
+ (hash-ref accum 'h-size? #f))
+ (error (~a (hash-ref (runtime-env) 'script)
+ ": no such directory: "
+ dir))))))
+
+;; Recur using `ls` to get a directory's content
+(define (tree dir show-all? show-size?)
+ (displayln dir)
+ (let tree ([dir dir] [depth 0])
+ (define elems (sort (ls dir) string<?))
+ (let in-dir ([elems (if show-all? elems (filter not-dot? elems))])
+ (unless (null? elems)
+ (define elem (car elems))
+ (define elem-path (build-path dir elem))
+ (define s (stat elem-path))
+
+ (let loop ([depth depth])
+ (unless (= depth 0)
+ (display "│ ")
+ (loop (- depth 1))))
+ (if (null? (cdr elems))
+ (display "└─ ")
+ (display "├─ "))
+
+ (when show-size?
+ (display (~a "[" (human-readable (hash-ref s 'size)) "] ")))
+ (displayln elem)
+
+ (when (eq? (hash-ref s 'type) 'dir)
+ (tree elem-path (+ depth 1)))
+ (in-dir (cdr elems))))))
+
+(define not-dot?
+ (let ([dot? (glob->matcher ".*")])
+ (lambda (s) (not (dot? s)))))
+
+;; Arithmetic is not Zuo's strong suit, since it supports only
+;; 64-bit signed integers
+(define (human-readable n)
+ (define (decimal n)
+ (define d (quotient 1024 10))
+ (define dec (quotient (+ (modulo n 1024) (quotient d 2)) d))
+ (~a (quotient n (* 1024)) "." dec))
+ (define s
+ (cond
+ [(< n 1024) (~a n)]
+ [(< n (quotient (* 1024 1024) 10)) (~a (decimal n) "K")]
+ [else (~a (decimal (quotient n 1024)) "M")]))
+ (if (< (string-length s) 4)
+ (~a (substring " " (string-length s)) s)
+ s))
--- /dev/null
+++ b/main.zuo
@@ -1,0 +1,22 @@
+#lang zuo
+
+(for-each
+ alert
+ (append
+ (list ""
+ "Welcome to Zuo!"
+ ""
+ "This message is from \"main.zuo\"."
+ ""
+ "Probably, you're seeing this message because you ran Zuo with no arguments,"
+ "in which case \"main.zuo\" in the current directory is loaded by default."
+ ""
+ "If you want to run your own program, supply the program's path as an argument."
+ "A program file will start with `#lang`, and most likely it starts `#lang zuo`."
+ "Additional arguments are made available to the target program through the"
+ "`command-line-arguments` procedure (in languages like `#lang zuo`, at least)."
+ ""
+ "If you want to type in a program directly, supply the empty string \"\" in"
+ "place of a file path. You'll still need to start the program with something"
+ "like `#lang zuo`."
+ "")))
--- /dev/null
+++ b/tests/c.zuo
@@ -1,0 +1,17 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "c")
+
+(check (config-merge (hash 'CFLAGS "-O2") 'CFLAGS "-g")
+ (hash 'CFLAGS "-O2 -g"))
+
+(check (config-define (hash 'CFLAGS "-O2") "ZUO")
+ (hash 'CFLAGS "-O2" 'CPPFLAGS "-DZUO"))
+
+(check (config-define (hash 'CPPFLAGS "-DSLOW") "ZUO")
+ (hash 'CPPFLAGS "-DSLOW -DZUO"))
+
+(check (config-include (hash 'CPPFLAGS "-DSLOW") "zuo/private")
+ (hash 'CPPFLAGS "-DSLOW -Izuo/private"))
--- /dev/null
+++ b/tests/cleanable.zuo
@@ -1,0 +1,82 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "cleanables")
+
+(define adios-file (build-path tmp-dir "adios.txt"))
+
+(define (check-cleaned pre post expect-status expect-exist?)
+ (run-zuo* '("")+ (~a "#lang zuo\n"
+ (~s
+ `(begin
+ ,@pre
+ (define cl (cleanable-file ,adios-file))
+ ,@post)))
+ (lambda (status out err)
+ (check status expect-status)))
+ (check (file-exists? adios-file) expect-exist?))
+
+(fd-close (fd-open-output adios-file :truncate))
+(check-cleaned '()
+ '()
+ 0
+ #f)
+(check-cleaned `((void (fd-open-output ,adios-file :truncate)))
+ '()
+ 0
+ #f)
+(check-cleaned `((void (fd-open-output ,adios-file :truncate)))
+ '((car '()))
+ 1
+ #f)
+(check-cleaned `((void (fd-open-output ,adios-file :truncate)))
+ '((cleanable-cancel cl))
+ 0
+ #t)
+
+;; check that a process doesn't exit before a subprocess,
+;; even when it doesn't explicitly wait, or that it does exit
+;; in no-wait mode
+(define (check-sub no-wait?)
+ (define sub.zuo (build-path tmp-dir "sub.zuo"))
+ (define inner.zuo (build-path tmp-dir "inner.zuo"))
+ (let ([o (fd-open-output sub.zuo :truncate)])
+ (fd-write o (~a "#lang zuo\n"
+ (~s `(void (process (hash-ref (runtime-env) 'exe)
+ ,inner.zuo
+ ,(if no-wait?
+ '(hash 'cleanable? #f)
+ '(hash)))))))
+ (fd-close o))
+ (let ([o (fd-open-output inner.zuo :truncate)])
+ (fd-write o (~a "#lang zuo\n"
+ (~s `(let ([in (fd-open-input 'stdin)]
+ [out (fd-open-output 'stdout)])
+ (define s (fd-read in 1))
+ (fd-write out s)
+ (fd-read in 1)))))
+ (fd-close o))
+ (define p (process (hash-ref (runtime-env) 'exe)
+ sub.zuo
+ (hash 'stdin 'pipe 'stdout 'pipe)))
+ (define to (hash-ref p 'stdin))
+ (define from (hash-ref p 'stdout))
+ (cond
+ [no-wait? (process-wait (hash-ref p 'process))]
+ [else (check (process-status (hash-ref p 'process)) 'running)])
+ (fd-write to "x")
+ (check (fd-read from 1) "x")
+ (unless no-wait?
+ (check (process-status (hash-ref p 'process)) 'running))
+ (fd-write to "y")
+ (process-wait (hash-ref p 'process))
+ (check (process-status (hash-ref p 'process)) 0))
+
+(check-sub #f)
+(check-sub #f)
+(check-sub #t)
+
+(check-arg-fail (cleanable-file 10) not-path)
+(check-arg-fail (cleanable-cancel 10) "cleanable handle")
--- /dev/null
+++ b/tests/cycle.zuo
@@ -1,0 +1,21 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "cycle")
+
+(define cycle-file (build-path tmp-dir "cycle.zuo"))
+
+(define out (fd-open-output cycle-file :truncate))
+(fd-write out (~a "#lang zuo\n"
+ "(require \"cycle.zuo\")\n"))
+(fd-close out)
+
+(check (run-zuo `(require ,(if (relative-path? cycle-file)
+ (build-path (hash-ref (runtime-env) 'dir) cycle-file)
+ cycle-file))
+ (lambda (status out err)
+ (and (not (= status 0))
+ (equal? out "")
+ (contains? err "cycle in module loading")))))
+
--- /dev/null
+++ b/tests/equal.zuo
@@ -1,0 +1,53 @@
+#lang zuo
+
+(require "harness.zuo")
+
+;; We need certain things to work for checking even to work, but all
+;; we can do is assume that things work...
+
+(alert "equal")
+
+(check #t)
+(check (not #f))
+(check (eq? 'apple 'apple))
+(check (not (eq? 'apple 'banana)))
+(check (not (eq? 'apple "apple")))
+
+(check (string=? "apple" "apple"))
+(check (not (string=? "apple" "banana")))
+(check (string-ci=? "apple" "aPPle"))
+(check (not (string-ci=? "apple" "banana")))
+
+(check (= 1 1))
+(check (not (= 1 -1)))
+
+(check (equal? 1 1))
+(check (equal? "apple" "apple"))
+
+(check (equal? "apple" "apple"))
+(check (equal? '("apple") '("apple")))+(check (equal? '(0 "apple") '(0 "apple")))
+(check (not (equal? '("apple") '("banana"))))+(check (not (equal? '(0 "apple") '(0 "banana"))))
+
+(check (equal? (hash 'a 1) (hash 'a 1)))
+(check (not (equal? (hash 'a 1) (hash 'b 1))))
+(check (not (equal? (hash 'a 1) (hash 'a 2))))
+
+(check (not (equal? "apple" 'other)))
+(check (not (equal? 'other "apple")))
+(check (not (equal? 1 'other)))
+(check (not (equal? 'other 1)))
+(check (not (equal? 1 (hash 'a 1))))
+(check (not (equal? (hash 'a 1) 1)))
+
+(check-fail (= 1 'apple) not-integer)
+(check-fail (= 'apple 1) not-integer)
+(check-arg-fail (string=? 1 "apple") not-string)
+(check-arg-fail (string=? "apple" 1) not-string)
+(check-arg-fail (string-ci=? 1 "apple") not-string)
+(check-arg-fail (string-ci=? "apple" 1) not-string)
+
+(check (eq? (void) (void)))
+(check (void? (void)))
+(check (not (void? 'void)))
--- /dev/null
+++ b/tests/example-common.zuo
@@ -1,0 +1,923 @@
+#lang zuo/datum
+
+;; This is an early version of the macro expander, preserved here
+;; as a large-ish example that's useful to check how long expansion takes.
+
+(let* ([caar (lambda (p) (car (car p)))]
+ [cadr (lambda (p) (car (cdr p)))]
+ [cdar (lambda (p) (cdr (car p)))]
+ [cddr (lambda (p) (cdr (cdr p)))]
+
+ [map (lambda (f vs)
+ (letrec ([map (lambda (vs)
+ (if (null? vs)
+ '()
+ (cons (f (car vs)) (map (cdr vs)))))])
+ (map vs)))]
+ [map2 (lambda (f vs v2s)
+ (letrec ([map (lambda (vs v2s)
+ (if (null? vs)
+ '()
+ (cons (f (car vs) (car v2s))
+ (map (cdr vs) (cdr v2s)))))])
+ (map vs v2s)))]
+ [foldl (lambda (f init vs)
+ (letrec ([fold (lambda (vs accum)
+ (if (null? vs)
+ accum
+ (fold (cdr vs) (f (car vs) accum))))])
+ (fold vs init)))]
+ [ormap (lambda (f vs)
+ (letrec ([ormap (lambda (vs)
+ (if (null? vs)
+ #f
+ (or (f (car vs)) (ormap (cdr vs)))))])
+ (ormap vs)))]
+
+ [make-scope (lambda (name) (string->uninterned-symbol name))]
+ [set-add (lambda (ht v) (hash-set ht v #t))]
+ [set-remove hash-remove]
+ [set-flip (lambda (ht v)
+ (let ([ht2 (hash-remove ht v)])
+ (if (eq? ht ht2)
+ (hash-set ht v #t)
+ ht2)))]
+ [scope-set=? (lambda (sc1 sc2)
+ (and (hash-keys-subset? sc1 sc2)
+ (hash-keys-subset? sc2 sc1)))]
+
+ [empty-prop (hash)]
+ [prop-add (lambda (prop s) (hash-set prop s 'add))]
+ [prop-remove (lambda (prop s) (hash-set prop s 'remove))]
+ [prop-flip (lambda (prop s)
+ (let ([v (hash-ref prop s #f)])
+ (cond
+ [(not v) (hash-set prop s 'flip)]
+ [(eq? v 'flip) (hash-remove prop s)]
+ [(eq? v 'add) (hash-set prop s 'remove)]
+ [else (hash-set prop s 'add)])))]
+
+ [syntax-tag (string->uninterned-symbol "syntax")]
+ [identifier (lambda (id scopes) (opaque syntax-tag (cons id scopes)))]
+ [lazy-prop-pair (lambda (vec) (opaque syntax-tag vec))]
+
+ [syntax? (lambda (v) (and (opaque-ref syntax-tag v #f) #t))]
+ [identifier? (lambda (v) (symbol? (car (opaque-ref syntax-tag v '(#f . #f)))))]
+ [lazy-prop-pair? (lambda (v) (pair? (car (opaque-ref syntax-tag v '(#f . #f)))))]
+ [identifier-e (lambda (v) (car (opaque-ref syntax-tag v #f)))]
+ [identifier-scopes (lambda (v) (cdr (opaque-ref syntax-tag v #f)))]
+ [syntax-raw-content (lambda (v) (opaque-ref syntax-tag v #f))] ; returns # for non-syntaz
+
+ [datum->syntax (letrec ([datum->syntax (lambda (ctx v)
+ (cond
+ [(syntax? v) v]
+ [(symbol? v) (identifier v (identifier-scopes ctx))]
+ [(pair? v) (cons (datum->syntax ctx (car v))
+ (datum->syntax ctx (cdr v)))]
+ [else v]))])
+ datum->syntax)]
+ [syntax->datum (letrec ([syntax->datum (lambda (s)
+ (cond
+ [(identifier? s) (identifier-e s)]
+ [(lazy-prop-pair? s) (syntax->datum (car (syntax-raw-content s)))]
+ [(pair? s) (cons (syntax->datum (car s))
+ (syntax->datum (cdr s)))]
+ [else s]))])
+ syntax->datum)]
+
+ [adjust-scope (lambda (s scope op prop-op)
+ (cond
+ [(pair? s) (lazy-prop-pair (cons s (prop-op empty-prop scope)))]
+ [else (let* ([c (syntax-raw-content s)])
+ (if c
+ (let ([a (car c)])
+ (if (symbol? a)
+ (identifier a (op (cdr c) scope))
+ (lazy-prop-pair (cons (car c)
+ (prop-op (cdr c) scope)))))
+ s))]))]
+ [add-scope (lambda (s scope) (adjust-scope s scope set-add prop-add))]
+ [remove-scope (lambda (s scope) (adjust-scope s scope set-remove prop-remove))]
+ [flip-scope (lambda (s scope) (adjust-scope s scope set-flip prop-flip))]
+
+ [apply-prop (lambda (prop s)
+ (cond
+ [(= 0 (hash-count prop)) s]
+ [else (let* ([c (syntax-raw-content s)])
+ (cond
+ [(and c (pair? (car c)) (= 0 (hash-count prop)))
+ (lazy-prop-pair (cons (car c) prop))]
+ [(pair? s) (lazy-prop-pair (cons s prop))]
+ [else
+ (foldl (lambda (scope s)
+ (let ([op (hash-ref prop scope #f)])
+ (cond
+ [(eq? op 'add) (add-scope s scope)]
+ [(eq? op 'remove) (remove-scope s scope)]
+ [else (flip-scope s scope)])))
+ s
+ (hash-keys prop))]))]))]
+
+ [syntax-e (lambda (s) (let ([c (syntax-raw-content s)])
+ (if c
+ (let ([a (car c)])
+ (if (symbol? a)
+ a
+ (let ([prop (cdr c)])
+ (cons (apply-prop prop (car a))
+ (apply-prop prop (cdr a))))))
+ s)))]
+
+ [stx-pair? (lambda (p) (or (pair? p) (lazy-prop-pair? p)))]
+ [stx-car (lambda (p) (if (pair? p)
+ (car p)
+ (let ([c (syntax-raw-content p)])
+ (if (and c (pair? (car c)))
+ (apply-prop (cdr c) (car (car c)))
+ (error "stx-car: not a syntax pair" p)))))]
+ [stx-cdr (lambda (p) (if (pair? p)
+ (cdr p)
+ (let ([c (syntax-raw-content p)])
+ (if (and c (pair? (car c)))
+ (apply-prop (cdr c) (cdr (car c)))
+ (error "stx-cdr: not a syntax pair" p)))))]
+ [stx-list? (letrec ([stx-list?
+ (lambda (p)
+ (cond
+ [(null? p) #t]
+ [(pair? p) (stx-list? (cdr p))]
+ [else (let ([c (syntax-raw-content p)])
+ (and c
+ (let ([pr (car c)])
+ (and (pair? pr) (stx-list? (cdr pr))))))]))])
+ stx-list?)]
+ [stx->list (letrec ([stx->list
+ (lambda (p)
+ (cond
+ [(null? p) '()]
+ [(pair? p) (let ([r (stx->list (cdr p))])
+ (and r (cons (car p) r)))]
+ [else (let ([c (syntax-raw-content p)])
+ (and c
+ (let* ([a (car c)])
+ (and (pair? a)
+ (let* ([prop (cdr c)]
+ [r (stx->list (apply-prop prop (cdr a)))])
+ (and r (cons (apply-prop prop (car a))
+ r)))))))]))])
+ stx->list)]
+ [stx-length (letrec ([stx-length
+ (lambda (p)
+ (cond
+ [(null? p) 0]
+ [(pair? p) (+ 1 (stx-length (cdr p)))]
+ [else (let ([c (syntax-raw-content p)])
+ (if c
+ (let ([a (car c)])
+ (if (pair? a)
+ (+ 1 (stx-length (cdr a)))
+ 0))
+ 0))]))])
+ stx-length)]
+ [stx-caar (lambda (p) (stx-car (stx-car p)))]
+ [stx-cadr (lambda (p) (stx-car (stx-cdr p)))]
+ [stx-cdar (lambda (p) (stx-cdr (stx-car p)))]
+ [stx-cddr (lambda (p) (stx-cdr (stx-cdr p)))]
+
+ [add-binding* (lambda (binds id binding)
+ (let* ([sym (identifier-e id)]
+ [sc (identifier-scopes id)]
+ [sym-binds (hash-ref binds sym (hash))]
+ [k-scope (car (hash-keys sc))] ; relying on deterministic order
+ [sc+bs (hash-ref sym-binds k-scope '())]
+ [sym-binds (hash-set sym-binds k-scope (cons (cons sc binding) sc+bs))])
+ (hash-set binds sym sym-binds)))]
+ [find-all-matching-bindings (lambda (binds id)
+ (let* ([sym (identifier-e id)]
+ [id-sc (identifier-scopes id)]
+ [sym-binds (hash-ref binds sym #f)])
+ (if (not sym-binds)
+ '()
+ (foldl (lambda (scope lst)
+ (foldl (lambda (sc+b lst)
+ (let* ([sc (car sc+b)])
+ (if (hash-keys-subset? sc id-sc)
+ (cons sc+b lst)
+ lst)))
+ lst
+ (hash-ref sym-binds scope '())))
+ '()
+ (hash-keys sym-binds)))))]
+ [check-unambiguous (lambda (id max-sc+b candidate-sc+bs)
+ (map (lambda (sc+b)
+ (unless (hash-keys-subset? (car sc+b)
+ (car max-sc+b))
+ (error "ambiguous" (identifier-e id))))
+ candidate-sc+bs))]
+ [resolve* (lambda (binds id)
+ (let* ([candidate-sc+bs (find-all-matching-bindings binds id)])
+ (cond
+ [(pair? candidate-sc+bs)
+ (let* ([max-sc+binding (foldl (lambda (sc+b max-sc+b)
+ (if (> (hash-count (car max-sc+b))
+ (hash-count (car sc+b)))
+ max-sc+b
+ sc+b))
+ (car candidate-sc+bs)
+ (cdr candidate-sc+bs))])
+ (check-unambiguous id max-sc+binding candidate-sc+bs)
+ (cdr max-sc+binding))]
+ [else #f])))]
+
+ [make-state (lambda (binds nominals) (cons binds (cons (hash) nominals)))]
+ [state-binds car]
+ [state-merged cadr]
+ [state-nominals cddr]
+ [state-set-binds (lambda (state binds) (cons binds (cdr state)))]
+ [state-set-merged (lambda (state merged) (cons (car state) (cons merged (cddr state))))]
+ [state-set-nominals (lambda (state nominals) (cons (car state) (cons (cadr state) nominals)))]
+
+ [merge-binds (lambda (state key m-binds)
+ (let* ([merged (state-merged state)])
+ (cond
+ [(hash-ref merged key #f)
+ ;; already merged
+ state]
+ [else
+ (let* ([merged (hash-set merged key #t)]
+ [binds (state-binds state)]
+ [new-binds
+ ;; merge bindings from `m-binds` to `binds`:
+ (foldl (lambda (sym binds)
+ (let* ([sym-ht (hash-ref binds sym (hash))]
+ [m-sym-ht (hash-ref m-binds sym #f)]
+ [new-sym-ht
+ (foldl (lambda (s sym-ht)
+ (hash-set sym-ht
+ s
+ (append (hash-ref m-sym-ht s '())
+ (hash-ref sym-ht s '()))))
+ sym-ht
+ (hash-keys m-sym-ht))])
+ (hash-set binds sym new-sym-ht)))
+ binds
+ (hash-keys m-binds))])
+ (state-set-binds (state-set-merged state merged) new-binds))])))]
+
+ [mod-path=? (lambda (a b) (if (or (symbol? a) (symbol? b))
+ (eq? a b)
+ (string=? a b)))]
+ [call-with-nominal (lambda (state mod-path default-ids k)
+ (let* ([mod-path (if (identifier? mod-path)
+ (identifier-e mod-path)
+ mod-path)]
+ [fronted
+ (letrec ([assoc-to-front
+ (lambda (l)
+ (cond
+ [(null? l) (list (cons mod-path default-ids))]
+ [(mod-path=? mod-path (caar l)) l]
+ [else (let ([new-l (assoc-to-front (cdr l))])
+ (cons (car new-l) (cons (car l) (cdr new-l))))]))])
+ (assoc-to-front (state-nominals state)))])
+ (k (cdar fronted)
+ (lambda (new-sym+bs)
+ (let* ([new-noms (cons (cons (caar fronted) new-sym+bs)
+ (cdr fronted))])
+ (state-set-nominals state new-noms))))))]
+ [record-nominal (lambda (state mod-path sym bind)
+ (call-with-nominal state mod-path '()
+ (lambda (sym+binds install)
+ (install (cons (cons sym bind) sym+binds)))))]
+ [lookup-nominal (lambda (state mod-path)
+ (call-with-nominal state mod-path #f
+ (lambda (sym+binds install)
+ sym+binds)))]
+ [initial-nominals (lambda (binds mod-path)
+ ;; in case `all-from-out` is used on the initial import,
+ ;; add all the current ids in `binds` as nominally imported
+ (let* ([sym+bs (foldl (lambda (sym sym+bs)
+ (let* ([sym-ht (hash-ref binds sym #f)])
+ (foldl (lambda (scope sym+bs)
+ (let ([sc+bs (hash-ref sym-ht scope #f)])
+ (foldl (lambda (sc+b sym+bs)
+ (cons (cons sym (cdr sc+b))
+ sym+bs))
+ sym+bs
+ sc+bs)))
+ sym+bs
+ (hash-keys sym-ht))))
+ '()
+ (hash-keys binds))])
+ (list (cons mod-path sym+bs))))]
+
+ [bound-identifier=? (lambda (id1 id2)
+ (unless (identifier? id1) (error "bound-identifier?: not an identifier" id1))
+ (unless (identifier? id2) (error "bound-identifier?: not an identifier" id2))
+ (and (eq? (identifier-e id1) (identifier-e id2))
+ (scope-set=? (identifier-scopes id1)
+ (identifier-scopes id2))))]
+ [id-sym-eq? (lambda (id sym) (and (identifier? id) (eq? (identifier-e id) sym)))]
+
+ ;; simple transparent structs
+ [make-maker (lambda (tag) (lambda (v) (cons tag v)))]
+ [make-? (lambda (tag) (lambda (v) (and (pair? v) (eq? tag (car v)))))]
+ [make-?? (lambda (tag1 tag2) (lambda (v) (and (pair? v) (or (eq? tag1 (car v))
+ (eq? tag2 (car v))))))]
+ [any-ref cdr] ; not bothering to check a tag
+
+ [make-core-form (make-maker 'core-form)]
+ [core-form? (make-? 'core-form)]
+ [form-id any-ref]
+
+ [make-local (make-maker 'local)]
+ [local? (make-? 'local)]
+ [local-id any-ref]
+
+ [make-defined (make-maker 'defined)]
+ [defined? (make-? 'defined)]
+ [make-local-variable (make-maker 'local-variable)]
+ [variable? (make-?? 'local-variable 'defined)]
+ [variable-var any-ref]
+
+ [make-macro (make-maker 'macro)]
+ [macro-proc+key+ctx+binds any-ref]
+ [make-defined-macro (make-maker 'defined-macro)]
+ [defined-macro? (make-? 'defined-macro)]
+ [defined-macro-proc any-ref]
+ [macro? (make-?? 'macro 'defined-macro)]
+
+ [make-literal (make-maker 'literal)]
+ [literal? (make-? 'literal)]
+ [literal-val any-ref]
+
+ [make-initial-import (make-maker 'initial)]
+ [initial-import? (make-? 'initial)]
+ [initial-import-bind any-ref]
+
+ [make-specific (make-maker 'specific)]
+ [specific? (make-? 'specific)]
+ [specific-label (lambda (s) (cdr (any-ref s)))]
+ [unwrap-specific (lambda (v) (if (specific? v)
+ (car (any-ref v))
+ v))]
+ [as-specific (lambda (v) (make-specific (cons v (string->uninterned-symbol "u"))))]
+ [specific=? (lambda (a b) (if (specific? a)
+ (if (specific? b)
+ (eq? (specific-label a) (specific-label b))
+ #f)
+ (eq? a b)))]
+
+ [add-binding (lambda (state id binding)
+ (state-set-binds state (add-binding* (state-binds state) id binding)))]
+ [resolve (lambda (state id)
+ (let* ([bind (resolve* (state-binds state) id)]
+ [bind (unwrap-specific bind)])
+ (if (initial-import? bind)
+ (initial-import-bind bind)
+ bind)))]
+ [free-id=? (lambda (state id1 id2)
+ (let* ([bind1 (resolve* (state-binds state) id1)]
+ [bind2 (resolve* (state-binds state) id2)])
+ (or (specific=? bind1 bind2)
+ (and (not bind1)
+ (not bind2)
+ (eq? (identifier-e id1) (identifier-e id2))))))]
+
+ [core-sc (hash 'core #t)]
+ [make-core-initial-bind (lambda (bind) (hash 'core (list (cons core-sc (as-specific (make-initial-import bind))))))]
+ [kernel-binds (let* ([ht (kernel-env)])
+ (foldl (lambda (sym binds)
+ (cond
+ [(or (eq? sym 'eval)
+ (eq? sym 'dynamic-require))
+ ;; skip things related to the `zuo/kernel` evaluator
+ binds]
+ [else
+ (hash-set binds sym (make-core-initial-bind (hash-ref ht sym #f)))]))
+ (hash)
+ (hash-keys ht)))]
+ [top-form-binds (foldl (lambda (sym binds)
+ (hash-set binds sym (make-core-initial-bind (make-core-form sym))))
+ kernel-binds
+ '(lambda let letrec quote if begin
+ define define-syntax require provide
+ quote-syntax))]
+ [top-binds (let* ([binds top-form-binds]
+ [add (lambda (binds name val) (hash-set binds name (make-core-initial-bind val)))]
+ [binds (add binds 'identifier? identifier?)]
+ [binds (add binds 'stx-pair? stx-pair?)]
+ [binds (add binds 'stx-car stx-car)]
+ [binds (add binds 'stx-cdr stx-cdr)]
+ [binds (add binds 'stx-list? stx-list?)]
+ [binds (add binds 'stx->list stx->list)]
+ [binds (add binds 'stx-length stx-length)]
+ [binds (add binds 'syntax-e syntax-e)]
+ [binds (add binds 'syntax->datum syntax->datum)]
+ [binds (add binds 'datum->syntax datum->syntax)]
+ [binds (add binds 'bound-identifier=? bound-identifier=?)])
+ binds)]
+
+ [export-bind (lambda (bind mod-scope ctx binds)
+ ;; convert a local binding into one suitable to import
+ (let* ([label (and (specific? bind)
+ (specific-label bind))]
+ [bind (unwrap-specific bind)]
+ [bind (if (initial-import? bind)
+ (initial-import-bind bind)
+ bind)]
+ [bind (cond
+ [(defined? bind)
+ (make-local-variable (variable-var bind))]
+ [(defined-macro? bind)
+ (make-macro (list (defined-macro-proc bind) mod-scope ctx binds))]
+ [else bind])])
+ (if label
+ (make-specific (cons bind label))
+ bind)))]
+ [initial-import-bind (lambda (bind)
+ (let* ([label (and (specific? bind)
+ (specific-label bind))]
+ [bind (unwrap-specific bind)]
+ [bind (make-initial-import bind)])
+ (if label
+ (make-specific (cons bind label))
+ bind)))]
+
+ [gensym (lambda (sym) (string->uninterned-symbol (symbol->string sym)))]
+ [maybe-begin (lambda (d) (if (null? (stx-cdr d)) (stx-car d) (cons (identifier 'begin core-sc) d)))]
+ [name-lambda (lambda (form id)
+ (if (and (pair? form)
+ (eq? (car form) 'lambda))
+ ;; `zuo/kernel` recognizes this pattern to name the form
+ `(lambda ,(cadr form) ,(symbol->string (identifier-e id)) ,(cadr (cdr form)))
+ form))]
+
+ [syntax-error (lambda (msg s) (error (~a msg ": " (~s (syntax->datum s)))))]
+ [bad-syntax (lambda (s) (syntax-error "bad syntax" s))]
+ [duplicate-identifier (lambda (id s) (error "duplicate identifier:" (identifier-e id) (syntax->datum s)))]
+
+ [procedure-arity-mask (lambda (p) -1)]
+
+ [apply-macro (lambda (m s ctx state k)
+ (let* ([apply-macro
+ (lambda (proc ctx state)
+ (let* ([new-scope (make-scope "macro")]
+ [s (add-scope s new-scope)]
+ [s (if (= 4 (bitwise-and (procedure-arity-mask proc) 4))
+ (proc s (lambda (a b) (free-id=? state a b)))
+ (proc s))]
+ [s (datum->syntax ctx s)]
+ [s (flip-scope s new-scope)])
+ (k s state)))])
+ (cond
+ [(defined-macro? m) (apply-macro (defined-macro-proc m) ctx state)]
+ [else
+ (let* ([proc+key+ctx+binds (macro-proc+key+ctx+binds m)]
+ [proc (car proc+key+ctx+binds)]
+ [key (cadr proc+key+ctx+binds)]
+ [ctx (cadr (cdr proc+key+ctx+binds))]
+ [m-binds (cadr (cddr proc+key+ctx+binds))])
+ (apply-macro proc ctx (merge-binds state key m-binds)))])))]
+
+ [expand-define (lambda (s state k)
+ (unless (and (stx-list? s) (= 3 (stx-length s)) (identifier? (stx-cadr s)))
+ (bad-syntax s))
+ (let* ([id (stx-cadr s)]
+ [id-bind (resolve state id)])
+ (when (or (defined? id-bind)
+ (defined-macro? id-bind))
+ (syntax-error "duplicate definition" id))
+ (let* ([sym (identifier-e id)]
+ [def-id (gensym sym)]
+ [var (variable sym)]
+ [new-state (add-binding state id (as-specific (make-defined var)))]
+ [new-s `(,variable-set! ,var (,name-lambda ,(stx-cadr (stx-cdr s)) ,id))])
+ (k new-s new-state))))]
+
+ [expand-define-syntax (lambda (s state parse)
+ (unless (and (stx-list? s) (= 3 (stx-length s)) (identifier? (stx-cadr s)))
+ (bad-syntax s))
+ (let* ([id (stx-cadr s)]
+ [id-bind (resolve state id)])
+ (when (or (defined? id-bind)
+ (defined-macro? id-bind))
+ (syntax-error "duplicate definition" id))
+ (let* ([e (parse (stx-cadr (stx-cdr s)) state)]
+ [proc ('eval (name-lambda e id))])+ (add-binding state id (as-specific (make-defined-macro proc))))))]
+
+ [expand-provide (lambda (s state provides mod-path)
+ (unless (stx-list? s) (bad-syntax s))
+ (foldl (lambda (p provides)
+ (let* ([add-provide (lambda (provides id as-sym)
+ (let* ([old-id (hash-ref provides as-sym #f)])
+ (when (and old-id
+ (not (free-id=? state old-id id)))
+ (syntax-error "already provided as different binding" as-sym))
+ (hash-set provides as-sym id)))]
+ [bad-provide-form (lambda () (syntax-error "bad provide clause" p))])
+ (cond
+ [(identifier? p) (add-provide provides p (identifier-e p))]
+ [(stx-pair? p)
+ (unless (stx-list? p) (bad-provide-form))
+ (let ([form (stx-car p)])
+ (cond
+ [(id-sym-eq? form 'rename-out)
+ (foldl (lambda (rn provides)
+ (unless (and (stx-list? rn) (= 2 (stx-length rn))
+ (identifier? (stx-car rn)) (identifier? (stx-cadr rn)))
+ (bad-provide-form))
+ (add-provide provides (stx-car rn) (identifier-e (stx-cadr rn))))
+ provides
+ (stx->list (stx-cdr p)))]
+ [(id-sym-eq? form 'all-from-out)
+ (foldl (lambda (req-path provides)
+ (let* ([prov-sc (identifier-scopes (stx-car s))]
+ [sym+binds (lookup-nominal state req-path)])
+ (unless sym+binds (syntax-error "module not required" req-path))
+ (foldl (lambda (sym+bind provides)
+ (let* ([sym (car sym+bind)]
+ [id (identifier sym prov-sc)]
+ [bind (resolve* (state-binds state) id)])
+ (cond
+ [(not (specific=? bind (cdr sym+bind)))
+ ;; shadowed by definition or other import
+ provides]
+ [else
+ (add-provide provides id sym)])))
+ provides
+ sym+binds)))
+ provides
+ (stx->list (stx-cdr p)))]
+ [else (bad-provide-form)]))]
+ [else (bad-provide-form)])))
+ provides
+ (stx->list (stx-cdr s))))]
+ [expand-require (lambda (s state mod-path)
+ (let* ([check-renames
+ ;; syntax check on renaming clauses `ns`
+ (lambda (r ns id-ok?)
+ (map (lambda (n) (unless (or (and id-ok?
+ (identifier? n))
+ (and (stx-list? n)
+ (= 2 (stx-length n))
+ (identifier? (stx-car n))
+ (identifier? (stx-cadr n))))
+ (bad-syntax r)))
+ (stx->list ns)))]
+ [make-rename-filter
+ ;; used to apply `ns` renaming clauses to an imported identifier
+ (lambda (ns only?)
+ (lambda (sym)
+ (letrec ([loop (lambda (ns)
+ (cond
+ [(null? ns) (if only? #f sym)]
+ [(id-sym-eq? (stx-car ns) sym) sym]
+ [(and (stx-pair? (stx-car ns))
+ (id-sym-eq? (stx-caar ns) sym))
+ (syntax-e (stx-cadr (stx-car ns)))]
+ [else (loop (stx-cdr ns))]))])
+ (loop ns))))]
+ [make-provides-checker
+ ;; used to check whether set of provided is consistent with `ns`
+ (lambda (ns)
+ (lambda (provides)
+ (map (lambda (n)
+ (let ([id (if (pair? n) (car n) n)])
+ (unless (hash-ref provides (identifier-e id) #f)
+ (syntax-error "identifier is not in required set" id))))
+ (stx->list ns))))])
+ ;; parse each `require` clause `r:
+ (foldl (lambda (r state)
+ (let* ([req-sc (identifier-scopes (stx-car s))]
+ [req-path+filter+check
+ (cond
+ [(string? r) (list r (lambda (sym) sym) void)]
+ [(identifier? r) (list (identifier-e r) (lambda (sym) sym) void)]
+ [(stx-pair? r)
+ (unless (and (stx-list? r) (stx-pair? (stx-cdr r))) (bad-syntax r))
+ (let* ([ns (stx-cddr r)])
+ (cond
+ [(id-sym-eq? (stx-car r) 'only-in)
+ (check-renames r ns #t)
+ (list (stx-cadr r) (make-rename-filter ns #t) (make-provides-checker ns))]
+ [(id-sym-eq? (stx-car r) 'rename-in)
+ (check-renames r ns #f)
+ (list (stx-cadr r) (make-rename-filter ns #f) (make-provides-checker ns))]
+ [else (bad-syntax r)]))]
+ [else (bad-syntax r)])]
+ [req-path (car req-path+filter+check)]
+ [filter (cadr req-path+filter+check)]
+ [check (cadr (cdr req-path+filter+check))]
+ [in-mod-path (if (string? req-path)
+ (module-path-join req-path (car (split-path mod-path)))
+ (syntax->datum req-path))]
+ [mod ('dynamic-require in-mod-path)]+ [provides (hash-ref mod 'macromod-provides #f)])
+ (unless provides (syntax-error "not a compatible module" r))
+ (check provides)
+ ;; add each provided binding (except as filtered)
+ (foldl (lambda (sym state)
+ (let* ([as-sym (filter sym)])
+ (cond
+ [(not as-sym) state]
+ [else
+ ;; check whether it's bound already
+ (let* ([as-id (identifier as-sym req-sc)]
+ [current-bind (resolve* (state-binds state) as-id)]
+ [req-bind (hash-ref provides sym #f)]
+ [add-binding/record-nominal
+ (lambda ()
+ (let* ([state (add-binding state as-id req-bind)])
+ (record-nominal state req-path as-sym req-bind)))])
+ (cond
+ [(not current-bind)
+ ;; not already bound, so import is ok
+ (add-binding/record-nominal)]
+ [(initial-import? (unwrap-specific current-bind))
+ ;; `require` can shadow an initial import
+ (add-binding/record-nominal)]
+ [(specific=? current-bind req-bind)
+ ;; re-import of same variable or primitive, also ok
+ state]
+ [(or (defined? current-bind)
+ (defined-macro? current-bind))
+ ;; definition shadows import
+ state]
+ [else
+ (syntax-error "identifier is already imported" as-id)]))])))
+ state
+ (hash-keys provides))))
+ state
+ (stx->list (stx-cdr s)))))]
+
+ [expand-top-sequence
+ ;; expand top-level forms and gather imports and definitions
+ (lambda (es state mod-path ctx parse)
+ (letrec ([expand-top
+ (lambda (es accum state provides)
+ (cond
+ [(null? es) (list (reverse accum) state provides)]
+ [else
+ (let* ([s (stx-car es)])
+ (cond
+ [(stx-pair? s)
+ (let* ([rator (stx-car s)]
+ [bind (and (identifier? rator)
+ (resolve state rator))])
+ (cond
+ [(macro? bind)
+ (apply-macro bind s ctx state
+ (lambda (new-s new-state)
+ (expand-top (cons new-s (cdr es)) accum new-state provides)))]
+ [(core-form? bind)
+ (let ([bind (form-id bind)])
+ (cond
+ [(eq? bind 'begin)
+ (unless (stx-list? s) (bad-syntax s))
+ (expand-top (append (stx->list (stx-cdr s)) (cdr es)) accum state provides)]
+ [(eq? bind 'define)
+ (expand-define s
+ state
+ (lambda (new-s new-state)
+ (expand-top (cdr es) (cons new-s accum) new-state provides)))]
+ [(eq? bind 'define-syntax)
+ (let ([new-state (expand-define-syntax s state parse)])
+ (expand-top (cdr es) accum new-state provides))]
+ [(eq? bind 'provide)
+ (let ([new-provides (expand-provide s state provides mod-path)])
+ (expand-top (cdr es) accum state new-provides))]
+ [(eq? bind 'require)
+ (let ([new-state (expand-require s state mod-path)])
+ (expand-top (cdr es) accum new-state provides))]
+ [else
+ (expand-top (cdr es) (cons s accum) state provides)]))]
+ [else (expand-top (cdr es) (cons s accum) state provides)]))]
+ [else (expand-top (cdr es) (cons s accum) state provides)]))]))])
+ (expand-top es '() state (hash))))]
+
+ [parse-lambda (lambda (s state parse)
+ (unless (>= (stx-length s) 3) (bad-syntax s))
+ (let* ([formals (stx-cadr s)]
+ [new-formals (letrec ([reformal (lambda (f seen)
+ (cond
+ [(null? f) '()]
+ [(identifier? f)
+ (when (ormap (lambda (sn) (bound-identifier=? f sn)) seen)
+ (duplicate-identifier f s))
+ (gensym (syntax-e f))]
+ [(stx-pair? f)
+ (let* ([a (stx-car f)])
+ (unless (identifier? a) (bad-syntax s))
+ (cons (reformal a seen)
+ (reformal (stx-cdr f) (cons a seen))))]
+ [else (bad-syntax s)]))])
+ (reformal formals '()))]
+ [new-scope (make-scope "lambda")]
+ [state (letrec ([add-formals (lambda (state formals new-formals)
+ (cond
+ [(identifier? formals)
+ (let* ([id (add-scope formals new-scope)])
+ (add-binding state id (make-local new-formals)))]
+ [(pair? new-formals)
+ (add-formals (add-formals state (stx-cdr formals) (cdr new-formals))
+ (stx-car formals)
+ (car new-formals))]
+ [else state]))])
+ (add-formals state formals new-formals))])
+ `(lambda ,new-formals
+ ,(parse (maybe-begin (add-scope (stx-cddr s) new-scope)) state))))]
+
+ [nest-bindings (lambda (new-cls body)
+ (letrec ([nest-bindings (lambda (new-cls)
+ (if (null? new-cls)
+ body
+ `(let (,(car new-cls))
+ ,(nest-bindings (cdr new-cls)))))])
+ (nest-bindings (reverse new-cls))))]
+ [parse-let (lambda (s state parse)
+ (unless (>= (stx-length s) 3) (bad-syntax s))
+ (let* ([cls (stx-cadr s)]
+ [orig-state state]
+ [new-scope (make-scope "let")])
+ (unless (stx-list? cls) (bad-syntax s))
+ (letrec ([parse-clauses
+ (lambda (cls new-cls state seen)
+ (cond
+ [(null? cls)
+ (nest-bindings (reverse new-cls)
+ (parse (maybe-begin (add-scope (stx-cddr s) new-scope)) state))]
+ [else
+ (let* ([cl (stx-car cls)])
+ (unless (and (stx-list? cl) (= 2 (stx-length cl))) (bad-syntax s))
+ (let* ([id (stx-car cl)])
+ (unless (identifier? id) (bad-syntax s))
+ (when (ormap (lambda (sn) (bound-identifier=? id sn)) seen)
+ (duplicate-identifier id s))
+ (let* ([new-id (gensym (identifier-e id))])
+ (parse-clauses (stx-cdr cls)
+ (cons (list new-id (name-lambda
+ (parse (stx-cadr cl) orig-state)
+ id))
+ new-cls)
+ (add-binding state (add-scope id new-scope) (make-local new-id))
+ (cons id seen)))))]))])
+ (parse-clauses cls '() state '()))))]
+
+ [parse-letrec (lambda (s state parse)
+ (unless (>= (stx-length s) 3) (bad-syntax s))
+ (let* ([cls (stx-cadr s)]
+ [orig-state state]
+ [new-scope (make-scope "letrec")])
+ (unless (stx-list? cls) (bad-syntax s))
+ ;; use mutable variables to tie knots
+ (letrec ([bind-all (lambda (x-cls new-ids state seen)
+ (cond
+ [(null? x-cls)
+ (nest-bindings
+ (map (lambda (new-id)
+ `[,new-id (,variable ',new-id)])
+ new-ids)
+ `(begin
+ (begin . ,(map2 (lambda (cl new-id)
+ `(,variable-set! ,(car new-ids)
+ ,(name-lambda
+ (let ([rhs (stx-cadr (stx-car cls))])
+ (parse (add-scope rhs new-scope) state))
+ (stx-caar cls))))
+ (stx->list cls)
+ (reverse new-ids)))
+ ,(parse (maybe-begin (add-scope (stx-cddr s) new-scope)) state)))]
+ [else
+ (let* ([cl (stx-car x-cls)])
+ (unless (and (stx-list? cl) (= 2 (stx-length cl))) (bad-syntax s))
+ (let* ([id (stx-car cl)])
+ (unless (identifier? id) (bad-syntax s))
+ (when (ormap (lambda (sn) (bound-identifier=? id sn)) seen)
+ (duplicate-identifier id s))
+ (let ([new-id (gensym (identifier-e id))])
+ (bind-all (stx-cdr x-cls)
+ (cons new-id new-ids)
+ (add-binding state (add-scope id new-scope) (make-local-variable new-id))
+ (cons id seen)))))]))])
+ (bind-all cls '() state '()))))]
+
+ [make-parse
+ (lambda (ctx)
+ (letrec ([parse
+ (lambda (s state)
+ (cond
+ [(stx-pair? s)
+ (let* ([rator (stx-car s)]
+ [bind (and (identifier? rator)
+ (resolve state rator))])
+ (cond
+ [(macro? bind)
+ (apply-macro bind s ctx state
+ (lambda (new-s new-state)
+ (parse new-s new-state)))]
+ [(core-form? bind)
+ (unless (stx-list? s) (bad-syntax s))
+ (let ([bind (form-id bind)])
+ (cond
+ [(eq? bind 'lambda)
+ (parse-lambda s state parse)]
+ [(eq? bind 'let)
+ (parse-let s state parse)]
+ [(eq? bind 'letrec)
+ (parse-letrec s state parse)]
+ [(eq? bind 'quote)
+ (unless (= 2 (stx-length s)) (bad-syntax s))
+ `(quote ,(syntax->datum (stx-cadr s)))]
+ [(eq? bind 'quote-syntax)
+ (unless (= 2 (stx-length s)) (bad-syntax s))
+ `(quote ,(stx-cadr s))]
+ [(eq? bind 'if)
+ (unless (= 4 (stx-length s)) (bad-syntax s))
+ `(if ,(parse (stx-cadr s) state)
+ ,(parse (stx-cadr (stx-cdr s)) state)
+ ,(parse (stx-cadr (stx-cddr s)) state))]
+ [(eq? bind 'begin)
+ (unless (stx-pair? (stx-cdr s)) (bad-syntax s))
+ (let ([es (map (lambda (e) (parse e state)) (stx->list (stx-cdr s)))])
+ (if (null? (cdr es))
+ (car es)
+ (cons 'begin es)))]
+ [else
+ (map (lambda (e) (parse e state)) (stx->list s))]))]
+ [(eq? rator name-lambda) ; form created by `define` to propagate name
+ (name-lambda (parse (stx-cadr s) state) (stx-cadr (stx-cdr s)))]
+ [else (map (lambda (e) (parse e state)) (stx->list s))]))]
+ [(identifier? s)
+ (let* ([bind (resolve state s)])
+ (cond
+ [(core-form? bind) (bad-syntax s)]
+ [(local? bind) (local-id bind)]
+ [(variable? bind) `(,variable-ref ,(variable-var bind))]
+ [(literal? bind) (literal-val bind)]
+ [(macro? bind)
+ (apply-macro bind s ctx state
+ (lambda (new-s new-state)
+ (parse new-s state)))]
+ [(not bind) (syntax-error "unbound identifier" s)]
+ [else bind]))]
+ [(null? s) (bad-syntax s)]
+ [else s]))])
+ parse))]
+
+ [make-read-and-eval
+ (lambda (make-initial-state)
+ (lambda (str start mod-path)
+ (let* ([es (string-read (substring str start (string-length str)))]
+ [mod-scope (make-scope "module")]
+ [ctx (identifier 'module (set-add core-sc mod-scope))]
+ [es (map (lambda (e) (datum->syntax ctx e)) es)]
+ [parse (make-parse ctx)]
+ [initial-state (make-initial-state ctx)]
+ [es+state+provides (expand-top-sequence es initial-state mod-path ctx parse)]
+ [es (car es+state+provides)]
+ [state (cadr es+state+provides)]
+ [binds (state-binds state)]
+ [provides (cadr (cdr es+state+provides))]
+ [outs (foldl (lambda (as-sym outs)
+ (let* ([id (hash-ref provides as-sym #f)]
+ [bind (resolve* (state-binds state) id)])
+ (unless bind (syntax-error "provided identifier not bound" id))
+ (hash-set outs as-sym (export-bind bind mod-scope ctx binds))))
+ (hash)
+ (hash-keys provides))]
+ [print-result (lambda (v)
+ (unless (eq? v (void))
+ (alert (~v v))))]
+ [add-print (lambda (s) `(,print-result ,s))])
+ ('eval (cons 'begin (cons '(void) (map (lambda (e) (add-print (parse e state))) es))))+ (hash 'macromod-provides outs))))])
+ (eq?
+ 'done
+ (hash
+ ;; makes `#lang zuo/private/macromod work:
+ 'read-and-eval (make-read-and-eval (lambda (ctx)
+ (make-state top-binds
+ (initial-nominals top-binds 'zuo/private/macromod))))
+ ;; makes `(require zuo/private/macromod)` work:
+ 'macromod-provides (foldl (lambda (sym provides)
+ (hash-set provides sym (hash-ref top-binds sym #f)))
+ (hash)
+ (hash-keys top-binds))
+ ;; for making a new `#lang` with some initial imports:
+ 'make-read-and-eval-with-initial-imports-from
+ (lambda (mod-path)
+ (let* ([mod ('dynamic-require mod-path)]+ [provides (hash-ref mod 'macromod-provides #f)])
+ (unless provides
+ (syntax-error "not a compatible module for initial imports" mod-path))
+ (make-read-and-eval
+ (lambda (ctx)
+ (let* ([binds (foldl (lambda (sym binds)
+ (let* ([id (datum->syntax ctx sym)]
+ [bind (initial-import-bind (hash-ref provides sym #f))])
+ (add-binding* binds id bind)))
+ (hash)
+ (hash-keys provides))])
+ (make-state binds (initial-nominals binds mod-path))))))))))
--- /dev/null
+++ b/tests/example-hygienic.zuo
@@ -1,0 +1,3 @@
+#lang zuo/hygienic
+
+(include "example-common.zuo")
--- /dev/null
+++ b/tests/example.zuo
@@ -1,0 +1,3 @@
+#lang zuo
+
+(include "example-common.zuo")
--- /dev/null
+++ b/tests/fib-common.zuo
@@ -1,0 +1,18 @@
+#lang zuo/datum
+
+;; The classic toy benchmark
+(provide fib)
+
+(define input
+ (let ([args (hash-ref (runtime-env) 'args)])
+ (if (null? args)
+ 30
+ (string->integer (car args)))))
+
+(define (fib n)
+ (cond
+ [(= n 0) 1]
+ [(= n 1) 1]
+ [else (+ (fib (- n 1)) (fib (- n 2)))]))
+
+(fib input)
--- /dev/null
+++ b/tests/fib-hygienic.zuo
@@ -1,0 +1,6 @@
+#lang zuo/hygienic
+
+;; Performance should be the same as the non-hygienic parsing, but we
+;; may want to check on the startup overhead of `zuo/hygienic`
+
+(include "fib-common.zuo")
--- /dev/null
+++ b/tests/fib.zuo
@@ -1,0 +1,3 @@
+#lang zuo
+
+(include "fib-common.zuo")
--- /dev/null
+++ b/tests/file-handle.zuo
@@ -1,0 +1,132 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "file handles")
+
+(check (not (handle? 1)))
+(check (not (handle? '(handle))))
+(check eof eof)
+(check (eq? eof eof))
+
+(check (handle? (fd-open-input 'stdin)))
+(check (handle? (fd-open-output 'stdout (hash))))
+(check (handle? (fd-open-output 'stderr (hash))))
+(check-arg-fail (fd-open-output 'stdin (hash)) "not a path string")
+(check-arg-fail (fd-open-input 'stdout) "not a path string")
+(check-arg-fail (fd-open-input 'stderr) "not a path string")
+(check-arg-fail (fd-open-output 'stdout (hash 'exists 'truncate)) "non-empty options")
+
+(let ([out (fd-open-output (build-path tmp-dir "handle1.txt") :truncate)])
+ (check (handle? out))
+ (check (void? (fd-write out "one")))
+ (check (void? (fd-close out)))
+ (check (handle? out)))
+
+(check-fail (let ([out (fd-open-output ,(build-path tmp-dir "handle2.txt") :truncate)])
+ (fd-close out)
+ (fd-close out))
+ "not an open")
+
+(let ([in (fd-open-input (build-path tmp-dir "handle1.txt"))])
+ (check (handle? in))
+ (check (fd-read in 1) "o")
+ (check (fd-read in 2) "ne")
+ (check (fd-read in 1) eof)
+ (check (fd-read in 0) "")
+ (check (void? (fd-close in)))
+ (check (handle? in)))
+
+(let ([in (fd-open-input (build-path tmp-dir "handle1.txt"))])
+ (check (fd-read in eof) "one")
+ (check (fd-read in 1) eof)
+ (check (fd-read in eof) "")
+ (check (void? (fd-close in))))
+
+(check-arg-fail (fd-open-output 'no :error) "not a path string")
+(check-arg-fail (fd-open-output "" :error) "not a path string")
+(check-arg-fail (fd-open-input 'no) "not a path string")
+(check-arg-fail (fd-open-input "") "not a path string")
+(check-arg-fail (fd-read 'no 0) "not an open input")
+(check-arg-fail (fd-write 'no "") "not an open output")
+(check-arg-fail (fd-close 'oops) "not an open input or output")
+
+(check-arg-fail (fd-open-output "file" 'oops) "not a hash table")
+(check-arg-fail (fd-open-output "file" (hash 'oops 'truncate)) "unrecognized option")
+(check-arg-fail (fd-open-output "file" (hash 'exists 'oops)) "invalid exists mode")
+
+(check-arg-fail (fd-open-output ,(build-path tmp-dir "handle1.txt")
+ :error)
+ "file open failed")
+(check-arg-fail (fd-open-output ,(build-path (build-path tmp-dir "no-such-dir")
+ "handle0.txt")
+ :error)
+ "file open failed")
+(check-arg-fail (fd-open-output ,(build-path tmp-dir "nonesuch.txt")
+ :must-truncate)
+ "file open failed")
+(check-arg-fail (fd-open-output ,(build-path tmp-dir "nonesuch.txt")
+ :update)
+ "file open failed")
+(let ([fd (fd-open-output (build-path tmp-dir "handle1.txt")
+ :append)])
+ (fd-write fd " two")
+ (fd-close fd)
+ (define in (fd-open-input (build-path tmp-dir "handle1.txt")))
+ (check (fd-read in eof) "one two")
+ (fd-close in))
+(let ([fd (fd-open-output (build-path tmp-dir "handle1.txt")
+ :must-truncate)])
+ (fd-write fd "[three]")
+ (fd-close fd)
+ (define in (fd-open-input (build-path tmp-dir "handle1.txt")))
+ (check (fd-read in eof) "[three]")
+ (fd-close in))
+(let ([fd (fd-open-output (build-path tmp-dir "handle1.txt")
+ :update)])
+ (fd-write fd "4")
+ (fd-close fd)
+ (define in (fd-open-input (build-path tmp-dir "handle1.txt")))
+ (check (fd-read in eof) "4three]")
+ (fd-close in))
+(let ([fd (fd-open-output (build-path tmp-dir "handle1.txt")
+ :can-update)])
+ (fd-write fd "50")
+ (fd-close fd)
+ (define in (fd-open-input (build-path tmp-dir "handle1.txt")))
+ (check (fd-read in eof) "50hree]")
+ (fd-close in))
+(let ([fd (begin
+ (rm (build-path tmp-dir "handle1.txt"))
+ (fd-open-output (build-path tmp-dir "handle1.txt")
+ :can-update))])
+ (fd-write fd "six")
+ (fd-close fd)
+ (define in (fd-open-input (build-path tmp-dir "handle1.txt")))
+ (check (fd-read in eof) "six")
+ (fd-close in))
+
+(let ([not-there (build-path tmp-dir "handle0.txt")])
+ (when (file-exists? not-there) (rm not-there))
+ (check-arg-fail (fd-open-input ,not-there) "file open failed"))
+
+(let ()
+ (define path (build-path tmp-dir "handle2.txt"))
+ (define out (fd-open-output path :truncate))
+ (define big (apply ~a (let loop ([i 10000])
+ (if (= i 0)
+ '()
+ (cons "hello" (loop (- i 1)))))))
+ (fd-write out big)
+ (fd-close out)
+ (let ()
+ (define in (fd-open-input path))
+ (check (equal? big (fd-read in eof)))
+ (check (fd-read in 1) eof)
+ (fd-close in))
+ (let ()
+ (define in (fd-open-input path))
+ (define len (quotient (string-length big) 2))
+ (check (equal? (fd-read in len) (substring big 0 len)))
+ (check (fd-read in 1) (string (string-ref big len)))
+ (fd-close in)))
--- /dev/null
+++ b/tests/filesystem.zuo
@@ -1,0 +1,157 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "filesystem")
+
+(check (hash? (stat tmp-dir #f)))
+(check (stat (build-path tmp-dir "nonesuch.txt") #f) #f)
+
+(let ([s (stat tmp-dir #f)])
+ (check (hash-ref s 'type) 'dir))
+(check (directory-exists? tmp-dir))
+(check (file-exists? tmp-dir) #f)
+(check (link-exists? tmp-dir) #f)
+(check-arg-fail (stat 10) not-path)
+
+(define now (current-time))
+
+(define exists.txt (build-path tmp-dir "exists.txt"))
+(let ([fd (fd-open-output exists.txt :truncate)])
+ (fd-write fd "xyz")
+ (fd-close fd))
+
+(define exists2.txt (build-path tmp-dir "exists2.txt"))
+(fd-close (fd-open-output exists2.txt :can-update))
+
+(check (file-exists? exists.txt))
+(check (file-exists? exists2.txt))
+(check (directory-exists? exists2.txt) #f)
+(check (link-exists? exists2.txt) #f)
+
+(check-arg-fail (file-exists? 10) not-path)
+(check-arg-fail (directory-exists? 10) not-path)
+(check-arg-fail (link-exists? 10) not-path)
+
+(let ([s (stat exists.txt #f)])
+ (check (hash? s))
+ (check (hash-ref s 'type) 'file)
+ (check (hash-ref s 'size) 3)
+ ;; Seems to be too precise for some Linux configurations:
+ #;
+ (check (or (> (hash-ref s 'modify-time-seconds) (car now))
+ (and (= (hash-ref s 'modify-time-seconds) (car now))
+ (>= (hash-ref s 'modify-time-nanoseconds) (cdr now)))))
+ (check (>= (hash-ref s 'modify-time-seconds) (car now)))
+ (let ([s2 (stat exists.txt #t)])
+ (check s s2))
+ (let ([s2 (stat exists2.txt #t)])
+ (check (hash? s2))
+ (check (not (equal? (hash-ref s 'inode) (hash-ref s2 'inode))))
+ (check (equal? (hash-ref s 'device-id) (hash-ref s2 'device-id)))))
+
+(let ([l (ls tmp-dir)])
+ (check (pair? (member "exists.txt" l)))
+ (check (pair? (member "exists2.txt" l))))
+(check-arg-fail (ls 10) not-path)
+
+(rm exists2.txt)
+(check (stat exists2.txt #t) #f)
+(check (member "exists2.txt" (ls tmp-dir)) #f)
+
+(define sub-dir (build-path tmp-dir "sub"))
+(rm* sub-dir)
+
+(check (directory-exists? sub-dir) #f)
+(check (mkdir sub-dir) (void))
+(check (directory-exists? sub-dir))
+(check-arg-fail (mkdir 10) not-path)
+
+(define sub-sub-dir (build-path sub-dir "subsub"))
+(check (directory-exists? sub-sub-dir) #f)
+(check (mkdir sub-sub-dir) (void))
+(check (directory-exists? sub-sub-dir))
+(check (rmdir sub-sub-dir) (void))
+(check (directory-exists? sub-sub-dir) #f)
+(check (mkdir sub-sub-dir) (void))
+
+(fd-close (fd-open-output (build-path sub-sub-dir "apple") :can-update))
+(fd-close (fd-open-output (build-path sub-sub-dir "banana") :can-update))
+(fd-close (fd-open-output (build-path sub-sub-dir "cherry") :can-update))
+(fd-close (fd-open-output (build-path sub-dir "donut") :can-update))
+
+(check (length (ls sub-dir)) 2)
+(check (length (ls sub-sub-dir)) 3)
+
+(check (void? (mv (build-path sub-sub-dir "banana")
+ (build-path sub-dir "banana"))))
+(check (length (ls sub-dir)) 3)
+(check (length (ls sub-sub-dir)) 2)
+(check (void? (mv (build-path sub-dir "banana")
+ (build-path sub-sub-dir "eclair"))))
+(let ([l (ls sub-sub-dir)])
+ (check (pair? (member "apple" l)))
+ (check (pair? (member "cherry" l)))
+ (check (pair? (member "eclair" l)))
+ (check (not (member "banana" l))))
+(check-arg-fail (mv 10 "x") not-path)
+(check-arg-fail (mv "x" 10) not-path)
+
+(check-fail (rm ,sub-dir) "failed")
+(check-arg-fail (rm 10) not-path)
+
+(rm* sub-dir)
+(check (directory-exists? sub-sub-dir) #f)
+(check (directory-exists? sub-dir) #f)
+(check-arg-fail (rm* 10) not-path)
+
+(mkdir-p sub-sub-dir)
+(check (directory-exists? sub-sub-dir))
+(check (directory-exists? sub-dir))
+(check-arg-fail (mkdir-p 10) not-path)
+
+(when (eq? 'unix (hash-ref (runtime-env) 'system-type))
+ (let ([fd (fd-open-output (build-path sub-dir "high") :can-update)])
+ (fd-write fd "HIGH")
+ (fd-close fd))
+ (let ([fd (fd-open-output (build-path sub-sub-dir "low") :can-update)])
+ (fd-write fd "LOW")
+ (fd-close fd))
+ (define (get path)
+ (let ([fd (fd-open-input path)])
+ (define v (fd-read fd eof))
+ (fd-close fd)
+ v))
+ (symlink "low" (build-path sub-sub-dir "below"))
+ (check (get (build-path sub-sub-dir "below")) "LOW")
+ (check (readlink (build-path sub-sub-dir "below")) "low")
+ (check (hash-ref (stat (build-path sub-sub-dir "below") #f) 'type) 'link)
+ (check (hash-ref (stat (build-path sub-sub-dir "below") #t) 'type) 'file)
+ (check (link-exists? (build-path sub-sub-dir "below")))
+ (check (rm (build-path sub-sub-dir "below")) (void))
+ (check (get (build-path sub-sub-dir "low")) "LOW")
+
+ (symlink "../high" (build-path sub-sub-dir "above"))
+ (check (get (build-path sub-sub-dir "above")) "HIGH")
+ (check (readlink (build-path sub-sub-dir "above")) "../high")
+ (check (rm (build-path sub-sub-dir "above")) (void))
+ (check (get (build-path sub-dir "high")) "HIGH")
+
+ (symlink ".." (build-path sub-sub-dir "again"))
+ (check (link-exists? (build-path sub-sub-dir "again")))
+ (check (hash-ref (stat (build-path sub-sub-dir "again") #f) 'type) 'link)
+ (check (hash-ref (stat (build-path sub-sub-dir "again") #t) 'type) 'dir)
+ (check (get (build-path sub-sub-dir "again" "high")) "HIGH")
+ (check (get (build-path sub-sub-dir "again" "subsub" "low")) "LOW")
+ (check (ls sub-dir) (ls (build-path sub-sub-dir "again")))
+
+ (rm* sub-sub-dir)
+ (check (get (build-path sub-dir "high")) "HIGH")
+
+ (void))
+
+(check-arg-fail (readlink 10) not-path)
+(check-arg-fail (symlink 10 "a") not-path)
+(check-arg-fail (symlink "a" 10) not-path)
+
+(rm* sub-dir)
--- /dev/null
+++ b/tests/form-common.zuo
@@ -1,0 +1,216 @@
+#lang zuo/datum
+
+(check 1 1)
+(check cons cons)
+
+(check-fail oops "unbound identifier: oops")
+
+(check (cons 1 2) '(1 . 2))
+(check-fail (cons 1 . 2) bad-stx)
+(check-fail (cons . 2) bad-stx)
+
+(check (procedure? (lambda (x) x)) #t)
+(check (procedure? (lambda (x y) x)) #t)
+(check (procedure? (lambda (x y . z) x)) #t)
+(check (procedure? (lambda (x y . z) x x)) #t)
+(check (procedure? (lambda (x [y x] . z) x x)) #t)
+(check-fail (lambda) bad-stx)
+(check-fail (lambda . x) bad-stx)
+(check-fail (lambda 5 x) bad-stx)
+(check-fail (lambda (x x) x) "duplicate identifier")
+(check-fail (lambda (x . x) x) "duplicate identifier")
+(check-fail (lambda (x y x) x) "duplicate identifier")
+(check-fail (lambda (x y . x) x) "duplicate identifier")
+(check-fail (lambda (x y . z) . x) bad-stx)
+(check-fail (lambda (x y . 5) x) bad-stx)
+(check-fail (lambda ([x 1] y . z) x) bad-stx)
+(check-fail (lambda (x [y . 1] . z) x) bad-stx)
+(check-fail (lambda (x [y 1 2] . z) x) bad-stx)
+(check-fail (lambda 5 x) bad-stx)
+(check-fail (lambda x 1 . 2) bad-stx)
+(check-fail (lambda x 1 2 . 3) bad-stx)
+(check-fail lambda bad-stx)
+
+(check ((lambda (x y z) (list z x)) 1 2 3) '(3 1))
+(check ((lambda (x y [z (+ x y)]) (list z x)) 1 2 30) '(30 1))
+(check ((lambda (x y [z (+ x y)]) (list z x)) 1 2) '(3 1))
+(check ((lambda (x [y (+ x 2)] [z (+ x y)]) (list z x)) 1) '(4 1))
+(check-fail ((lambda (x) x)) arity)
+(check-fail ((lambda (x) x) 1 2) arity)
+(check-fail ((lambda (x . z) x)) arity)
+
+(check (procedure? (lambda (x) x)) #t)
+
+(check (quote cons) 'cons)
+(check-fail (quote) bad-stx)
+(check-fail (quote cons list) bad-stx)
+(check-fail (quote . cons) bad-stx)
+(check-fail (quote cons . list) bad-stx)
+(check-fail quote bad-stx)
+
+(check (if #t 1 2) 1)
+(check (if 0 1 2) 1)
+(check (if #f 1 2) 2)
+(check-fail (if) bad-stx)
+(check-fail (if . 1) bad-stx)
+(check-fail (if 1) bad-stx)
+(check-fail (if 1 . 2) bad-stx)
+(check-fail (if 1 2) bad-stx)
+(check-fail (if 1 2 . 3) bad-stx)
+(check-fail (if 1 2 3 . 4) bad-stx)
+(check-fail (if 1 2 3 4) bad-stx)
+(check-fail if bad-stx)
+
+(check (let ([x 1]) x) 1)
+(check (let ([x 1]) (let ([x 2]) x)) 2)
+(check (let ([x 1]) (list (let ([x 2]) x) x)) '(2 1))
+(check (let ([x 1] [y 2]) (let ([x y] [y x]) (list y x))) '(1 2))
+
+(check (let* ([x 1]) x) 1)
+(check (let* ([x 1]) (let ([x 2]) x)) 2)
+(check (let* ([x 1]) (list (let* ([x 2]) x) x)) '(2 1))
+(check (let* ([x 1] [y 2]) (let* ([x y] [y x]) (list y x))) '(2 2))
+
+(check (letrec ([x 1]) x) 1)
+(check (letrec ([x 1]) (let ([x 2]) x)) 2)
+(check (letrec ([x 1]) (list (letrec ([x 2]) x) x)) '(2 1))
+(check-fail (letrec ([x y] [y x]) (list y x)) "undefined")
+
+(define (check-bad-lets let-id)
+ (check-fail (,let-id) bad-stx)
+ (check-fail (,let-id . x) bad-stx)
+ (check-fail (,let-id ()) bad-stx)
+ (check-fail (,let-id (x) x) bad-stx)
+ (check-fail (,let-id ([x]) x) bad-stx)
+ (check-fail (,let-id ([x . 1]) x) bad-stx)
+ (check-fail (,let-id ([x 1 . 2]) x) bad-stx)
+ (check-fail (,let-id ([x 1 2]) x) bad-stx)
+ (check-fail (,let-id ([1 2]) x) bad-stx)
+ (check-fail (,let-id ([x 2] . y) x) bad-stx)
+ (check-fail (,let-id ([x 2] y) x) bad-stx)
+ (check-fail (,let-id ([x 2])) bad-stx)
+ (check-fail (,let-id ([x 2]) . x) bad-stx)
+ (check-fail (,let-id ([x 2]) x . x) bad-stx)
+ (check-fail (,let-id ([x 2]) x x . x) bad-stx)
+ (check-fail ,let-id bad-stx))
+
+(check-bad-lets 'let)
+(check-bad-lets 'letrec)
+(check-bad-lets 'let*)
+
+(check (begin 1) 1)
+(check (begin 1 2) 2)
+(check (begin 1 2 3 4) 4)
+(check-fail (list (begin)) bad-stx)
+(check-fail (begin . 1) bad-stx)
+(check-fail (begin 1 2 3 . 4) bad-stx)
+(check-fail begin bad-stx)
+
+(check (and) #t)
+(check (and 1) 1)
+(check (and 1 2) 2)
+(check (and #f (quotient 1 0)) #f)
+(check-fail and bad-stx)
+(check-fail (and . 1) bad-stx)
+(check-fail (and 1 . 2) bad-stx)
+
+(check (or) #f)
+(check (or 1) 1)
+(check (or 1 2) 1)
+(check (or #f 2) 2)
+(check (or #t (quotient 1 0)) #t)
+(check-fail or bad-stx)
+(check-fail (or . 1) bad-stx)
+(check-fail (or 1 . 2) bad-stx)
+
+(check (when 1 2) 2)
+(check (when 1 2 3) 3)
+(check (when #f 2) (void))
+(check-fail when bad-stx)
+(check-fail (when . #t) bad-stx)
+(check-fail (when #t) bad-stx)
+(check-fail (when #t . 1) bad-stx)
+
+(check (unless 1 2) (void))
+(check (unless #f 2 3) 3)
+(check (unless #f 2) 2)
+(check-fail unless bad-stx)
+(check-fail (unless . #t) bad-stx)
+(check-fail (unless #t) bad-stx)
+(check-fail (unless #t . 1) bad-stx)
+
+(check (cond) (void))
+(check (cond [1 2]) 2)
+(check (cond [else 2]) 2)
+(check (cond [#f 2]) (void))
+(check (cond [#f 2] [#t 'ok]) 'ok)
+(check (cond [#f 2] [else 'ok]) 'ok)
+(check (cond [#f 1 2] [else 'yes 'ok]) 'ok)
+(check (cond [#t 1 2] [else 'yes 'ok]) 2)
+(check-fail cond bad-stx)
+(check-fail (cond . 1) bad-stx)
+(check-fail (cond []) bad-stx)
+(check-fail (cond [1]) bad-stx)
+(check-fail (cond [1 . 2]) bad-stx)
+(check-fail (cond [1 2] . 5) bad-stx)
+(check-fail (cond [else 2] [else 10]) "misplaced syntax")
+(check-fail else "misplaced syntax")
+
+(check `x 'x)
+(check `1 1)
+(check `() '())
+(check `((1 (#t x))) '((1 (#t x))))
+(check `,(+ 1 1) 2)
+(check `(1 ,(+ 1 1) 3) '(1 2 3))
+(check `(1 `,(+ 1 1) 3) '(1 `,(+ 1 1) 3))
+(check `(1 `,,(+ 1 1) 3) '(1 `,2 3))
+(check `(1 `,(0 . ,(+ 1 1)) 3) '(1 `,(0 . 2) 3))
+(check `(1 ,@(list 2 3) 4) '(1 2 3 4))
+(check `(,@(list 2 3) 4) '(2 3 4))
+(check `(,@(list 2 3) . 4) '(2 3 . 4))
+(check `(1 ,@4) '(1 . 4))
+(check `unquote 'unquote)
+(check `(1 . unquote) '(1 . unquote))
+(check-fail* 'unquote #f "misplaced syntax")
+(check-fail* 'unquote-splicing #f "misplaced syntax")
+(check-fail* '`(1 . ,@(list 2 3)) #f "misplaced splicing unquote")
+
+(check (module-path? (quote-module-path)))
+(check (pair? (member (cdr (split-path (quote-module-path))) '("form.zuo" "form-hygienic.zuo"))))+
+(define (reverse-rest x . y) (cons x (reverse y)))
+(check (reverse-rest 1 2 3) '(1 3 2))
+
+(define (combiner x [y (+ x 2)] [z (+ x y)] . rest)
+ (list z x rest))
+(check (combiner 1) '(4 1 ()))
+(check (combiner 1 10 20 30 40) '(20 1 (30 40)))
+
+(define (check-bad-defines define-id)
+ (check-fail ,define-id bad-stx)
+ (check-fail (,define-id) bad-stx)
+ (check-fail (,define-id . x) bad-stx)
+ (check-fail (,define-id x) bad-stx)
+ (check-fail (,define-id x 1 2) bad-stx)
+ (check-fail (,define-id x . 1) bad-stx)
+ (check-fail (,define-id x 1 . 2) bad-stx)
+ (check-fail (,define-id 1 1) bad-stx)
+ (check-fail (,define-id (x)) bad-stx)
+ (check-fail (,define-id (x) . 1) bad-stx)
+ (check-fail (,define-id (x) 1 . 2) bad-stx)
+ (check-fail (,define-id (1) 1) bad-stx)
+ (check-fail (,define-id (x . 1) 1) bad-stx)
+ (check-fail (,define-id (x 1) 1) bad-stx)
+ (check-fail (,define-id (x [y]) 1) bad-stx)
+ (check-fail (,define-id (x [y 1 2]) 1) bad-stx)
+ (check-fail (,define-id (x [y . 1]) 1) bad-stx)
+ (check-fail (,define-id ([y 1] x) 1) bad-stx))
+
+(check-bad-defines 'define)
+(check-bad-defines 'define-syntax)
+
+(define bad-macro "not a procedure or context consumer")
+
+(check-fail (define-syntax whatever 19) "not a procedure or context consumer")
+
+(check-fail (context-consumer 19) "not a procedure")
--- /dev/null
+++ b/tests/form-hygienic.zuo
@@ -1,0 +1,7 @@
+#lang zuo/hygienic
+
+(require "harness-hygienic.zuo")
+
+(alert "syntactic forms, hygienic expander")
+
+(include "form-common.zuo")
--- /dev/null
+++ b/tests/form.zuo
@@ -1,0 +1,7 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "syntactic forms")
+
+(include "form-common.zuo")
--- /dev/null
+++ b/tests/glob.zuo
@@ -1,0 +1,88 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "glob")
+
+(check (glob-match? "apple" "apple"))
+(check (glob-match? "apple" "banana") #f)
+
+(check (glob-match? "" ""))
+(check (glob-match? "" "x") #f)
+(check (glob-match? "x" "") #f)
+
+(check (glob-match? "a*le" "apple"))
+(check (glob-match? "a*le" "ale"))
+(check (glob-match? "a*le" "aple"))
+(check (glob-match? "a*le" "a//p//le"))
+(check (glob-match? "a*le" "appe") #f)
+(check (glob-match? "a*le" "pple") #f)
+
+(check (glob-match? "a*?le" "apple"))
+(check (glob-match? "a*?le" "aple"))
+(check (glob-match? "a*?le" "ale") #f)
+
+(check (glob-match? "*le" "apple"))
+(check (glob-match? "*le" ".apple"))
+
+(check (glob-match? "*le" "apple"))
+(check (glob-match? "*le" ".apple"))
+
+(check (glob-match? "x[a-c]x" "x0x") #f)
+(check (glob-match? "x[a-c]x" "xax"))
+(check (glob-match? "x[a-c]x" "xbx"))
+(check (glob-match? "x[a-c]x" "xcx"))
+(check (glob-match? "x[a-c]x" "xdx") #f)
+(check (glob-match? "x[a-c]x" "x[x") #f)
+(check (glob-match? "x[a-c]x" "x]x") #f)
+
+(check (glob-match? "x[0-9][A-Z]x" "x0Ax"))
+(check (glob-match? "x[0-9][A-Z]x" "x9Zx"))
+(check (glob-match? "x[0-9][A-Z]x" "xA0x") #f)
+
+(check (glob-match? "x[0-9a]x" "x0x"))
+(check (glob-match? "x[0-9a]x" "xax"))
+(check (glob-match? "x[0-9a]x" "xbx") #f)
+(check (glob-match? "x[0-9a]x" "x-x") #f)
+(check (glob-match? "x[-0-9a]x" "x-x"))
+(check (glob-match? "x[0-9a-]x" "x-x"))
+(check (glob-match? "x[]0-9a]x" "x]x"))
+(check (glob-match? "x[]0-9a]x" "x0x"))
+(check (glob-match? "x[]0-9a]x" "x[x") #f)
+(check (glob-match? "x[a-]x" "x-x"))
+(check (glob-match? "x[a-]x" "x.x") #f)
+
+(check (glob-match? "x[^0-9a]x" "x_x"))
+(check (glob-match? "x[^0-9a]x" "x0x") #f)
+(check (glob-match? "x[^0-9a]x" "x5x") #f)
+(check (glob-match? "x[^0-9a]x" "x9x") #f)
+(check (glob-match? "x[^0-9a]x" "xax") #f)
+(check (glob-match? "x[^0-9a]x" "xbx"))
+(check (glob-match? "x[^0-9a]x" "xbx"))
+(check (glob-match? "x[^^]x" "xbx"))
+(check (glob-match? "x[^^]x" "x^x") #f)
+(check (glob-match? "x[^-]x" "x-x") #f)
+(check (glob-match? "x[^x]x" "x-x"))
+(check (glob-match? "x[^]]x" "x]x") #f)
+(check (glob-match? "x[^]]x" "x-x"))
+
+(check (glob-match? "**e" "apple"))
+(check (glob-match? "**" "apple"))
+(check (glob-match? "**z" "apple") #f)
+
+(check (procedure? (glob->matcher "a*c")))
+(check ((glob->matcher "a*c") "abxyzc"))
+
+(define-syntax (check-glob-fail stx)
+ `(check-fail (begin
+ (require zuo/glob)
+ ,(cadr stx))
+ ,(list-ref stx 2)))
+
+(check-glob-fail (glob-match? 10 "a") not-string)
+(check-glob-fail (glob-match? "a" 10) not-string)
+(check-glob-fail (glob->matcher 10) not-string)
+(check-glob-fail (glob->matcher "[") "unclosed square bracket")
+(check-glob-fail (glob->matcher "[]") "unclosed square bracket")
+(check-glob-fail (glob->matcher "[^]") "unclosed square bracket")
+(check-glob-fail (glob->matcher "[z-a]") "bad range")
--- /dev/null
+++ b/tests/harness-common.zuo
@@ -1,0 +1,138 @@
+#lang zuo/datum
+
+(provide check
+ check-fail
+ check-fail*
+ check-arg-fail
+ check-output
+
+ run-zuo*
+ run-zuo
+ contains?
+
+ bad-stx
+ arity
+ not-integer
+ not-string
+ not-path
+
+ tmp-dir)
+
+(define (check* e a b)
+ (unless (equal? a b)
+ (error (~a "failed: "
+ (~s e)
+ "\n result: " (~v a)
+ "\n result: " (~v b)))))
+
+(define-syntax (check stx)
+ (unless (list? stx) (bad-syntax stx))
+ (list* (quote-syntax check*)
+ (list (quote-syntax quote) stx)
+ (let ([len (length (cdr stx))])
+ (cond
+ [(= 1 len) (cons #t (cdr stx))]
+ [(= 2 len) (cdr stx)]
+ [else (bad-syntax stx)]))))
+
+(define (run-zuo* args input k)
+ (define p (apply process
+ (cons (hash-ref (runtime-env) 'exe #f)
+ (append args
+ (list (hash 'stdin 'pipe 'stdout 'pipe 'stderr 'pipe))))))
+ (fd-write (hash-ref p 'stdin) input)
+ (fd-close (hash-ref p 'stdin))
+ (define out (fd-read (hash-ref p 'stdout) eof))
+ (define err (fd-read (hash-ref p 'stderr) eof))
+ (fd-close (hash-ref p 'stdout))
+ (fd-close (hash-ref p 'stderr))
+ (process-wait (hash-ref p 'process))
+ (k (process-status (hash-ref p 'process)) out err))
+
+(define (run-zuo e k)
+ (run-zuo* '("") (~a "#lang " language-name " " (~s e)) k))+
+(define (contains? err msg)
+ (let loop ([i 0])
+ (and (not (> i (- (string-length err) (string-length msg))))
+ (or (string=? (substring err i (+ i (string-length msg))) msg)
+ (loop (+ i 1))))))
+
+(define (check-fail* e who msg)
+ (run-zuo
+ e
+ (lambda (status out err)
+ (when (= 0 status)
+ (error (~a "check-fail: failed to fail: " (~s e)
+ "\n stdout: " (~s out)
+ "\n stderr: " (~s err))))
+ (unless (contains? err msg)
+ (error (~a "check-fail: didn't find expected message: " (~s e)
+ "\n expected: " (~s msg)
+ "\n stderr: " (~s err))))
+ (when who
+ (let* ([who (symbol->string who)]
+ [len (string-length who)])
+ (unless (and (> (string-length err) len)
+ (string=? (substring err 0 len) who))
+ (error (~a "check-fail: didn't find expected who: " (~s e)
+ "\n expected: " who
+ "\n stderr: " (~s err)))))))))
+
+(define-syntax (check-fail stx)
+ (unless (and (list? stx) (= 3 (length stx))) (bad-syntax stx))
+ (list (quote-syntax check-fail*)
+ (list (quote-syntax quasiquote) (cadr stx))
+ #f
+ (cadr (cdr stx))))
+
+(define-syntax (check-arg-fail stx)
+ (unless (and (list? stx) (= 3 (length stx))
+ (pair? (cadr stx)) (identifier? (car (cadr stx))))
+ (bad-syntax stx))
+ (list (quote-syntax check-fail*)
+ (list (quote-syntax quasiquote) (cadr stx))
+ (list (quote-syntax quote) (car (cadr stx)))
+ (cadr (cdr stx))))
+
+(define (check-output* e stdout stderr)
+ (run-zuo
+ e
+ (lambda (status out err)
+ (unless ((if (equal? stderr "") (lambda (v) v) not)
+ (= 0 status))
+ (error (~a "check-output: process failed: " (~s e)
+ "\n stdout: " (~s out)
+ "\n stderr: " (~s err))))
+ (unless (and (equal? out stdout)
+ (equal? err stderr))
+ (error (~a "check-output: process failed: " (~s e)
+ "\n stdout: " (~s out)
+ "\n expect: " (~s stdout)
+ "\n stderr: " (~s err)
+ "\n expect: " (~s stderr)))))))
+
+(define-syntax (check-output stx)
+ (unless (list? stx) (bad-syntax stx))
+ (cond
+ [(= 3 (length stx))
+ (list (quote-syntax check-output*)
+ (list (quote-syntax quote) (cadr stx))
+ (list-ref stx 2)
+ "")]
+ [(= 4 (length stx))
+ (list (quote-syntax check-output*)
+ (list (quote-syntax quote) (cadr stx))
+ (list-ref stx 2)
+ (list-ref stx 3))]
+ [else (bad-syntax stx)]))
+
+;; Some common error messages
+(define bad-stx "bad syntax")
+(define arity "wrong number of arguments")
+(define not-integer "not an integer")
+(define not-string "not a string")
+(define not-path "not a path string")
+
+(define tmp-dir (build-path (car (split-path (quote-module-path))) ".." "build" "tmp"))
+(mkdir-p tmp-dir)
--- /dev/null
+++ b/tests/harness-hygienic.zuo
@@ -1,0 +1,5 @@
+#lang zuo/hygienic
+
+(define language-name 'zuo/hygienic)
+
+(include "harness-common.zuo")
--- /dev/null
+++ b/tests/harness.zuo
@@ -1,0 +1,5 @@
+#lang zuo
+
+(define language-name 'zuo/base)
+
+(include "harness-common.zuo")
--- /dev/null
+++ b/tests/hash.zuo
@@ -1,0 +1,52 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "hash tables")
+
+(check (hash? (hash)))
+(check (not (hash? 'apple)))
+
+(check (hash-ref (hash 'a 1) 'a #f) 1)
+(check (hash-ref (hash 'a 1) 'b #f) #f)
+(check (hash-ref (hash 'a 1) 'b 'no) 'no)
+(check-arg-fail (hash-ref 0 0 0) "not a hash table")
+(check-arg-fail (hash-ref (hash) 0 0) "not a symbol")
+
+(check (hash-set (hash 'a 1) 'b 2) (hash 'a 1 'b 2))
+(check (hash-ref (hash-set (hash 'a 1) 'b 2) 'a #f) 1)
+(check (hash-ref (hash-set (hash 'a 1) 'b 2) 'b #f) 2)
+(check (hash-ref (hash-set (hash 'a 1) 'b 2) 'c #f) #f)
+(check-arg-fail (hash-set 0 0 0) "not a hash table")
+(check-arg-fail (hash-set (hash) 0 0) "not a symbol")
+
+(check (hash-remove (hash 'a 1) 'a) (hash))
+(check (hash-remove (hash 'a 1) 'b) (hash 'a 1))
+(check (hash-remove (hash 'a 1 'b 2) 'a) (hash 'b 2))
+(check (hash-ref (hash-remove (hash 'a 1) 'a) 'a #f) #f)
+(check-arg-fail (hash-remove 0 0) "not a hash table")
+(check-arg-fail (hash-remove (hash) 0) "not a symbol")
+
+(check (hash-count (hash)) 0)
+(check (hash-count (hash 'a 1 'a 2 'b 3)) 2)
+(check (hash-count (hash-set (hash 'a 1 'b 3) 'c 3)) 3)
+(check (hash-count (hash-remove (hash 'a 1 'b 3) 'b)) 1)
+(check-arg-fail (hash-count 0) "not a hash table")
+
+(check (hash-keys (hash)) '())
+(check (hash-keys (hash 'a 1)) '(a))
+(check (let ([keys (hash-keys (hash 'a 1 'b 2))])
+ (or (equal? keys '(a b))
+ (equal? keys '(b a)))))
+(check (length (hash-keys (hash 'a 1 'b 2 'c 3))) 3)
+(check (length (hash-keys (hash 'a 1 'b 2 'a 3))) 2)
+(check-arg-fail (hash-keys 0) "not a hash table")
+
+(check (hash-keys-subset? (hash) (hash 'a 1)) #t)
+(check (hash-keys-subset? (hash 'a 1) (hash)) #f)
+(check (hash-keys-subset? (hash 'a 1) (hash 'a 1 'b 2)) #t)
+(check (hash-keys-subset? (hash 'b 2) (hash 'a 1 'b 2)) #t)
+(check (hash-keys-subset? (hash 'a 1 'b 2) (hash 'a 1)) #f)
+(check (hash-keys-subset? (hash 'a 1 'b 2) (hash 'b 1)) #f)
+(check-arg-fail (hash-keys-subset? 0 (hash)) "not a hash table")
+(check-arg-fail (hash-keys-subset? (hash) 0) "not a hash table")
--- /dev/null
+++ b/tests/image.zuo
@@ -1,0 +1,30 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "image")
+
+(define dump.zuo (build-path tmp-dir "dump.zuo"))
+(define image-file (build-path tmp-dir "image.boot"))
+
+(define (try-dump lang)
+ (define out (fd-open-output dump.zuo :truncate))
+ (fd-write out (~a "#lang " lang "\n"
+ "(dump-image-and-exit (fd-open-output (car (hash-ref (runtime-env) 'args)) :truncate))\n"))
+ (fd-close out)
+
+ (check (run-zuo* (list dump.zuo image-file)
+ ""
+ (lambda (status out err)
+ (= status 0))))
+ (run-zuo* (list "-X" "" "-B" image-file "")
+ (~a "#lang " lang " 10")
+ (lambda (status out err)
+ (check (and (= status 0) lang) lang)
+ (check out "10\n")
+ (check err ""))))
+
+(try-dump "zuo")
+(try-dump "zuo/hygienic")
+
+(check-arg-fail (dump-image-and-exit "oops") "open output file")
--- /dev/null
+++ b/tests/integer.zuo
@@ -1,0 +1,159 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "predicate")
+
+(check (integer? 10))
+(check (not (integer? 'a)))
+(check (not (integer? '(1 . 2))))
+
+(alert "arithmetic")
+
+(check (+ 1 2) 3)
+(check (+ 1 -2) -1)
+(check (+ 1 2 3 4) 10)
+(check (+) 0)
+(check (+ 1) 1)
+(check (+ 4294967296 1) 4294967297)
+(check (+ -4294967296 1) -4294967295)
+(check (+ 4294967296 1) 4294967297)
+(check (+ -9223372036854775808 1) -9223372036854775807)
+(check (- -9223372036854775808 1) 9223372036854775807)
+(check (+ 9223372036854775807 1) -9223372036854775808)
+(check-arg-fail (+ 1 'apple) not-integer)
+
+(check (- 2 1) 1)
+(check (- 2 -1) 3)
+(check (- 1 2 3 4) -8)
+(check (- 1) -1)
+(check (- 0) 0)
+(check (- -9223372036854775808) -9223372036854775808)
+(check (- -9223372036854775807) 9223372036854775807)
+(check-arg-fail (-) arity)
+(check-arg-fail (- 1 'apple) not-integer)
+
+(check (* 10 2) 20)
+(check (* 10 -2) -20)
+(check (* 1 2 3 4) 24)
+(check (*) 1)
+(check (* 10) 10)
+(check (* 10 0) 0)
+(check (* 4294967296 4294967296) 0)
+(check (* 4294967296 -4294967296) 0)
+(check (* 4294967296 4294967297) 4294967296)
+(check (* 4294967296 -4294967297) -4294967296)
+(check (* 2147483648 4294967296) -9223372036854775808)
+(check (* -9223372036854775808 1) -9223372036854775808)
+(check (* -9223372036854775808 -1) -9223372036854775808)
+(check (* 9223372036854775807 -1) -9223372036854775807)
+(check (* -9223372036854775807 -1) 9223372036854775807)
+(check-arg-fail (* 1 'apple) not-integer)
+
+(check (quotient 5 2) 2)
+(check (quotient 1 2) 0)
+(check (quotient -5 2) -2)
+(check (quotient 5 -2) -2)
+(check (quotient -9223372036854775808 4294967296) -2147483648)
+(check (quotient -9223372036854775808 1) -9223372036854775808)
+(check (quotient -9223372036854775808 -1) -9223372036854775808)
+(check (quotient 9223372036854775807 -1) -9223372036854775807)
+(check (quotient -9223372036854775807 -1) 9223372036854775807)
+(check-arg-fail (quotient -5) arity)
+(check-arg-fail (quotient 5 'apple) not-integer)
+(check-arg-fail (quotient 5 0) "divide by zero")
+
+(check (modulo 5 2) 1)
+(check (modulo 2 2) 0)
+(check (modulo -5 2) -1)
+(check (modulo 5 -2) 1)
+(check (modulo -9223372036854775808 1) 0)
+(check (modulo -9223372036854775808 -1) 0)
+(check (modulo 9223372036854775807 -1) 0)
+(check (modulo -9223372036854775807 -1) 0)
+(check (modulo -9223372036854775808 9223372036854775807) -1)
+(check (modulo 9223372036854775807 -9223372036854775808) 9223372036854775807)
+(check-arg-fail (modulo -5) arity)
+(check-arg-fail (modulo 5 'apple) not-integer)
+(check-arg-fail (modulo 5 0) "divide by zero")
+
+(alert "ordering")
+
+(check (= 1 1))
+(check (= -9223372036854775808 -9223372036854775808))
+
+(check (<= 1 1))
+(check (<= 1 2))
+(check (<= -2 -1))
+(check (not (<= -1 -2)))
+(check (<= -9223372036854775808 -9223372036854775808))
+(check (<= -9223372036854775808 9223372036854775807))
+(check (not (<= 9223372036854775807 -9223372036854775808)))
+(check-arg-fail (<= 'apple 5) not-integer)
+(check-arg-fail (<= 5 'apple) not-integer)
+
+(check (not (< 1 1)))
+(check (< 1 2))
+(check (< -2 -1))
+(check (not (< -1 -2)))
+(check (not (< -9223372036854775808 -9223372036854775808)))
+(check (< -9223372036854775808 9223372036854775807))
+(check (not (< 9223372036854775807 -9223372036854775808)))
+(check-arg-fail (< 'apple 5) not-integer)
+(check-arg-fail (< 5 'apple) not-integer)
+
+(check (not (> 1 1)))
+(check (> 2 1))
+(check (> -1 -2))
+(check (not (> -2 -1)))
+(check (not (> -9223372036854775808 -9223372036854775808)))
+(check (> 9223372036854775807 -9223372036854775808))
+(check (not (> -9223372036854775808 9223372036854775807)))
+(check-arg-fail (> 'apple 5) not-integer)
+(check-arg-fail (> 5 'apple) not-integer)
+
+(check (>= 1 1))
+(check (>= 2 1))
+(check (>= -1 -2))
+(check (not (>= -2 -1)))
+(check (>= -9223372036854775808 -9223372036854775808))
+(check (>= 9223372036854775807 -9223372036854775808))
+(check (not (>= -9223372036854775808 9223372036854775807)))
+(check-arg-fail (>= 'apple 5) not-integer)
+(check-arg-fail (>= 5 'apple) not-integer)
+
+(alert "bitwise")
+
+(check 1 (bitwise-and 3 1))
+(check 0 (bitwise-and 2 1))
+(check 42 (bitwise-and -1 42))
+(check -42 (bitwise-and -1 -42))
+(check 0 (bitwise-and -1 0))
+(check 0 (bitwise-and -9223372036854775808 9223372036854775807))
+(check-arg-fail (bitwise-and 'apple 5) not-integer)
+(check-arg-fail (bitwise-and 5 'apple) not-integer)
+
+(check 3 (bitwise-ior 3 1))
+(check 3 (bitwise-ior 2 1))
+(check -1 (bitwise-ior -1 42))
+(check 42 (bitwise-ior 0 42))
+(check -42 (bitwise-ior 0 -42))
+(check -1 (bitwise-ior -9223372036854775808 9223372036854775807))
+(check-arg-fail (bitwise-ior 'apple 5) not-integer)
+(check-arg-fail (bitwise-ior 5 'apple) not-integer)
+
+(check 2 (bitwise-xor 3 1))
+(check 3 (bitwise-xor 2 1))
+(check -43 (bitwise-xor -1 42))
+(check 42 (bitwise-xor 0 42))
+(check -42 (bitwise-xor 0 -42))
+(check -1 (bitwise-xor -9223372036854775808 9223372036854775807))
+(check-arg-fail (bitwise-xor 'apple 5) not-integer)
+(check-arg-fail (bitwise-xor 5 'apple) not-integer)
+
+(check -1 (bitwise-not 0))
+(check 0 (bitwise-not -1))
+(check 41 (bitwise-not -42))
+(check -43 (bitwise-not 42))
+(check 9223372036854775807 (bitwise-not -9223372036854775808))
+(check-arg-fail (bitwise-not 'apple) not-integer)
--- /dev/null
+++ b/tests/kernel.zuo
@@ -1,0 +1,93 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "kernel eval")
+
+(define bad-kernel-stx "bad kernel syntax")
+
+(check (kernel-eval 1) 1)
+(check (kernel-eval 'cons) cons)
+
+(check (kernel-eval '(cons 1 2)) '(1 . 2))
+(check-fail (kernel-eval '(cons 1 . 2)) bad-kernel-stx)
+(check-fail (kernel-eval '(cons . 2)) bad-kernel-stx)
+
+(check (procedure? (kernel-eval '(lambda (x) x))) #t)
+(check (procedure? (kernel-eval '(lambda (x x) x))) #t)
+(check (procedure? (kernel-eval '(lambda (x . x) x))) #t)
+(check (procedure? (kernel-eval '(lambda (x x) "name" x))) #t)
+(check ((kernel-eval '(lambda (x x) x)) #f 2) 2)
+(check ((kernel-eval '(lambda (x x . x) x)) #f 2 3 4) '(3 4))
+(check-fail (kernel-eval '(lambda)) bad-kernel-stx)
+(check-fail (kernel-eval '(lambda . x)) bad-kernel-stx)
+(check-fail (kernel-eval '(lambda x)) bad-kernel-stx)
+(check-fail (kernel-eval '(lambda (x x))) bad-kernel-stx)
+(check-fail (kernel-eval '(lambda (x x . x) . x)) bad-kernel-stx)
+(check-fail (kernel-eval '(lambda (x y . x) . x)) bad-kernel-stx)
+(check-fail (kernel-eval '(lambda (x x . 5) x)) bad-kernel-stx)
+(check-fail (kernel-eval '(lambda 5 x)) bad-kernel-stx)
+(check-fail (kernel-eval '(lambda x #f 2)) bad-kernel-stx)
+(check-fail (kernel-eval '(lambda x #f . 2)) bad-kernel-stx)
+(check-fail (kernel-eval 'lambda) "undefined: 'lambda")
+(check (((kernel-eval '(lambda (lambda) (lambda x x))) 1) 2) '(2))
+
+(check (kernel-eval '(quote cons)) 'cons)
+(check-fail (kernel-eval '(quote)) bad-kernel-stx)
+(check-fail (kernel-eval '(quote cons list)) bad-kernel-stx)
+(check-fail (kernel-eval '(quote . cons)) bad-kernel-stx)
+(check-fail (kernel-eval '(quote cons . list)) bad-kernel-stx)
+(check-fail (kernel-eval 'quote) "undefined: 'quote")
+
+(check (kernel-eval '(if #t 1 2)) 1)
+(check (kernel-eval '(if 0 1 2)) 1)
+(check (kernel-eval '(if #f 1 2)) 2)
+(check-fail (kernel-eval '(if)) bad-kernel-stx)
+(check-fail (kernel-eval '(if . 1)) bad-kernel-stx)
+(check-fail (kernel-eval '(if 1)) bad-kernel-stx)
+(check-fail (kernel-eval '(if 1 . 2)) bad-kernel-stx)
+(check-fail (kernel-eval '(if 1 2)) bad-kernel-stx)
+(check-fail (kernel-eval '(if 1 2 . 3)) bad-kernel-stx)
+(check-fail (kernel-eval '(if 1 2 3 . 4)) bad-kernel-stx)
+(check-fail (kernel-eval '(if 1 2 3 4)) bad-kernel-stx)
+(check-fail (kernel-eval 'if) "undefined: 'if")
+
+(check (kernel-eval '(let ([x 1]) x)) 1)
+(check (kernel-eval '(let ([x 1]) (let ([x 2]) x))) 2)
+(check (kernel-eval '(let ([x 1]) (list (let ([x 2]) x) x))) '(2 1))
+(check-fail (kernel-eval '(let)) bad-kernel-stx)
+(check-fail (kernel-eval '(let . x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ())) bad-kernel-stx)
+(check-fail (kernel-eval '(let () x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let (x) x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x]) x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x . 1]) x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x 1 . 2]) x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x 1 2]) x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([1 2]) x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x 2] . y) x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x 2] y) x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x 2]))) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x 2]) . x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x 2]) x . x)) bad-kernel-stx)
+(check-fail (kernel-eval '(let ([x 2]) x x)) bad-kernel-stx)
+(check-fail (kernel-eval 'let) "undefined: 'let")
+
+(check (kernel-eval '(begin 1)) 1)
+(check (kernel-eval '(begin 1 2)) 2)
+(check (kernel-eval '(begin 1 2 3 4)) 4)
+(check-fail (kernel-eval '(begin)) bad-kernel-stx)
+(check-fail (kernel-eval '(begin . 1)) bad-kernel-stx)
+(check-fail (kernel-eval '(begin 1 2 3 . 4)) bad-kernel-stx)
+(check-fail (kernel-eval 'begin) "undefined: 'begin")
+
+(check (andmap (lambda (k)
+ (eq? (kernel-eval k) (hash-ref (kernel-env) k #f)))
+ (hash-keys (kernel-env))))
+
+(check (kernel-eval
+ (let loop ([i 10000])
+ (if (= i 0)
+ "ok"
+ `(kernel-eval ',(loop (- i 1))))))
+ "ok")
--- /dev/null
+++ b/tests/macro-common.zuo
@@ -1,0 +1,103 @@
+#lang zuo/datum
+
+(define macro-dir (build-path tmp-dir "macros"))
+(rm* macro-dir)
+(mkdir macro-dir)
+
+(check ((lambda lambda lambda) 3) '(3))
+(check (let ([let 10]) let) 10)
+(check (let ([let 11]) (let* ([let let]) let)) 11)
+(check (let ([quote list]) '1) '(1))
+
+(let ()
+ (define-syntax (let-one stx)
+ (list (quote-syntax let)
+ (list (list (cadr stx) 1))
+ (cadr (cdr stx))))
+ (check (let-one x (list x x)) '(1 1))
+ (check (let-one x (let ([let 0]) (list x let x))) '(1 0 1)))
+
+(let ([five 5])
+ (define-syntax (let-five stx)
+ (list (quote-syntax let)
+ (list (list (cadr stx) (quote-syntax five)))
+ (cadr (cdr stx))))
+ (check (let-five x (list x x)) '(5 5))
+ (check (let-five x (let ([five 10]) (list x x))) '(5 5))
+ (check (let ([five 10]) (let-five x (list x x))) '(5 5)))
+
+(define (make-file* path content)
+ (let ([fd (fd-open-output (build-path macro-dir path) :truncate)])
+ (fd-write fd (~a "#lang " lang-name "\n"
+ (~s (cons 'begin content))))
+ (fd-close fd)))
+
+(define-syntax (make-file stx)
+ (list (quote-syntax make-file*)
+ (cadr stx)
+ (cons (quote-syntax list)
+ (map (lambda (c) (list (quote-syntax quote) c))
+ (cddr stx)))))
+
+(make-file "exports-macro.zuo"
+ (provide macro)
+ (define (my-list . x) x)
+ (define-syntax (macro stx)
+ (list (quote-syntax my-list)
+ (cadr stx)
+ (cadr stx))))
+
+(make-file "uses-macro.zuo"
+ (require "exports-macro.zuo")
+ (provide macro-to-macro)
+ (define hello "hi")
+ (macro hello)
+ (define-syntax (macro-to-macro stx)
+ (list (quote-syntax list)
+ (list (quote-syntax macro) (cadr stx))
+ (list (quote-syntax macro) (cadr stx)))))
+
+(run-zuo* (list (build-path macro-dir "uses-macro.zuo"))
+ ""
+ (lambda (status out err)
+ (check err "")
+ (check status 0)
+ (check out "(list \"hi\" \"hi\")\n")))
+
+(make-file "uses-macro-to-macro.zuo"
+ (require "uses-macro.zuo")
+ (define-syntax (go stx) (quote-syntax 'went))
+ (macro-to-macro go))
+
+(run-zuo* (list (build-path macro-dir "uses-macro-to-macro.zuo"))
+ ""
+ (lambda (status out err)
+ (check err "")
+ (check status 0)
+ (check out "(list \"hi\" \"hi\")\n(list (list 'went 'went) (list 'went 'went))\n")))
+
+(make-file "exports-helper.zuo"
+ (provide doubled)
+ (define (my-list . x) x)
+ (define (doubled stx)
+ (list (quote-syntax my-list)
+ stx
+ stx)))
+
+(make-file "uses-helper.zuo"
+ (provide macro)
+ (require "exports-helper.zuo")
+ (define-syntax (macro stx)
+ (doubled (cadr stx))))
+
+(make-file "uses-macro-with-helper.zuo"
+ (require "uses-helper.zuo")
+ (define hello "hi")
+ (macro hello))
+
+(run-zuo* (list (build-path macro-dir "uses-macro-with-helper.zuo"))
+ ""
+ (lambda (status out err)
+ (check err "")
+ (check status 0)
+ (check out "(list \"hi\" \"hi\")\n")))
--- /dev/null
+++ b/tests/macro-hygienic.zuo
@@ -1,0 +1,28 @@
+#lang zuo/hygienic
+
+(require "harness-hygienic.zuo")
+
+(alert "macros, hygienic expander")
+
+(define lang-name 'zuo/hygienic)
+
+(include "macro-common.zuo")
+
+(define module-five 5)
+(define-syntax (let-module-five stx)
+ (list (quote-syntax let)
+ (list (list (cadr stx) 'module-five)) ; coerced to defining context
+ (cadr (cdr stx))))
+(check (let-module-five x (list x x)) '(5 5))
+(check (let-module-five x (let ([module-five 10]) (list x x))) '(5 5))
+(check (let ([module-five 10]) (let-module-five x (list x x))) '(5 5))
+
+(let ([five 5])
+ (define-syntax (let-five stx)
+ (list (quote-syntax let)
+ (list (list (cadr stx) (datum->syntax (car stx) 'five))) ; non-hygienic
+ (cadr (cdr stx))))
+ (check (let-five x (list x x)) '(5 5))
+ (check (let-five x (let ([five 10]) (list x x))) '(5 5))
+ (check (let ([five 10]) (let-five x (list x x))) '(10 10)))
+
--- /dev/null
+++ b/tests/macro.zuo
@@ -1,0 +1,19 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "macros")
+
+(define lang-name 'zuo)
+
+(include "macro-common.zuo")
+
+(let ([five 5])
+ (define-syntax (let-five stx)
+ (list (quote-syntax let)
+ (list (list (cadr stx) 'five)) ; can get captured
+ (cadr (cdr stx))))
+ (check (let-five x (list x x)) '(5 5))
+ (check (let-five x (let ([five 10]) (list x x))) '(5 5))
+ (check (let ([five 10]) (let-five x (list x x))) '(10 10)))
+
--- /dev/null
+++ b/tests/main.zuo
@@ -1,0 +1,31 @@
+#lang zuo
+
+(require "equal.zuo")
+(require "integer.zuo")
+(require "pair.zuo")
+(require "string.zuo")
+(require "symbol.zuo")
+(require "hash.zuo")
+(require "procedure.zuo")
+(require "path.zuo")
+(require "opaque.zuo")
+(require "variable.zuo")
+(require "module-path.zuo")
+(require "kernel.zuo")
+(require "read+print.zuo")
+(require "syntax.zuo")
+(require "syntax-hygienic.zuo")
+(require "file-handle.zuo")
+(require "process.zuo")
+(require "filesystem.zuo")
+(require "cleanable.zuo")
+(require "image.zuo")
+(require "shell.zuo")
+(require "c.zuo")
+(require "cycle.zuo")
+(require "form.zuo")
+(require "form-hygienic.zuo")
+(require "macro.zuo")
+(require "macro-hygienic.zuo")
+
+(alert "... tests passed!")
--- /dev/null
+++ b/tests/module-path.zuo
@@ -1,0 +1,64 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "module paths")
+
+(check (module-path? 'zuo))
+(check (module-path? 'zuo/main))
+(check (module-path? 'zuo/private/main))
+(check (module-path? '/zuo) #f)
+(check (module-path? 'zuo/) #f)
+(check (module-path? 'zuo//main) #f)
+(check (module-path? 'zuo?) #f)
+(check (module-path? 'zuo/?/x) #f)
+
+(check (module-path? "main.zuo"))
+(check (module-path? "private/main.zuo"))
+(check (module-path? "private/../main.zuo"))
+(check (module-path? "./../main.zuo"))
+(check (module-path? "main"))
+(check (module-path? "main.rkt"))
+(check (module-path? " main.zuo "))
+(check (module-path? "") #f)
+(check (module-path? "a\0b") #f)
+
+(check (module-path? 1) #f)
+(check (module-path? '(zuo)) #f)
+
+(check (build-module-path 'zuo "list.zuo") 'zuo/list)
+(check (build-module-path 'zuo/main "list.zuo") 'zuo/list)
+(check (build-module-path 'zuo/private/main "list.zuo") 'zuo/private/list)
+(check (build-module-path 'zuo "helper/list.zuo") 'zuo/helper/list)
+(check (build-module-path 'zuo/main "helper/list.zuo") 'zuo/helper/list)
+(check (build-module-path 'zuo/private/main "helper/list.zuo") 'zuo/private/helper/list)
+(check (build-module-path 'zuo/private/main "../list.zuo") 'zuo/list)
+(check (build-module-path 'zuo/private/main "./list.zuo") 'zuo/private/list)
+(check (build-module-path 'zuo/private/main "./././../././list.zuo") 'zuo/list)
+(check-arg-fail (build-module-path 'zuo "list") "lacks \".zuo\"")
+(check-arg-fail (build-module-path 'zuo "../list.zuo") "too many up elements")
+(check-arg-fail (build-module-path 'zuo "x//list.zuo") "not a relative module library path")
+(check-arg-fail (build-module-path 'zuo "..//list.zuo") "not a relative module library path")
+(check-arg-fail (build-module-path 'zuo "list@.zuo") "not a relative module library path")
+(check-arg-fail (build-module-path 'zuo "@/list.zuo") "not a relative module library path")
+(check-arg-fail (build-module-path 'zuo "list.rkt") "not a relative module library path")
+(check-arg-fail (build-module-path 'zuo "x.y/list.zuo") "not a relative module library path")
+
+(check (build-module-path "lib/zuo/main.zuo" "list.zuo") "lib/zuo/list.zuo")
+(check (build-module-path "lib/zuo/main.zuo" "../list.zuo") "lib/list.zuo")
+(check (build-module-path "lib.zuo" "list.zuo") "list.zuo")
+(check-arg-fail (build-module-path "lib/zuo/main.zuo" "list") "lacks \".zuo\"")
+(check-arg-fail (build-module-path "lib/zuo/main.zuo" "x//list.zuo") "not a relative module library path")
+(check-arg-fail (build-module-path "lib/zuo/main.zuo" "..//list.zuo") "not a relative module library path")
+(check-arg-fail (build-module-path "lib/zuo/main.zuo" "list@.zuo") "not a relative module library path")
+(check-arg-fail (build-module-path "lib/zuo/main.zuo" "@/list.zuo") "not a relative module library path")
+(check-arg-fail (build-module-path "lib/zuo/main.zuo" "list.rkt") "not a relative module library path")
+(check-arg-fail (build-module-path "lib/zuo/main.zuo" "x.y/list.zuo") "not a relative module library path")
+
+(check-arg-fail (build-module-path "" "x.zuo") "not a module path")
+(check-arg-fail (build-module-path 1 "x.zuo") "not a module path")
+(check-arg-fail (build-module-path "main.zuo" 1) "not a module path")
+(check-arg-fail (build-module-path 'zuo 1) "not a module path")
+
+(check (hash? (module->hash 'zuo)))
+(check-arg-fail (module->hash 8) "not a module path")
--- /dev/null
+++ b/tests/opaque.zuo
@@ -1,0 +1,15 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "opaque records")
+
+(check (not (pair? (opaque 'hello "hi"))))
+
+(check (opaque-ref 'hello (opaque 'hello "hi") #f) "hi")
+(check (opaque-ref 'not-hello (opaque 'hello "hi") #f) #f)
+(check (opaque-ref (string->uninterned-symbol "hello") (opaque 'hello "hi") #f) #f)
+(check (opaque-ref 'hello (opaque (string->uninterned-symbol "hello") "hi") #f) #f)
+(check (opaque-ref (opaque 'hello "hi") 'hello #f) #f)
+(check (opaque-ref 10 10 #f) #f)
+(check (opaque-ref 10 10 'no) 'no)
--- /dev/null
+++ b/tests/pair.zuo
@@ -1,0 +1,138 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "pairs")
+
+(check (null? '()))
+(check (null? 10) #f)
+(check (null? '(1)) #f)
+
+(check (pair? '()) #f)
+(check (pair? 10) #f)
+(check (pair? '(1)))
+
+(check (list? '()))
+(check (list? 10) #f)
+(check (list? '(1)))
+(check (list? '(1 2 3 4 5 6 7)))
+(check (list? '(1 . 2)) #f)
+(check (list? '(1 2 3 4 5 6 . 7)) #f)
+
+(check (cons 1 2) '(1 . 2))
+
+(check (car '(1 2)) 1)
+(check (car '(1 . 2)) 1)
+(check-arg-fail (car '()) "not a pair")
+(check-arg-fail (car 'apple) "not a pair")
+
+(check (cdr '(1 . 2)) 2)
+(check (cdr '(1 2)) '(2))
+(check-arg-fail (cdr '()) "not a pair")
+(check-arg-fail (cdr 'apple) "not a pair")
+
+(check (list) '())
+(check (list 1 2 3) '(1 2 3))
+
+(check (list* 1) 1)
+(check (list* 1 2 3) '(1 2 . 3))
+(check-fail (list*) arity)
+
+(check (append) '())
+(check (append 1) 1)
+(check (append '(1 2)) '(1 2))
+(check (append '(1 2) 3) '(1 2 . 3))
+(check (append '(1 2) '(3 4)) '(1 2 3 4))
+(check (append '(1 2) '(3 4) 5) '(1 2 3 4 . 5))
+
+(check (reverse '()) '())
+(check (reverse '(1 2 3)) '(3 2 1))
+(check-arg-fail (reverse 1) "not a list")
+(check-arg-fail (reverse '(1 . 2)) "not a list")
+
+(check (list-ref '(1) 0) 1)
+(check (list-ref '(1 . 2) 0) 1)
+(check (list-ref '(1 2 3 . 4) 2) 3)
+(check-arg-fail (list-ref '(1 . 2) 1) "encountered a non-pair")
+
+(check (list-set '(1) 0 'x) '(x))
+(check (list-set '(1 . 2) 0 'x) '(x . 2))
+(check (list-set '(1 2 3 . 4) 2 'x) '(1 2 x . 4))
+(check-arg-fail (list-set '(1 . 2) 1 'x) "encountered a non-pair")
+
+(check (list-tail '() 0) '())
+(check (list-tail 1 0) 1)
+(check (list-tail '(1 . 2) 1) 2)
+(check (list-tail '(1 2 3 . 4) 2) '(3 . 4))
+(check-arg-fail (list-tail '(1 . 2) 2) "encountered a non-pair")
+
+(check (caar '((1) (2))) 1)
+(check-arg-fail (caar 1) "not a valid argument")
+(check-arg-fail (caar '(1)) "not a valid argument")
+
+(check (cadr '((1 2) (3 4))) '(3 4))
+(check-arg-fail (cadr 1) "not a valid argument")
+(check-arg-fail (cadr '(1)) "not a valid argument")
+
+(check (cdar '((1 2) (3 4))) '(2))
+(check-arg-fail (cdar 1) "not a valid argument")
+(check-arg-fail (cdar '(1 . 2)) "not a valid argument")
+
+(check (cddr '((1 2) (3 4) (5 6))) '((5 6)))
+(check-arg-fail (cddr 1) "not a valid argument")
+(check-arg-fail (cddr '(1 . 2)) "not a valid argument")
+
+(check (map (lambda (x) (+ x 1)) '(0 1 2)) '(1 2 3))
+(check (map (lambda (x y) (+ x y)) '(1 2 3) '(-10 -20 -30)) '(-9 -18 -27))
+(check-arg-fail (map 1 '()) "not a procedure")
+(check-arg-fail (map (lambda (a) a) 1) "not a list")
+(check-arg-fail (map (lambda (a) a) '(1) 1) "not a list")
+(check-arg-fail (map (lambda (a b) a) '(1) '(1 2)) "lists have different lengths")
+
+(check (for-each (lambda (x) x) '(1 2 3)) (void))
+(check-output (for-each alert '(1 2 3)) "1\n2\n3\n")
+(check-arg-fail (for-each (lambda (a) a) 1) "not a list")
+(check-arg-fail (for-each 9 '(1 2)) "not a procedure")
+
+(check (foldl (lambda (x a) (+ a x)) 7 '(0 1 2)) 10)
+(check-arg-fail (foldl (lambda (x a) (+ a x)) 7 7) "not a list")
+(check-arg-fail (foldl 10 0 '(1)) "not a procedure")
+
+(check (andmap integer? '(1 2 3)))
+(check (andmap integer? '()))
+(check (andmap (lambda (x) (< x 10)) '(1 2 3)))
+(check (andmap (lambda (x) (< x 3)) '(1 2 3)) #f)
+(check (andmap (lambda (x) (< x 3)) '(1 2 3 "oops")) #f)
+(check-arg-fail (andmap 10 '(1)) "not a procedure")
+(check-arg-fail (andmap (lambda (x) (< x 3)) '(1 2 3 . "oops")) "not a list")
+
+(check (ormap integer? '(1 2 3)))
+(check (ormap string? '(1 2 3)) #f)
+(check (ormap string? '("a" 2 3)) #t)+(check (ormap (lambda (x) (< x 10)) '(1 "oops")))
+(check-arg-fail (ormap 10 '(1)) "not a procedure")
+(check-arg-fail (ormap (lambda (x) (< x 3)) '(1 2 3 . "oops")) "not a list")
+
+(check (member "x" '()) #f)
+(check (member "x" '("x" y z)) '("x" y z))+(check (member "x" '(x "x" y z)) '("x" y z))+(check-arg-fail (member "x" "y") "not a list")
+
+(check (assoc "x" '()) #f)
+(check (assoc "x" '(("x" . x) y z)) '("x" . x))+(check (assoc "x" '((x . x) ("x" . x) y z)) '("x" . x))+(check-arg-fail (assoc "x" "y") "not a list")
+(check-arg-fail (assoc "y" '((x . x) ("x" . x) y z)) "non-pair found in list")+
+(check (filter (lambda (x) (> x 7)) '()) '())
+(check (filter (lambda (x) (> x 7)) '(1 11 2 12 3 13 4)) '(11 12 13))
+(check-arg-fail (filter "x" '()) "not a procedure")
+(check-arg-fail (filter (lambda (x) #t) "y") "not a list")
+
+(check (sort '() <) '())
+(check (sort '(1 2 3 4) <) '(1 2 3 4))
+(check (sort '(3 4 2 1) <) '(1 2 3 4))
+(check (sort '("z" "d" "a" "m" "p" "q" "w" "f" "b") string<?)+ '("a" "b" "d" "f" "m" "p" "q" "w" "z"))+(check-arg-fail (sort "x" <) "not a list")
+(check-arg-fail (sort '() "x") "not a procedure")
--- /dev/null
+++ b/tests/path.zuo
@@ -1,0 +1,154 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "paths")
+
+(check (path-string? "x"))
+(check (path-string? "") #f)
+(check (path-string? "xy\0z") #f)
+(check (path-string? 'apple) #f)
+
+(define unix? (eq? (hash-ref (runtime-env) 'system-type) 'unix))
+
+(check (build-path "x" "y") (if unix? "x/y" "x\\y"))
+(check (build-path "." "y") "y")
+(check (build-raw-path "." "y") (if unix? "./y" ".\\y"))
+(check (build-path ".." "y") (if unix? "../y" "..\\y"))
+(check (build-path "x" ".") "x")
+(check (build-raw-path "x" ".") (if unix? "x/." "x\\."))
+(check (build-path "x" "..") ".")
+(check (build-raw-path "x" "..") (if unix? "x/.." "x\\.."))
+(check (build-path "x/y/z/./.." "..") "x/")
+(check (build-raw-path "x/y/z/./.." "..") (if unix? "x/y/z/./../.." "x/y/z/./..\\.."))
+(check (build-path "x/y/./.." "..") ".")
+(check (build-path "x/y/./.." "../../..") (if unix? "../.." "..\\.."))
+(check (build-path "x/y/./.." "../q/../..") "..")
+(check (build-path "x/" "y") (if unix? "x/y" "x/y"))
+(check (build-path "x//" "y") (if unix? "x//y" "x//y"))
+(check (build-path "x\\" "y") (if unix? "x\\/y" "x\\y"))
+(check (build-path "x" "y/z") (if unix? "x/y/z" "x\\y\\z"))
+(check (build-raw-path "x" "y/z") (if unix? "x/y/z" "x\\y/z"))
+(check (build-path "x/y" "z") (if unix? "x/y/z" "x/y\\z"))
+(check (build-path "x/y/" "z") (if unix? "x/y/z" "x/y/z"))
+(check (build-path "/x" "z") (if unix? "/x/z" "/x\\z"))
+(check-arg-fail (build-path "" "z") "not a path string")
+(check-arg-fail (build-path "z" "") "not a path string")
+(check-arg-fail (build-path 0 "z") "not a path string")
+(check-arg-fail (build-path "z" 0) "not a path string")
+(check-arg-fail (build-path "z" "/x") "path is not relative")
+
+(check (build-path "x") "x")
+(check (build-path "x" "y" "z") (if unix? "x/y/z" "x\\y\\z"))
+
+(check (split-path "x/y") '("x/" . "y"))+(check (split-path "x/y/") '("x/" . "y"))+(check (split-path "x//y/") '("x//" . "y"))+(check (split-path "x/y///") '("x/" . "y"))+(check (split-path "x") '(#f . "x"))
+(check (split-path "x/") '(#f . "x"))
+(check (split-path "x//") '(#f . "x"))
+(check (split-path "x\\y") (if unix? '(#f . "x\\y") '("x\\" . "y")))+(check (split-path "/") '(#f . "/"))
+(check-arg-fail (split-path "") "not a path string")
+(check-arg-fail (split-path 0) "not a path string")
+
+(unless unix?
+ (check (split-path "c:/") '(#f . "c:/"))
+ (check (split-path "c:///") '(#f . "c:/"))
+ (check (split-path "c:/x") '("c:/" . "x"))+ (check (split-path "c:/x/") '("c:/" . "x"))+ (check (split-path "c:\\") '(#f . "c:\\"))
+ (check (split-path "c:\\x") '("c:\\" . "x"))+ (check (split-path "//mach/drive/") '(#f . "//mach/drive/"))
+ (check (split-path "//mach/drive/\\\\") '(#f . "//mach/drive/"))
+ (check (split-path "//mach/drive/z") '("//mach/drive/" . "z"))+ (check (split-path "\\\\mach\\drive\\") '(#f . "\\\\mach\\drive\\"))
+ (check (split-path "\\\\mach\\drive\\z") '("\\\\mach\\drive\\" . "z"))+ (check (split-path "\\\\?\\c:\\elem") '("\\\\?\\c:\\" . "elem"))+ (check (split-path "\\\\?\\c:\\") '(#f . "\\\\?\\c:\\")))
+
+(check (relative-path? "x/y"))
+(check (relative-path? "x/y/"))
+(check (relative-path? "/x/") #f)
+(check (relative-path? "/") #f)
+(check (relative-path? "\\x") unix?)
+(check-arg-fail (relative-path? "") "not a path string")
+(check-arg-fail (relative-path? 0) "not a path string")
+
+(check (path-string? (at-source "adjacent.txt")))
+(check (at-source) (path-only (quote-module-path)))
+(check (procedure? at-source))
+(check-fail (at-source . x) bad-stx)
+
+(check (simple-form-path "a//b//c/d/../f/g")
+ (if unix?
+ "a/b/c/f/g"
+ "a\\b\\c\\f\\g"))
+(check (simple-form-path "a//b//c/d/.././../f/g")
+ (if unix?
+ "a/b/f/g"
+ "a\\b\\f\\g"))
+(check (simple-form-path "../../a//b//c/d")
+ (if unix?
+ "../../a/b/c/d"
+ "..\\..\\a\\b\\c\\d"))
+
+(check (find-relative-path "home/zuo/src" "home/zuo/src/private/optimize")
+ (build-path "private" "optimize"))
+(check (find-relative-path "home/zuo/src" "home/zuo/lib")
+ (build-path ".." "lib"))
+(check (find-relative-path "home/zuo/src" "home/zuo/src")
+ ".")
+(check (find-relative-path "home/zuo/src" "tmp/cache")
+ (build-path ".." ".." ".." "tmp" "cache"))
+(check (find-relative-path "." "tmp/cache")
+ (build-path "tmp" "cache"))
+(check (find-relative-path "tmp/cache" ".")
+ (build-path ".." ".."))
+(check (find-relative-path "../bin/tarm64osx/bin/" "main.o")
+ (build-path ".." ".." ".." (cdr (split-path (hash-ref (runtime-env) 'dir))) "main.o"))
+(let ([l (reverse (explode-path (hash-ref (runtime-env) 'dir)))])
+ (when (> (length l) 3)
+ (check (find-relative-path "../../../bin/tarm64osx/bin/" "../main.o")
+ (build-path ".." ".." ".." (list-ref l 2) (list-ref l 1) "main.o"))))
+(check (find-relative-path "tmp/cache" "/home/zuo/src")
+ "/home/zuo/src")
+
+(when unix?
+ (check (find-relative-path "/home/zuo/src" "/home/zuo/src/private/optimize")
+ "private/optimize")
+ (check (find-relative-path "/home/zuo/src" "/home/zuo/lib")
+ "../lib")
+ (check (find-relative-path "/home/zuo/src" "/home/zuo/src")
+ ".")
+ (check (find-relative-path "/home/zuo/src" "/tmp/cache")
+ "../../../tmp/cache"))
+
+(check (path-only "hello.txt") ".")
+(check (path-only ".") ".")
+(check (path-only "greeting/hello.txt") "greeting/")
+(check (path-only "in/greeting/hello.txt") "in/greeting/")
+(check (path-only "/") "/")
+(check (path-only "a/") "a/")
+(check (path-only "a\\") (if unix? "." "a\\"))
+(check (path-only "a/.") "a/.")
+(check (path-only "a/..") "a/..")
+(check-arg-fail (path-only 10) not-path)
+
+(check (file-name-from-path "hello.txt") "hello.txt")
+(check (file-name-from-path ".") #f)
+(check (file-name-from-path "greeting/hello.txt") "hello.txt")
+(check (file-name-from-path "in/greeting/hello.txt") "hello.txt")
+(check (file-name-from-path "/") #f)
+(check (file-name-from-path "a/") #f)
+(check (file-name-from-path "a\\") (if unix? "a\\" #f))
+(check (file-name-from-path "a/.") #f)
+(check (file-name-from-path "a/..") #f)
+(check-arg-fail (file-name-from-path 10) not-path)
+
+(check (path-replace-extension "a.c" ".o") "a.o")
+(check (path-replace-extension "p/a.c" ".o") (build-path "p" "a.o"))
+(check (path-replace-extension "p/.rc" ".o") (build-path "p" ".rc.o"))
+(check-arg-fail (path-replace-extension 10 "x") not-path)
+(check-arg-fail (path-replace-extension "x" 10) not-string)
--- /dev/null
+++ b/tests/procedure.zuo
@@ -1,0 +1,62 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "procedures")
+
+(check (procedure? procedure?))
+(check (procedure? (lambda (x) x)))
+(check (procedure? (lambda args args)))
+(check (procedure? apply))
+(check (procedure? call/cc))
+(check (procedure? (call/cc (lambda (k) k))))
+(check (not (procedure? 1)))
+
+(check (apply + '()) 0)
+(check (apply + '(1)) 1)
+(check (apply + '(1 2)) 3)
+(check (apply + '(1 2 3 4)) 10)
+(check (apply apply (list + '(1 2))) 3)
+(check-fail (apply +) arity)
+(check-fail (apply '(+ 1 2)) arity)
+(check-fail (apply apply (cons + '(1 2))) arity)
+(check-arg-fail (apply + 1) "not a list")
+
+(check (call/cc (lambda (k) (+ 1 (k 'ok)))) 'ok)
+(check (let ([f (call/cc (lambda (k) k))])
+ (if (procedure? f)
+ (f 10)
+ f))
+ 10)
+(check-fail (call/cc 1) "not a procedure")
+
+(check (call/prompt (lambda () 10)) 10)
+(check (let ([k (call/prompt
+ (lambda ()
+ (call/cc (lambda (k) k))))])
+ (+ 1 (call/prompt (lambda () (k 11)))))
+ 12)
+(check (let ([k (call/prompt
+ (lambda ()
+ (call/cc
+ (lambda (esc)
+ (+ 1
+ (* 2
+ (call/cc
+ (lambda (k) (esc k)))))))))])
+ (list (call/prompt (lambda () (k 3)))
+ (call/prompt (lambda () (k 4)))))
+ (list 7 9))
+(check-fail (call/prompt 1) "not a procedure")
+
+(check (let ([k (call/prompt
+ (lambda ()
+ (call/cc
+ (lambda (esc)
+ (+ 1
+ (* 2
+ (call/comp esc)))))))])
+ (list (k 30)
+ (k 40)))
+ (list 61 81))
+(check-arg-fail (call/comp 1) "not a procedure")
--- /dev/null
+++ b/tests/process.zuo
@@ -1,0 +1,146 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "processes")
+
+(define zuo.exe (hash-ref (runtime-env) 'exe))
+(define answer.txt (build-path tmp-dir "answer.txt"))
+
+;; check process without redirection, inculding multiple processes
+(let ()
+ (define echo-to-file.zuo (build-path tmp-dir "echo-to-file.zuo"))
+
+ (let ([out (fd-open-output echo-to-file.zuo :truncate)])
+ (fd-write out (~a "#lang zuo\n"
+ (~s '(let* ([args (hash-ref (runtime-env) 'args)]
+ [out (fd-open-output (car args) :truncate)])
+ (fd-write out (cadr args))))))
+ (fd-close out))
+
+ (let ([ht (process zuo.exe
+ echo-to-file.zuo
+ (list answer.txt
+ "anybody home?"))])
+ (check (hash? ht))
+ (check (= 1 (hash-count ht)))
+ (check (handle? (hash-ref ht 'process)))
+ (let ([p (hash-ref ht 'process)])
+ (check (handle? p))
+ (check (process-wait p) p)
+ (check (process-wait p p p) p)
+ (check (handle? p))
+ (check (process-status p) 0))
+ (let ([in (fd-open-input answer.txt)])
+ (check (fd-read in eof) "anybody home?")
+ (fd-close in)))
+
+ (define answer2.txt (build-path tmp-dir "answer2.txt"))
+ (let ([ht1 (process zuo.exe echo-to-file.zuo answer.txt "one")]
+ [ht2 (process zuo.exe (list echo-to-file.zuo answer2.txt) "two")])
+ (define p1 (hash-ref ht1 'process))
+ (define p2 (hash-ref ht2 'process))
+ (define pa (process-wait p1 p2))
+ (define pb (process-wait (if (eq? p1 pa) p2 p1)))
+ (check (or (and (eq? p1 pa) (eq? p2 pb))
+ (and (eq? p1 pb) (eq? p2 pa))))
+ (check (process-status p1) 0)
+ (check (process-status p2) 0)
+ (check (process-wait p1) p1)
+ (check (process-wait p2) p2)
+ (define pc (process-wait p1 p2))
+ (check (or (eq? pc p1) (eq? pc p2)))
+ (let ([in (fd-open-input answer.txt)])
+ (check (fd-read in eof) "one")
+ (fd-close in))
+ (let ([in (fd-open-input answer2.txt)])
+ (check (fd-read in eof) "two")
+ (fd-close in))))
+
+;; check setting the process directory and environment variables
+(let ([path->absolute-path (lambda (p) (if (relative-path? p)
+ (build-path (hash-ref (runtime-env) 'dir) p)
+ p))])
+ (define runtime-to-file
+ (~a "#lang zuo\n"
+ (~s `(let* ([out (fd-open-output ,(path->absolute-path answer.txt) :truncate)])
+ (fd-write out (~s (cons
+ (hash-ref (runtime-env) 'dir)
+ (hash-ref (runtime-env) 'env))))))))
+
+ (let ([ht (process zuo.exe "" (hash 'stdin 'pipe))])
+ (check (hash? ht))
+ (check (= 2 (hash-count ht)))
+ (check (handle? (hash-ref ht 'process)))
+ (check (handle? (hash-ref ht 'stdin)))
+ (fd-write (hash-ref ht 'stdin) runtime-to-file)
+ (fd-close (hash-ref ht 'stdin))
+ (process-wait (hash-ref ht 'process))
+ (check (process-status (hash-ref ht 'process)) 0)
+ (let ()
+ (define in (fd-open-input answer.txt))
+ (define dir+env (car (string-read (fd-read in eof))))
+ (fd-close in)
+ (check (car dir+env) (hash-ref (runtime-env) 'dir))
+ (check (andmap (lambda (p)
+ (define p2 (assoc (car p) (cdr dir+env)))
+ (and p2 (equal? (cdr p) (cdr p2))))
+ (hash-ref (runtime-env) 'env)))))
+
+ (let* ([env (list (cons "HELLO" "there"))]
+ [ht (process zuo.exe "" (hash 'stdin 'pipe
+ 'dir tmp-dir
+ 'env env))])
+ (fd-write (hash-ref ht 'stdin) runtime-to-file)
+ (fd-close (hash-ref ht 'stdin))
+ (process-wait (hash-ref ht 'process))
+ (check (process-status (hash-ref ht 'process)) 0)
+ (let ()
+ (define in (fd-open-input answer.txt))
+ (define dir+env (car (string-read (fd-read in eof))))
+ (fd-close in)
+ (define (dir-identity d) (hash-ref (stat d #t) 'inode))
+ (check (dir-identity (car dir+env)) (dir-identity tmp-dir))
+ (check (andmap (lambda (p)
+ (define p2 (assoc (car p) (cdr dir+env)))
+ (and p2 (equal? (cdr p) (cdr p2))))
+ env)))))
+
+;; make sure that the file descriptor for one process's pipe isn't
+;; kept open by a second process
+(let ()
+ (define ht1 (process zuo.exe "" (hash 'stdin 'pipe 'stdout 'pipe)))
+ (define ht2 (process zuo.exe "" (hash 'stdin 'pipe)))
+
+ (define in1 (hash-ref ht1 'stdin))
+ (fd-write in1 "#lang zuo 'hello")
+ (fd-close in1)
+ (check (fd-read (hash-ref ht1 'stdout) eof) "'hello\n")
+ (process-wait (hash-ref ht1 'process))
+ (fd-close (hash-ref ht1 'stdout))
+
+ (define in2 (hash-ref ht2 'stdin))
+ (fd-write in2 "#lang zuo")
+ (fd-close in2)
+ (process-wait (hash-ref ht2 'process))
+ (void))
+
+;; check transfer of UTF-8 arguments and related
+(define (check-process-arg arg)
+ (define p (process (hash-ref (runtime-env) 'exe)
+ ""
+ arg
+ (hash 'stdin 'pipe 'stdout 'pipe)))
+ (define to (hash-ref p 'stdin))
+ (fd-write to "#lang zuo (displayln (hash-ref (runtime-env) 'args))")
+ (fd-close to)
+ (define from (hash-ref p 'stdout))
+ (define s (fd-read from eof))
+ (process-wait (hash-ref p 'process))
+ (check s (~a"(" arg ")\n")))+
+(check-process-arg "\316\273")
+(check-process-arg "a b c")
+(check-process-arg "a \"b\" c")
+(check-process-arg "a \"b c")
+(check-process-arg "a \\b c")
--- /dev/null
+++ b/tests/read+print.zuo
@@ -1,0 +1,71 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "reading and printing")
+
+(check (string-read " 1 (apple) \n 2 \n\n" 0) '(1 (apple) 2))
+(check (string-read " 1 (apple) \n 2 \n\n" 3) '((apple) 2))
+(check (string-read "" 0) '())
+(check (string-read "x" 1) '())
+(check-fail (string-read "(" 0) "missing closer")+(check-fail (string-read 'apple 0) not-string)
+(check-fail (string-read "x" "y") not-integer)
+(check-fail (string-read "x" 2) "out of bounds")
+(check-fail (string-read "x" -2) "out of bounds")
+
+(check (~v 1 '(apple) "banana") "1 (list 'apple) \"banana\"")
+(check (~v 1 '(apple . pie) (string->uninterned-symbol "banana")) "1 (cons 'apple 'pie) #<symbol:banana>")
+(check (~s 1 '(apple) "banana") "1 (apple) \"banana\"")
+(check (~s 1 '(apple . pie) (string->uninterned-symbol "banana")) "1 (apple . pie) #<symbol:banana>")
+(check (~a 1 '(apple) "banana") "1(apple)banana")
+(check (~a 1 '(apple . pie) (string->uninterned-symbol "banana")) "1(apple . pie)banana")
+
+(define table
+ (list
+ (list #t "#t" "#t" "#t")
+ (list #f "#f" "#f" "#f")
+ (list 1 "1" "1" "1")
+ (list 0 "0" "0" "0")
+ (list -1 "-1" "-1" "-1")
+ (list 'apple "'apple" "apple" "apple")
+ (list (string->uninterned-symbol "banana") "#<symbol:banana>" "#<symbol:banana>" "banana")
+ (list "cherry" "\"cherry\"" "\"cherry\"" "cherry")
+ (list (cons "cherry" 'pie) "(cons \"cherry\" 'pie)" "(\"cherry\" . pie)" "(cherry . pie)")
+ (list (list* 1 2 3) "(list* 1 2 3)" "(1 2 . 3)" "(1 2 . 3)")
+ (list (hash 'a "x") "(hash 'a \"x\")" "#hash((a . \"x\"))" "#hash((a . x))")
+ (list apply "#<procedure:apply>" "#<procedure:apply>" "#<procedure:apply>")
+ (list call/cc "#<procedure:call/cc>" "#<procedure:call/cc>" "#<procedure:call/cc>")
+ (list (let ([f (lambda (x) x)]) f) "#<procedure:f>" "#<procedure:f>" "#<procedure:f>")
+ (list (opaque 'donut 5) "#<donut>" "#<donut>" "#<donut>")
+ (list (variable 'elderberry) "#<variable:elderberry>" "#<variable:elderberry>" "#<variable:elderberry>")
+ (list (void) "#<void>" "#<void>" "#<void>")))
+
+(for-each (lambda (row)
+ (apply (lambda (v pr wr di)
+ (check (~v v) pr)
+ (check (~s v) wr)
+ (check (~a v) di))
+ row))
+ table)
+
+(check-output (alert "hello" 'x) "hello: 'x\n")
+(check-output (alert 'hello 'x) "'hello 'x\n")
+(check-output (alert 'hello 'x 3 4) "'hello 'x 3 4\n")
+(check-output (error "hello" 'x) "" "hello: 'x\n")
+(check-output (error 'hello 'x) "" "'hello 'x\n")
+(check-output (error 'hello 'x 3 4) "" "'hello 'x 3 4\n")
+
+(check-fail (arity-error 'hello '()) not-string)
+(check-fail (arity-error "hello" 'oops) "not a list")
+(check-output (arity-error "hello" '(1 () "apple")) "" "hello: wrong number of arguments: 1 '() \"apple\"\n")
+
+(check (~s (let loop ([i 10000])
+ (if (= i 0)
+ '()
+ (list (loop (- i 1))))))
+ (apply ~a
+ (let loop ([i 10000] [accum '()])
+ (if (= i 0)
+ (cons "()" accum)
+ (cons "(" (loop (- i 1) (cons ")" accum)))))))--- /dev/null
+++ b/tests/shell.zuo
@@ -1,0 +1,17 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "shell")
+
+(define unix? (eq? (hash-ref (runtime-env) 'system-type) 'unix))
+
+(when unix?
+ (let ([p (shell "echo hi" (hash 'stdout 'pipe))])
+ (check (fd-read (hash-ref p 'stdout) eof) "hi\n")
+ (fd-close (hash-ref p 'stdout))
+ (process-wait (hash-ref p 'process))
+ (check (process-status (hash-ref p 'process)) 0)))
+
+(check (build-shell "x" "" "y" "" "" "z" "") "x y z")
+(check (build-shell "x" "" '("y" "" "" "z") "") "x y z")--- /dev/null
+++ b/tests/string.zuo
@@ -1,0 +1,122 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "strings")
+
+(check (string? "apple"))
+(check (string? #"apple"))
+(check (string? ""))
+(check (not (string? 'apple)))
+(check (not (string? 10)))
+
+(check (string 48 97) "0a")
+(check (string) "")
+(check-fail (string -1) "not an integer in [0, 255]")
+(check-fail (string 256) "not an integer in [0, 255]")
+(check-fail (string "a") "not an integer in [0, 255]")
+
+(check (string 2 17) "\002\021")
+(check (string 2 17) "\2\21")
+(check (string 2 17) "\02\21")
+(check (string 2 32 17) "\2 \21")
+(check (string 2 32 17) "\02 \21")
+(check (string 2 32 17 32) "\02 \21 ")
+(check (string 34 49) "\421")
+
+(check (string-length "") 0)
+(check (string-length "apple") 5)
+(check-fail (string-length 'apple) not-string)
+
+(check (string-ref "0123" 0) 48)
+(check (string-ref "0123" 2) 50)
+(check-fail (string-ref "0123" 4) "out of bounds")
+(check-fail (string-ref "0123" -1) "out of bounds")
+
+(check (substring "0123" 0 0) "")
+(check (substring "0123" 0 1) "0")
+(check (substring "0123" 0 4) "0123")
+(check (substring "0123" 4 4) "")
+(check-fail (substring "0123" -1 0) "out of bounds")
+(check-fail (substring "0123" 5 6) "out of bounds")
+(check-fail (substring "0123" -1 5) "out of bounds")
+(check-fail (substring "0123" 1 5) "out of bounds")
+(check-fail (substring "0123" 1 0) "index less than starting")
+
+(check (string-u32-ref "\000\000\000\000" 0) 0)
+(check (string-u32-ref "\000\004\004\000" 0) (+ (* 256 4) (* 256 256 4)))
+(check (string-u32-ref "\003\000\000\003" 0) (+ 3 (* 256 256 256 3)))
+(check (string-u32-ref "\377\000\000\377" 0) (+ 255 (* 256 256 256 255)))
+
+(check (string-u32-ref "__\000\000\000\000!" 2) 0)
+(check (string-u32-ref "__\000\004\004\000!" 2) (+ (* 256 4) (* 256 256 4)))
+(check (string-u32-ref "__\003\000\000\003!" 2) (+ 3 (* 256 256 256 3)))
+(check (string-u32-ref "__\377\000\000\377!" 2) (+ 255 (* 256 256 256 255)))
+
+(check (char "0") 48)
+(check (char "\377") 255)
+(check-fail (char) bad-stx)
+(check-fail (char "0" "more") bad-stx)
+(check-fail (char . "0") bad-stx)
+
+(check (string-split " apple pie " " ") '("" "apple" "pie" "" ""))+(check (string-split "__apple____pie__" "__") '("" "apple" "" "pie" ""))+(check (string-split " apple pie ") '("apple" "pie"))+(check-fail (string-split 10) not-string)
+(check-fail (string-split "apple" "") "not a nonempty string")
+
+(check (string-join '("a" "b" "c")) "a b c")+(check (string-join '("a" "b" "c") "x") "axbxc")+(check (string-join '("a" "b" "c") "") "abc")+(check (string-join '()) "")
+(check (string-join '() "x") "")
+(check-fail (string-join 10) "not a list of strings")
+(check-fail (string-join '("x") 10) not-string)+
+(check (string-trim " a ") "a")
+(check (string-trim " a b c ") "a b c")
+(check (string-trim " a " " ") " a ")
+(check (string-trim " a " " ") " a ")
+(check-fail (string-trim 10) not-string)
+(check-fail (string-trim "apple" "") "not a nonempty string")
+
+(let ([s "hello! / \\ \\\\ // \\\" \"\\ the:re/547\\65\"13\"2-*()*^$*&^'|'&~``'"])
+ (let i-loop ([i 0])
+ (let j-loop ([j i])
+ (let* ([s (substring s i j)])
+ (check (shell->strings (string->shell s)) (list s))
+ (check (shell->strings (~a " " (string->shell s) " ")) (list s)))
+ (unless (= j (string-length s)) (j-loop (+ j 1))))
+ (unless (= i (string-length s)) (i-loop (+ i 1)))))
+
+(check (string-sha1 "hello\n") "f572d396fae9206628714fb2ce00f72e94f2258f")
+
+(check (string->integer "10") 10)
+(check (string->integer "-10") -10)
+(check (string->integer "-0") 0)
+(check (string->integer "-") #f)
+(check (string->integer "") #f)
+(check (string->integer "12x") #f)
+(check (string->integer "9223372036854775807") 9223372036854775807)
+(check (string->integer "9223372036854775808") #f)
+(check (string->integer "-9223372036854775807") -9223372036854775807)
+(check (string->integer "-9223372036854775808") -9223372036854775808)
+(check (string->integer "-9223372036854775809") #f)
+(check (string->integer "000000000000000000000007") 7)
+(check-fail (string->integer 1) not-string)
+
+(check (string<? "a" "b") #t)
+(check (string<? "a" "apple") #t)
+(check (string<? "b" "apple") #f)
+(check (string<? "banana" "a") #f)
+(check (string<? "" "") #f)
+(check (string<? "" "x") #t)
+(check-fail (string<? 1 "") not-string)
+(check-fail (string<? "" 1) not-string)
+
+(check (string-tree? "a"))
+(check (string-tree? '("a")))+(check (string-tree? '("a" "b" ("c") () (((("d")))))))+(check (string-tree? 'a) #f)
+(check (string-tree? '("a" "b" ("c") () ((((d)))))) #f)+(check (string-tree? '("a" "b" ("c") () (((("d" . "c")))))) #f)--- /dev/null
+++ b/tests/symbol.zuo
@@ -1,0 +1,21 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "symbols")
+
+(check (symbol? 'apple))
+(check (symbol? (string->uninterned-symbol "apple")))
+(check (not (symbol? "apple")))
+(check (not (symbol? 10)))
+
+(check (symbol->string 'apple) "apple")
+(check-arg-fail (symbol->string "apple") "not a symbol")
+
+(check (eq? 'apple (string->symbol "apple")))
+(check (not (eq? 'apple (string->uninterned-symbol "apple"))))
+(check (not (eq? (string->uninterned-symbol "apple")
+ (string->uninterned-symbol "apple"))))
+(check (not (equal? 'apple (string->uninterned-symbol "apple"))))
+(check-arg-fail (string->symbol 'apple) not-string)
+(check-arg-fail (string->uninterned-symbol 'apple) not-string)
--- /dev/null
+++ b/tests/syntax-hygienic.zuo
@@ -1,0 +1,32 @@
+#lang zuo/hygienic
+
+(require "harness-hygienic.zuo")
+
+(alert "hygienic syntax")
+
+(check (identifier? (quote-syntax x)))
+(check (not (identifier? 'x)))
+(check (not (identifier? #f)))
+(check (not (identifier? (quote-syntax (x y)))))
+(check (not (identifier? '(x y))))
+(check (andmap identifier? (quote-syntax (x y))))
+
+(check (syntax-e (quote-syntax x)) 'x)
+(check-fail (syntax-e 'x) "not a syntax object")
+
+(check (syntax->datum 'x) 'x)
+(check (syntax->datum (quote-syntax x)) 'x)
+(check (syntax->datum (quote-syntax (x y))) '(x y))
+(check (syntax->datum '(1 #f)) '(1 #f))
+
+(check (not (symbol? (datum->syntax (quote-syntax x) 'y))))
+(check (syntax-e (datum->syntax (quote-syntax x) 'y)) 'y)
+(check-fail (datum->syntax 'x 'y) "not a syntax object")
+
+(check (bound-identifier=? (quote-syntax x) (quote-syntax x)))
+(check (not (bound-identifier=? (quote-syntax x) (quote-syntax y))))
+
+(check-fail (syntax-e #f) "not a syntax object")
+(check-fail (syntax-e '(x y)) "not a syntax object")
+(check-fail (bound-identifier=? '(x) 'x) "not a syntax object")
+(check-fail (bound-identifier=? 'x '(x)) "not a syntax object")
--- /dev/null
+++ b/tests/syntax.zuo
@@ -1,0 +1,35 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "syntax objects")
+
+(check (identifier? (quote-syntax x)))
+(check (identifier? 'x))
+(check (not (identifier? #f)))
+(check (not (identifier? (quote-syntax (x y)))))
+(check (not (identifier? '(x y))))
+(check (andmap identifier? (quote-syntax (x y))))
+
+(check (syntax-e (quote-syntax x)) 'x)
+(check (syntax-e 'x) 'x)
+(check-arg-fail (syntax-e #f) "not a syntax object")
+(check-arg-fail (syntax-e '(x y)) "not a syntax object")
+
+(check (syntax->datum 'x) 'x)
+(check (syntax->datum (quote-syntax x)) 'x)
+(check (syntax->datum (quote-syntax (x y))) '(x y))
+(check (syntax->datum '(1 #f)) '(1 #f))
+
+(check (datum->syntax 'x 'y) 'y)
+(check (datum->syntax (quote-syntax x) 'y) 'y)
+(check (syntax-e (datum->syntax (quote-syntax x) 'y)) 'y)
+(check-arg-fail (datum->syntax '(x) 'y) "not a syntax object")
+
+(check (bound-identifier=? 'x 'x))
+(check (bound-identifier=? (quote-syntax x) (quote-syntax x)))
+(check (not (bound-identifier=? (quote-syntax x) (quote-syntax y))))
+(check (not (bound-identifier=? 'x (quote-syntax x))))
+(check-arg-fail (bound-identifier=? '(x) 'x) "not a syntax object")
+(check-arg-fail (bound-identifier=? 'x '(x)) "not a syntax object")
+
--- /dev/null
+++ b/tests/thread.zuo
@@ -1,0 +1,158 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "threads")
+
+(check (call-in-main-thread
+ (lambda ()
+ (define ch (channel))
+ (define msgs (channel))
+ (thread (lambda () (channel-put msgs (list "read" (channel-get ch)))))
+ (thread (lambda () (channel-put msgs "write") (channel-put ch 'hello)))
+ (list (channel-get msgs)
+ (channel-get msgs))))
+ '("write" ("read" hello)))+
+(check (call-in-main-thread
+ (lambda ()
+ (define ch (channel))
+ (define go (channel))
+ (for-each (lambda (i) (channel-put ch i)) '(a b c d))
+ (thread (lambda ()
+ (for-each (lambda (v) (channel-put ch (list v (channel-get ch))))
+ '(1 2 3 4))
+ (channel-put go 'ok)))
+ (channel-get go)
+ (map (lambda (i) (channel-get ch)) '(_ _ _ _))))
+ '((1 a) (2 b) (3 c) (4 d)))
+
+(check (call-in-main-thread
+ (lambda ()
+ (define ch (channel))
+ (define go (channel))
+ (define ls '(a b c d))
+ (for-each (lambda (i) (channel-put ch i)) ls)
+ (for-each (lambda (v)
+ (thread (lambda ()
+ (channel-put ch (list v (channel-get ch)))
+ (channel-put go 'ok))))
+ (map symbol->string ls))
+ (for-each (lambda (i) (channel-get go)) ls)
+ (map (lambda (i) (channel-get ch)) '(_ _ _ _))))
+ ;; this is the result for now, at least, since everything is deterministic
+ ;; and the scheduler's enquring strategy adds a new thread to the front
+ '(("d" a) ("c" b) ("b" c) ("a" d)))+
+;; Each thread starts a process, but the wait might immediately succeed every time
+(check (let ([r (call-in-main-thread
+ (lambda ()
+ (define ch (channel))
+ (define ls '(a b c d))
+ (for-each (lambda (id)
+ (thread
+ (lambda ()
+ (define p (process (hash-ref (runtime-env) 'exe)
+ ""
+ (~a id)
+ (hash 'stdin 'pipe 'stdout 'pipe)))
+ (define to (hash-ref p 'stdin))
+ (fd-write to (~a "#lang zuo\n"
+ (~s '(alert (hash-ref (runtime-env) 'args)))))
+ (fd-close to)
+ (define from (hash-ref p 'stdout))
+ (define str (fd-read from eof))
+ (fd-close from)
+ (thread-process-wait (hash-ref p 'process))
+ (channel-put ch str))))
+ ls)
+ (map (lambda (i) (channel-get ch)) ls)))])
+ (and (= (length r) 4)
+ (andmap (lambda (s) (member s r))
+ '("(list \"a\")\n" "(list \"b\")\n" "(list \"c\")\n" "(list \"d\")\n"))+ #t)))
+
+;; Each thread starts a process, relies on the main thread to finish it
+(check (let ([r (call-in-main-thread
+ (lambda ()
+ (define ch (channel))
+ (define done (channel))
+ (define ls '(a b c d))
+ (for-each (lambda (id)
+ (thread
+ (lambda ()
+ (define p (process (hash-ref (runtime-env) 'exe)
+ ""
+ (~a id)
+ (hash 'stdin 'pipe 'stdout 'pipe)))
+ (channel-put ch p)
+ (thread-process-wait (hash-ref p 'process))
+ (channel-put done 'ok))))
+ ls)
+ (define results
+ (map (lambda (i)
+ (define p (channel-get ch))
+ (define to (hash-ref p 'stdin))
+ (define from (hash-ref p 'stdout))
+ (fd-write to (~a "#lang zuo\n"
+ (~s '(alert (hash-ref (runtime-env) 'args)))))
+ (fd-close to)
+ (define str (fd-read from eof))
+ (fd-close from)
+ str)
+ ls))
+ (for-each (lambda (id) (channel-get done)) ls)
+ results))])
+ (and (= (length r) 4)
+ (andmap (lambda (s) (member s r))
+ '("(list \"a\")\n" "(list \"b\")\n" "(list \"c\")\n" "(list \"d\")\n"))+ #t)))
+
+;; Each thread starts a process, main thread waits on all
+(check (let ([r (call-in-main-thread
+ (lambda ()
+ (define ch (channel))
+ (define go (channel))
+ (define ls '(a b c d))
+ (for-each (lambda (id)
+ (thread
+ (lambda ()
+ (define p (process (hash-ref (runtime-env) 'exe)
+ ""
+ (~a id)
+ (hash 'stdin 'pipe 'stdout 'pipe)))
+ (channel-put ch (hash-ref p 'process))
+ (channel-get go)
+ (define to (hash-ref p 'stdin))
+ (fd-write to (~a "#lang zuo\n"
+ (~s '(alert (hash-ref (runtime-env) 'args)))))
+ (fd-close to)
+ (define from (hash-ref p 'stdout))
+ (define str (fd-read from eof))
+ (fd-close from)
+ (channel-put ch str))))
+ ls)
+ (define ps (map (lambda (i) (channel-get ch)) ls))
+ (for-each (lambda (i) (channel-put go i)) ls)
+ (let loop ([ps ps])
+ (unless (null? ps)
+ (define p (apply thread-process-wait ps))
+ (loop (remove p ps))))
+ (map (lambda (i) (channel-get ch)) ls)))])
+ (and (= (length r) 4)
+ (andmap (lambda (s) (member s r))
+ '("(list \"a\")\n" "(list \"b\")\n" "(list \"c\")\n" "(list \"d\")\n"))+ #t)))
+
+(check-fail (begin
+ (require zuo/thread)
+ (call-in-main-thread
+ (lambda () (channel-get (channel)))))
+ "main thread is stuck")
+
+(check-fail (begin
+ (require zuo/thread)
+ (call-in-main-thread
+ (lambda ()
+ ((call/prompt (lambda () (call/cc (lambda (k) k)))) 0))))
+ "main thread is stuck")
--- /dev/null
+++ b/tests/variable.zuo
@@ -1,0 +1,23 @@
+#lang zuo
+
+(require "harness.zuo")
+
+(alert "variables")
+
+(check (variable? (variable 'alice)))
+(check (not (variable? 'alice)))
+
+(check-fail (variable-ref (variable 'alice)) "undefined: alice")
+(check-fail (variable-ref 'alice) "not a variable")
+
+(check (let ([a (variable 'alice)])
+ (variable-set! a 'home)
+ (list (variable-ref a) (variable-ref a)))
+ '(home home))
+(check-fail (let ([a (variable 'alice)])
+ (variable-set! a 'home)
+ (variable-set! a 'home))
+ "variable already has a value")
+(check-fail (variable-set! 'alice 'home) "not a variable")
+
+(check-arg-fail (variable 10) "not a symbol")
--- /dev/null
+++ b/zuo-doc/defzuomodule.rkt
@@ -1,0 +1,10 @@
+#lang at-exp racket/base
+(require scribble/manual)
+
+(provide defzuomodule)
+
+@(define-syntax-rule (defzuomodule zuo/x)
+ (begin
+ @defmodule[zuo/x #:no-declare #:packages ()]
+ @declare-exporting[zuo zuo/x #:packages () #:use-sources (zuo-doc/fake-zuo)]
+ @para{The @racketmodname[zuo/x] module is reprovided by @racketmodname[zuo].}))--- /dev/null
+++ b/zuo-doc/fake-kernel.rkt
@@ -1,0 +1,18 @@
+#lang racket/base
+
+(define-syntax-rule (define-fake id ...)
+ (begin
+ (provide id ...)
+ (define id 'id) ...))
+
+(define-syntax-rule (intro-define-fake)
+ (define-fake
+ lambda
+ let
+ quote
+ if
+ define
+ begin))
+
+(intro-define-fake)
+
--- /dev/null
+++ b/zuo-doc/fake-zuo-hygienic.rkt
@@ -1,0 +1,16 @@
+#lang racket/base
+
+(define-syntax-rule (define-fake id ...)
+ (begin
+ (provide id ...)
+ (define id 'id) ...))
+
+(define-syntax-rule (intro-define-fake)
+ (define-fake
+ identifier?
+ syntax-e
+ syntax->datum
+ datum->syntax
+ bound-identifier=?))
+
+(intro-define-fake)
--- /dev/null
+++ b/zuo-doc/fake-zuo.rkt
@@ -1,0 +1,238 @@
+#lang racket/base
+
+(define-syntax-rule (define-fake id ...)
+ (begin
+ (provide id ...)
+ (define id 'id) ...))
+
+(define-syntax-rule (intro-define-fake)
+ (define-fake
+ lambda
+ let
+ let*
+ letrec
+ if
+ and
+ or
+ when
+ unless
+ begin
+ cond
+ quote
+ quasiquote
+ unquote
+ unquote-splicing
+ quote-syntax
+
+ define
+ define-syntax
+ include
+ require
+ provide
+ module+
+ quote-module-path
+
+ pair?
+ null?
+ integer?
+ string?
+ symbol?
+ hash?
+ list?
+ procedure?
+ path-string?
+ module-path?
+ relative-path?
+ handle?
+ boolean?
+ void
+
+ apply
+ call/cc
+ call/prompt
+ continuation-prompt-available?
+ context-consumer
+ context-consumer?
+
+ cons
+ car
+ cdr
+ list
+ append
+ reverse
+ length
+ member
+ assoc
+ remove
+ list-ref
+ list-set
+
+ andmap
+ ormap
+ map
+ filter
+ foldl
+ for-each
+
+ not
+ eq?
+ equal?
+ void?
+
+ +
+ -
+ *
+ quotient
+ modulo
+ <
+ <=
+ =
+ >=
+ >
+ bitwise-and
+ bitwise-ior
+ bitwise-xor
+ bitwise-not
+
+ string-length
+ string-ref
+ string-u32-ref
+ substring
+ string=?
+ string-ci=?
+ string->symbol
+ string->uninterned-symbol
+ symbol->string
+ string
+ string-sha1
+ char
+ string-split string-join string-trim
+ string-tree?
+
+ hash
+ hash-ref
+ ref
+ hash-set
+ hash-remove
+ hash-keys
+ hash-count
+ hash-keys-subset?
+
+ opaque
+ opaque-ref
+
+ build-path
+ split-path
+ at-source
+
+ variable?
+ variable
+ variable-ref
+ variable-set!
+
+ identifier?
+ syntax-e
+ syntax->datum
+ datum->syntax
+ bound-identifier=?
+ syntax-error
+ bad-syntax
+ misplaced-syntax
+ duplicate-identifier
+
+ fd-open-input
+ fd-open-output
+ fd-close
+ fd-read
+ fd-write
+ eof
+ fd-terminal?
+ file->string
+ display-to-file
+
+ stat
+ ls rm mv mkdir rmdir symlink readlink cp
+ current-time
+ system-type
+ file-exists?
+ directory-exists?
+ link-exists?
+ explode-path
+ simple-form-path
+ find-relative-path
+ build-raw-path
+ path-replace-extension
+ path-only
+ file-name-from-path
+ path->complete-path
+ ls* rm* cp* mkdir-p
+ :error :truncate :must-truncate :append :update :can-update
+ cleanable-file
+ cleanable-cancel
+
+ process
+ process-status
+ process-wait
+ find-executable-path
+ shell->strings
+ string->shell
+
+ error
+ alert
+ ~v
+ ~a
+ ~s
+ arity-error
+ arg-error
+ display displayln
+
+ string-read
+ module->hash
+ build-module-path
+ kernel-env
+ kernel-eval
+
+ runtime-env
+ dump-image-and-exit
+ exit
+ suspend-signal resume-signal
+
+ command-line
+
+ target
+ rule
+ phony-rule
+ input-file-target
+ input-data-target
+ target-path
+ target-name
+ target?
+ token?
+ rule?
+ phony-rule?
+ sha1?
+ file-sha1
+ no-sha1
+ build
+ build/command-line
+ build/command-line*
+ build/dep
+ build/no-dep
+ provide-targets
+ find-target
+ make-at-dir
+ make-targets
+ command-target?
+ command-target->target
+ bounce-to-targets
+
+ shell
+ shell/wait
+ build-shell
+
+ call-in-main-thread
+ thread? thread channel? channel channel-put channel-get
+ thread-process-wait
+ config-file->hash))
+
+(intro-define-fake)
--- /dev/null
+++ b/zuo-doc/info.rkt
@@ -1,0 +1,12 @@
+#lang info
+
+(define deps '("base"+ "scribble-lib"
+ "at-exp-lib"
+ "racket-doc"))
+
+(define scribblings '(("zuo.scrbl" (multi-page) (language))))+
+(define pkg-desc "Documentation for the Zuo build language")
+
+(define pkg-authors '(mflatt))
--- /dev/null
+++ b/zuo-doc/lang-zuo-datum.scrbl
@@ -1,0 +1,12 @@
+#lang scribble/manual
+
+@title{Zuo Data as Module}+
+@defmodulelang[zuo/datum]
+
+A module in the @racketmodname[zuo/datum] language ``exports'' its
+content as a list of S-expressions. The export is not a
+@racket[provide] in the sense of the @racketmodname[zuo] language.
+Instead, the module's representation (see @secref["module-protocol"])
+is just a hash table mapping @racket['datums] to the list of
+S-expressions.
--- /dev/null
+++ b/zuo-doc/lang-zuo-hygienic.scrbl
@@ -1,0 +1,71 @@
+#lang scribble/manual
+@(require (for-label (except-in zuo-doc/fake-zuo
+ identifier?
+ syntax-e
+ syntax->datum
+ datum->syntax
+ bound-identifier=?)
+ zuo-doc/fake-zuo-hygienic)
+ "real-racket.rkt")
+
+@title[#:tag "zuo-hygienic"]{Zuo with Hygienic Macros}+
+@defmodulelang[zuo/hygienic #:no-declare #:packages ()]
+@declare-exporting[zuo/hygienic #:packages () #:use-sources(zuo-doc/fake-zuo-hygienic)]
+
+The @racketmodname[zuo/hygienic] language provides the same set of
+bindings as @racketmodname[zuo/base], but with hygienic macros. Its
+macro-expansion protocol uses a different representation of
+identifiers and binding scope, and different rules for
+@racket[quote-syntax] and macros:
+
+@itemlist[
+
+ @item{A @racketmodname[zuo/hygienic] term's representation always+ uses identifier syntax objects in place of symbols. A macro
+ will never receive a plain symbol in its input, and if the
+ macro produces a term with plain symbol, it is automatically
+ coerced to a syntax object using the scope of the module that
+ defines the macro.}
+
+ @item{A syntax object's context includes a @defterm{set of scopes},+ instead of just one @tech{scope}. Before expanding forms in a+ new context, a fresh scope representation is added to every
+ identifier appearing within the context. An reference is
+ resolved by finding the binding identifier with the most
+ specific set of scopes that is a subset of the referencing
+ identifier's scopes.}
+
+ @item{In addition to binding contexts, a specific macro invocation is+ also represented by a scope: a fresh scope is added to every
+ syntax object introduced by a macro expansion. This fresh scope
+ means that an identifier introduced by the expansion can only
+ bind identifiers that were introduced by the same expansion.
+ Meanwhile, a @racket[quote-syntax]-imposed scope on an
+ introduced identifier prevents it from being bound by an
+ identifier that's at the macro-use site and not visible at the
+ macro-definition site.}
+
+ @item{The @racket[quote-syntax] form produces an identifier syntax+ object with all of its scope intact. That syntax object
+ acquires additional scope if it is returned from a macro
+ expander into a new context.}
+
+]
+
+These differences particularly affect the functions that operate on
+@tech{syntax objects}:+
+@deftogether[(
+@defproc[(identifier? [v any?]) boolean?]
+@defproc[(syntax-e [v identifier?]) symbol?]
+@defproc[(syntax->datum [v any?]) any?]
+@defproc[(datum->syntax [ctx identifier?] [v any?]) any?]
+@defproc[(bound-identifier=? [id1 identifier?]
+ [id2 identifier?]) boolean?]
+)]{+
+Unlike the @racketmodname[zuo] function, @racket[identifier?] does not
+recognize a plain symbol as an identifier. The @racket[datum->syntax]
+function converts symbols in @racket[v] to syntax objects using the
+context of @racket[ctx].}
--- /dev/null
+++ b/zuo-doc/lang-zuo-kernel.scrbl
@@ -1,0 +1,111 @@
+#lang scribble/manual
+@(require (for-label zuo-doc/fake-kernel
+ (except-in zuo-doc/fake-zuo
+ lambda
+ let
+ quote
+ if
+ define
+ begin))
+ "real-racket.rkt")
+
+@title[#:tag "zuo-kernel"]{Zuo Kernel Language}+
+@defmodulelang[zuo/kernel #:no-declare #:packages ()]
+@declare-exporting[zuo-doc/fake-kernel #:packages ()]
+
+The body of a @racketmodname[zuo/kernel] module is a single expression
+using a set of core @seclink["kernel-syntax"]{syntactic forms}+and @seclink["kernel-primitives"]{primitives}. The expression+must produce a @tech{hash table} that serves as the module's+representation (see @secref["module-protocol"]).
+
+
+@section[#:tag "kernel-syntax"]{Syntactic Forms}+
+@deftogether[(
+@defform[#:link-target? #f #:id not-id id]
+@defform[#:link-target? #f #:id not-literal literal]
+@defform[#:link-target? #f #:id not-expr (expr expr ...)]
+@defform[(lambda formals maybe-name maybe-arity-mask expr)
+ #:grammar ([formals (id ...)
+ id
+ (id ... . id)]
+ [maybe-name string
+ code:blank]
+ [maybe-arity-mask integer
+ code:blank])]
+@defform[(quote datum)]
+@defform[(if expr expr expr)]
+@defform[(let ([id expr]) expr)]
+@defform[(begin expr ...+)]
+)]{+
+These forms are analogous to a variable reference, literal, procedure
+application, @realracket*[lambda quote if let begin] in
+@racketmodname[racket], but often restricted to a single expression or
+binding clause. Unlike the corresponding @racketmodname[racket] or
+@racketmodname[zuo] forms, the names of syntactic forms are not
+shadowed by a @racket[lambda] or @racket[let] binding, and they refer
+to syntactic forms only at the head of a term. A reference to an
+unbound variable is a run-time error. If an @racket[id] appears
+multiple times in @racket[formals], the last instance shadows the
+others.
+
+A @racket[lambda] form can optionally include a name and/or
+arity mask. If an arity mask is provided, it must be a subset of the mask
+implied by the @racket[formals]. If @racket[formals] allows 63 or more
+arguments, then it must allow any number of arguments (to be
+consistent with the possible arities expressed by a mask).
+
+Although @racket[let] and @racket[begin] could be encoded with
+@racket[lambda] easily enough, they're useful shortcuts to make
+explicit internally.}
+
+
+@section[#:tag "kernel-primitives"]{Primitives}+
+The following names provided by @racketmodname[zuo] are also available
+in @racketmodname[zuo/kernel] (and the values originate there):
+
+@racketblock[
+
+ pair? null? list? cons car cdr list append reverse length
+ list-ref list-set
+
+ integer? + - * quotient modulo < <= = >= >
+ bitwise-and bitwise-ior bitwise-xor bitwise-not
+
+ string? string-length string-ref string-u32-ref substring string
+ string=? string-ci=? string-sha1 string-split
+
+ symbol? symbol->string string->symbol string->uninterned-symbol
+
+ hash? hash hash-ref hash-set hash-remove
+ hash-keys hash-count hash-keys-subset?
+
+ procedure? apply call/cc call/prompt
+
+ eq? not void
+
+ opaque opaque-ref
+
+ path-string? build-path build-raw-path split-path relative-path?
+ module-path? build-module-path
+
+ variable? variable variable-ref variable-set!
+
+ handle? fd-open-input fd-open-output fd-close fd-read fd-write eof
+ fd-terminal? cleanable-file cleanable-cancel
+
+ stat ls rm mv mkdir rmdir symlink readlink cp
+ runtime-env current-time
+
+ process process-status process-wait string->shell shell->strings
+
+ string-read ~v ~a ~s alert error arity-error arg-error
+
+ kernel-env kernel-eval module->hash dump-image-and-exit exit
+ suspend-signal resume-signal
+
+]
--- /dev/null
+++ b/zuo-doc/lang-zuo.scrbl
@@ -1,0 +1,1327 @@
+#lang scribble/manual
+@(require (for-label zuo-doc/fake-zuo)
+ "real-racket.rkt")
+
+@title[#:tag "zuo-base"]{Zuo Base Language}+
+@defmodule[#:multi (zuo zuo/base) #:no-declare #:lang #:packages ()]
+@declare-exporting[zuo zuo/base #:packages () #:use-sources (zuo-doc/fake-zuo)]
+
+The @racketmodname[zuo] language is Zuo's default language. It's meant
+to be familiar to Racket programmers, and the description here leans
+heavily on comparisons and the Racket documentation, for now. Zuo
+forms and functions tend use traditional Racket names, even when a
+different choice might be made in a fresh design, and even when the
+Zuo construct is not exactly the same. Filesystem operations, however,
+tend to use the names of Unix programs, which are much shorter than
+Racket's long names.
+
+The @racketmodname[zuo/base] language includes most of the bindings
+from @racketmodname[zuo], but not the ones that are from
+@racketmodname[zuo/cmdline], @racketmodname[zuo/build],
+@racketmodname[zuo/shell], @racketmodname[zuo/thread],
+@racketmodname[zuo/glob], or @racketmodname[zuo/config].
+
+@section{Syntax and Evaluation Model}+
+A @racketmodname[zuo] module consists of a sequence of definitions
+(e.g., @racket[define]), macro definitions (e.g.,
+@racket[define-syntax]), imports (e.g., @racket[require]), exports
+(e.g., @racket[provides]), and expressions (e.g., @racket[5]). Loading
+the module first @deftech{expands} it, and then @deftech{evaluates}+it. A module is loaded only once, so if a module is demanded more than
+once, the result of the first load is used.
+
+The expansion process expands macro uses, loads imported modules, and
+evaluates macro definitions as such forms are encountered for the
+module body. Expansion creates a binding for each definition as
+encountered, but does not expand or evaluate the definition, yet.
+Expansion of definitions and expressions is deferred until all forms
+in the module body have been processed. Some expression forms have
+local definition contexts, which can include further imports and macro
+definitions, so expansion at those points nests the same two-step
+process as used for the module body.
+
+Evaluation of a module evaluates its definitions and expressions (some
+of which may have been introduced by macro expansion) in order.
+Definitions bind mutually recursively within the enclosing module or
+definition context, and referencing a defined variable before its
+evaluation is an error. The value of each expression in a module body
+is printed using @racket[alert] compiled with @racket[~v].
+
+A module's provided variables and syntax are made available to other
+modules that import it. Variables and macros that are not provided are
+completely inaccessible outside of the module.
+
+There are no @defterm{phases} in the sense of Racket. When+@racketmodname[zuo] macro expansion encountered an import, it makes
+all of the imported module's exports immediately available for use in
+macro implementations, both variables and macros. For example, an
+imported macro might be used both to implement a macro body and in
+nearby run-time code or even run-time code generated by the macro's
+expansion. The absence of a phase separation is related to way that
+each module is evaluated only once, and it's made workable in part by
+the absence of mutable data structures in Zuo, and in part because
+there is no support for compiling a @racketmodname[zuo] module and
+saving it separate from it's instantiation in a Zuo process or saved
+image.
+
+Zuo macros consume a representation of syntax that uses plain pairs,
+numbers, strings, etc., but with an identifier @tech{syntax object}+potentially in place of a symbol. Even for symbols, using a syntax
+object is optional; by using @racket[quote-syntax] to create a syntax
+object, a macro can generate a term with identifiers bound at the
+macro's definition site, instead of a use site's, but the macro
+expander does not impose or automate that binding. See
+@racket[quote-syntax] for more information.
+
+@; ----------------------------------------
+
+@section{Binding and Control Forms}+
+A @racketmodname[zuo] syntactic form is either a @deftech{definition}+form or an @deftech{expression forms}. Expressions can appear in+definition contexts, but not vice versa. In descriptions of syntactic
+forms @racket[_body ...+] refers to a context that allows definition
+forms, but the last form in the expansion of the definition context
+must be an expression form.
+
+@subsection{Expression Forms}+
+@defform[(lambda formals body ...+)
+ #:grammar ([formals (id ... [id expr] ...)
+ id
+ (id ... [id expr] ... . id)])]{+
+Analogous to @realracket[lambda] in @racketmodname[racket], but
+without keyword arguments.}
+
+
+@defform[#:link-target? #f #:id not-expr (expr expr ...)]{+
+A function call, where the initial @racket[expr] is not an identifier
+bound to a macro.}
+
+
+@deftogether[(
+@defform*[[(let ([id val-expr] ...) body ...+)
+ (let proc-id ([id init-expr] ...) body ...+)]]
+@defform[(let* ([id val-expr] ...) body ...+)]
+@defform[(letrec ([id val-expr] ...) body ...+)]
+)]{+
+Just like @realracket*[let let* letrec] in @racketmodname[racket].}
+
+
+@deftogether[(
+@defform[(if test-expr then-expr else-expr)]
+@defform[(and expr ...)]
+@defform[(or expr ...)]
+@defform[(when test-expr body ...+)]
+@defform[(unless test-expr body ...+)]
+@defform[#:literals (else)
+ (cond cond-clause ...)
+ #:grammar ([cond-clause [test-expr then-body ...+]
+ [else then-body ...+]])]
+@defform[#:id else else]
+@defform[(begin expr ...+)]
+)]{+
+Just like @realracket*[if and or when unless cond else begin] in
+@racketmodname[racket], except that @racket[cond] is more limited.}
+
+
+@deftogether[(
+@defform[(quote datum)]
+@defform[(quasiquote datum)]
+@defform[#:id unquote unquote]
+@defform[#:id unquote-splicing unquote-splicing]
+)]{+
+Just like @realracket*[quote quasiquote unquote unquote-splicing] from
+@racketmodname[racket].}
+
+
+@defform[(quote-syntax datum)]{+
+Analogous to @realracket[quote-syntax] from @racketmodname[racket],
+but only identifiers have a specialized syntax-object representation
+in place of symbols. Tree structure in @racket[datum] represented
+using plain pairs, and non-identifier elements of @racket[datums] are
+represented with plain numbers, strings, etc.
+
+A Zuo module's representation starts with plain pairs and symbols, a
+macro procedure can receive terms containing plain symbols, and it can
+return a term with plain symbols. A symbol non-hygienically acquires a
+@tech{scope} at the point where its binding is resolved or where it+creates a binding.
+
+A @deftech{scope} corresponds to a particular binding context. It can+be a module context, an internal definition context, or a binding site
+for an expression form like the formals of a @racket[lambda] or the
+right-hand side of a @racket[letrec].
+
+An identifier @tech{syntax object} created by @racket[quote-syntax] closes+over a binding at the point where it is created, closing over the
+enclosing module scope if the identifier is not (yet) bound. The
+closure does not change if the identifier is nested in a later
+@racket[quote-syntax] form. Identifiers that are introduced by macros
+are not automatically given a scope or otherwise distinguished from
+identifiers that appeared as input to a macro, and a plain symbol is
+implicitly coerced to a syntax object only at the point where it binds
+or where its binding is resolved as a reference.
+
+There is no @realracket[quasisyntax], @realracket[unsyntax], or
+@realracket[unsyntax-splicing] analog, since @racket[quasiquote],
+@racket[unquote], and @racket[unquote-splicing] are already convenient
+enough for most purposes. To generate a fresh symbol for the output of
+a macro expansion, use @racket[string->uninterned-symbol].}
+
+@defform[(quote-module-path)]{+
+Returns the module path of the enclosing module.}
+
+
+@subsection{Definition Forms}+
+@defform*[[(define id expr)
+ (define (id . formals) body ...++)]]{+
+Like @realracket*[define] from @racketmodname[racket], but without
+keyword arguments, optional arguments, or header nesting for curried
+functions.}
+
+@defform*[[(define-syntax id expr)
+ (define-syntax (id . formals) body ...++)]]{+
+Analogous to @realracket*[define-syntax] from @racketmodname[racket],
+binds @racket[id] as a macro. The value of @racket[expr] must be
+either a procedure (of one argument) or a value constructed by
+@racket[context-consumer].
+
+If @racket[expr] produces a @racket[context-consumer] wrapper, then
+when @racket[id] is used for a macro invocation, the wrapped procedure
+receives three arguments: the macro use as syntax, a function that
+acts like @realracket[free-identifier=?], and either @racket[#f] or an
+inferred-name string. (In @racketmodname[racket],
+@realracket[free-identifier=?] and @realracket[syntax-local-name] are
+implicitly parameterized over the context of a macro invocation.
+Explicitly providing a comparison procedure and name string to a macro
+implementation, instead, avoids the implicit parameterization.)
+
+See @racket[quote-syntax] for more information about the
+representation of syntax that a macro function consumes and produces.}
+
+@defform[(struct id (field-id ...))]{+
+Analogous to @realracket*[struct] from @racketmodname[racket], but
+defining only @racket[id] as a constructor,
+@racket[id]@racketidfont{?} as a predicate,+@racket[id]@racketidfont{-}@racket[field-id] as an accessor for each+@racket[field-id], and
+@racket[id]@racketidfont{-set-}@racket[field-id] as a+functional-update operation (along the lines of
+@realracket[struct-copy]) for each @racket[field-id].}
+
+@defform[(include module-path)]{+
+Splices the content of the module identified by @racket[module-path],
+assuming that @racket[module-path] is implemented in a language like
+@racketmodname[zuo/datum].}
+
+@deftogether[(
+@defform[#:literals (only-in rename-in)
+ (require spec ...)
+ #:grammar ([spec module-path
+ (only-in module-path
+ maybe-renamed-id ...)
+ (rename-in module-path
+ renamed-id ...)]
+ [maybe-renamed-id id
+ renamed-id]
+ [renamed-id [provided-id id]])]
+@defform[#:literals (all-from-out)
+ (provide spec ...)
+ #:grammar ([spec id
+ (rename-out renamed-id ...)
+ (all-from-out module-path)]
+ [maybe-renamed-id id
+ renamed-id]
+ [renamed-id [id provided-id]])]
+)]{+
+Like @realracket*[require provide] from @racketmodname[racket], but a
+@racket[require] can appear in any definition context, while
+@racket[provide] is not allowed in @tech{submodules}.}+
+@defform[(module+ id defn-or-expr ...)]{+
+Declares a kind of @deftech{submodule}, roughly analogous to+@realracket[module+] from @racketmodname[racket], but without allowing
+submodules nested in submodules.
+
+A submodule becomes a procedure of zero arguments that is a mapped
+from the symbol form of @racket[id] in the encloding module's
+representation as a hash table (see @secref["module-protocol"]).
+Calling the procedure evaluates the @racket[defn-or-expr] content of
+the submodule, where expression results are printed and the procedure
+result is @racket[(void)].
+
+When Zuo loads a starting module (see @secref["running"]), it checks
+for a @racketidfont{main} submodule and runs it if one is found.}+
+@; ----------------------------------------
+
+@section{Booleans}+
+Zuo booleans are written @racket[#t] or @racket[#true] and @racket[#f]
+or @racket[#false]. Any value other than @racket[#f] counts as true
+for conditionals.
+
+@deftogether[(
+@defproc[(boolean? [v any/c]) boolean?]
+@defproc[(not [v any/c]) boolean?]
+)]{+
+Just like @realracket*[boolean? not] from @racket[racket].}
+
+@defproc[(eq? [v1 any/c] [v2 any/c]) boolean?]{+
+Analogous to @realracket[eq?] from @racket[racket], but even small Zuo
+numbers are not necessarily @racket[eq?] when they are @racket[=].}
+
+@defproc[(equal? [v1 any/c] [v2 any/c]) boolean?]{+
+Analogous to @realracket[equal?] from @racket[racket].}
+
+
+@section{Numbers}+
+A Zuo number corresponds to a 64-bit two's complement representation
+with modular arithmetic (i.e., wraparound on overflow). It is always
+written in decimal form with a leading @litchar{-} for negative+numbers.
+
+@defproc[(integer? [v any/c]) boolean?]{+
+Returns @racket[#t] if @racket[v] is an integer, @racket[#f] otherwise.}
+
+@deftogether[(
+@defproc[(+ [z integer?] ...) integer?]
+@defproc*[([(- [z integer?]) integer?]
+ [(- [z integer?] [w integer?] ...+) integer?])]
+@defproc[(* [z integer?] ...) integer?]
+@defproc[(quotient [n integer?] [m integer?]) integer?]
+@defproc[(modulo [n integer?] [m integer?]) integer?]
+@defproc[(= [z integer?] [w integer?]) boolean?]
+@defproc[(< [x integer?] [y integer?]) boolean?]
+@defproc[(<= [x integer?] [y integer?]) boolean?]
+@defproc[(> [x integer?] [y integer?]) boolean?]
+@defproc[(>= [x integer?] [y integer?] ...) boolean?]
+@defproc[(bitwise-ior [n integer?] [m integer?]) integer?]
+@defproc[(bitwise-and [n integer?] [m integer?]) integer?]
+@defproc[(bitwise-xor [n integer?] [m integer?]) integer?]
+@defproc[(bitwise-not [n integer?]) integer?]
+)]{+
+Analogous to @realracket*[+ - * quotient modulo = < <= > >=
+bitwise-ior bitwise-and bitwise-xor bitwise-not] from
+@racketmodname[racket], but on Zuo integers and sometimes constrained
+to two arguments.}
+
+
+@section{Pairs and Lists}+
+Zuo pairs and lists work the same as in Racket with the same textual
+representation.
+
+@deftogether[(
+@defproc[(pair? [v any/c])
+ boolean?]
+@defproc[(null? [v any/c])
+ boolean?]
+@defproc[(list? [v any/c])
+ boolean?]
+@defproc[(cons [a any/c] [d any/c])
+ pair?]
+@defproc[(car [p pair?])
+ any/c]
+@defproc[(cdr [p pair?])
+ any/c]
+@defproc[(list [v any/c] ...)
+ list?]
+@defproc[(list* [v any/c] ... [tail any/c])
+ any/c]
+@defproc*[([(append [lst list?] ...) list?]
+ [(append [lst list?] ... [v any/c]) any/c])]
+@defproc[(reverse [lst list?]) list?]
+@defproc[(length [lst list?]) integer?]
+@defproc[(list-ref [lst pair?] [pos integer?]) any/c]
+@defproc[(list-set [lst pair?] [pos integer?] [v any/c]) any/c]
+@defproc[(list-tail [lst any/c] [pos integer?]) any/c]
+)]{+
+Just like @realracket*[pair? null? cons car cdr list? list* append
+reverse list-ref list-set list-tail] from @racketmodname[racket], except that
+@racket[list?] takes time proportional to the length of the list.}
+
+@deftogether[(
+@defproc[(caar [p pair?]) any/c]
+@defproc[(cadr [p pair?]) any/c]
+@defproc[(cdar [p pair?]) any/c]
+@defproc[(cddr [p pair?]) any/c]
+)]{+
+Just like @realracket*[caar cadr cdar cddr] from @racketmodname[racket].}
+
+
+@deftogether[(
+@defproc[(map [proc procedure?] [lst list?] ...+)
+ list?]
+@defproc[(for-each [proc procedure?] [lst list?])
+ void?]
+@defproc[(foldl [proc procedure?] [init any/c] [lst list?])
+ any/c]
+@defproc[(andmap [proc procedure?] [lst list?])
+ any/c]
+@defproc[(ormap [proc procedure?] [lst list?])
+ any/c]
+@defproc[(filter [proc procedure?] [lst list?])
+ list?]
+@defproc[(sort [lst list?] [less-than? procedure?])
+ list?]
+)]{+
+Like @realracket*[map for-each foldl andmap ormap filter] from
+@racketmodname[racket], but mostly restricted to a single list.}
+
+@deftogether[(
+@defproc[(member [v any/c] [lst list?])
+ (or/c pair? #f)]
+@defproc[(assoc [v any/c] [lst list?])
+ (or/c pair? #f)]
+@defproc[(remove [v any/c] [lst list?])
+ (or/c pair? #f)]
+)]{+
+Like @realracket*[member assoc remove] from @racketmodname[racket].}
+
+
+@section{Strings}+
+Zuo @deftech{strings} are sequences of bytes.+
+@deftogether[(
+@defproc[(string? [v any/c]) boolean?]
+@defproc[(string [char integer?] ...) string?]
+@defproc[(string-length [str string?]) integer?]
+@defproc[(string-ref [str string?] [k integer?]) integer?]
+@defproc[(substring [str string?]
+ [start integer?]
+ [end integer? (string-length str)]) string?]
+@defproc[(string=? [str1 string?] [str2 string?]) boolean?]
+@defproc[(string-ci=? [str1 string?] [str2 string?]) boolean?]
+@defproc[(string<? [str1 string?] [str2 string?]) boolean?]
+)]{+
+Analogous to @realracket*[string? string string-length string-ref substring
+string=? string<?] from @racketmodname[racket], or more precisely analogous to
+@realracket*[bytes? bytes-length bytes-ref subbytes bytes=? bytes-ci=?] from
+@racketmodname[racket].}
+
+@defproc[(string-u32-ref [str string?] [k integer?]) integer?]{+
+Returns the two's complement interpretation of four bytes in
+@racket[str] starting at index @racket[k] using the host machine's
+endianness.}
+
+@defproc[(string->integer [str string?]) (or/c integer? #f)]{+
+Tries to parse @racket[str] as an integer returning @racket[#f] if
+that fails.}
+
+@defproc[(string-sha1 [str string?]) string?]{+
+Returns the SHA-1 hash of @racket[str] as a 40-digit hexadecimal string.}
+
+@defform[(char str)]{+
+Expands to @racket[(string-ref str 0)], where @racket[str] must be a
+string of length 1.}
+
+@defproc*[([(string-split [str string?]) list?]
+ [(string-split [str string?] [sep string?]) list?])]{+
+Breaks @racket[str] into a sequence of substrings that have a
+non-empty separator string in between. When @racket[sep] is not
+provided, @racket[" "] is used as the separator, and empty strings are
+filtered from the result list. When @racket[sep] is provided, empty
+strings are @emph{not} filtered from the result list.}+
+@defproc[(string-join [strs list?] [sep string? " "]) string?]{+
+Concatenates the strings in @racket[strs] with @racket[sep] between
+each pair of strings.}
+
+@defproc[(string-trim [str string?] [edge-str string? " "]) string?]{+
+Removes any number of repetitions of @racket[edge-str] from the start
+and end of @racket[str].}
+
+
+@defproc[(string-tree? [v any/c]) boolean?]{+
+Returns @racket[#t] if @racket[v] is a string or if it is a list where
+@racket[string-tree?] returns @racket[#t] for each element,
+@racket[#f] otherwise. The flattened form of a string tree is a list
+of its strings in order. See also @racket[process] and
+@racket[build-shell].}
+
+
+@section{Symbols}+
+Zuo symbols are @deftech{interned} by the reader, where two interned+symbols are @racket[eq?] when they have the same string content. An
+@deftech{uninterned} symbol is @racket[eq?] only to itself. Zuo+symbols are the only kind of value that can be used as a key for a Zuo
+@tech{hash table}.+
+The textual representation of symbols does not include escapes for
+special character, analogous to the way @litchar{|} works in Racket.+Symbols with those characters will print in a way that cannot be read
+back into Zuo.
+
+@deftogether[(
+@defproc[(symbol? [v any/c]) boolean?]
+@defproc[(symbol->string [sym symbol?]) string?]
+@defproc[(string->symbol [str string?]) symbol?]
+@defproc[(string->uninterned-symbol [str string?]) symbol?]
+)]{+
+Analogous to @realracket*[symbol? symbol->string string->symbol
+string->uninterned-symbol] from @racketmodname[racket].}
+
+
+@section{Hash Tables (Persistent Maps)}+
+Zuo @tech{hash tables} do not actually have anything to do with+hashing, but they're called that for similarly to Racket. A hash table
+maps symbols to other values, and updating a hash table produces a new
+hash table (which, internally, may share with the original).
+
+Hash table print in a way analogous to Racket, but there is no reader
+support to convert the textual form back into a hash table value.
+
+@deftogether[(
+@defproc[(hash? [v any/c]) boolean?]
+@defproc[(hash [key symbol?] [val any/c] ... ...) hash?]
+@defproc*[([(hash-ref [hash hash?]
+ [key symbol?])
+ any/c]
+ [(hash-ref [hash hash?]
+ [key symbol?]
+ [failure-value any/c])
+ any/c])]
+@defproc[(hash-set [hash (and/c hash? immutable?)]
+ [key symbol?]
+ [v any/c])
+ hash?]
+@defproc[(hash-remove [hash (and/c hash? immutable?)]
+ [key symbol?])
+ hash?]
+@defproc[(hash-keys [hash hash?]) (listof symbol?)]
+@defproc[(hash-count [hash hash?]) integer?]
+@defproc[(hash-keys-subset? [hash1 hash?] [hash2 hash?])
+ boolean?]
+)]{+
+Analogous to @realracket*[hash? hash hash-ref hash-set hash-remove
+hash-keys hash-count hash-keys-subset?] from @racketmodname[racket].
+Besides being constrained to symbol keys, there is one additional
+difference: the third argument to @racket[hash-ref], when supplied,
+is always used as a value to return if a key is missing, as
+opposed to a failure thunk.}
+
+
+@section{Procedures}+
+@deftogether[(
+@defproc[(procedure? [v any/c]) any/c]
+@defproc[(apply [proc procedure?] [lst list?]) any/c]
+@defproc[(call/cc [proc procedure?]) any/c]
+@defproc[(call/prompt [proc procedure?] [tag symbol?]) any/c]
+@defproc[(continuation-prompt-available? [tag symbol?]) boolean?]
+)]{+
+Like @realracket*[procedure? apply call/cc
+call-with-continuation-prompt continuation-prompt-available?] from
+@racketmodname[racket], but @racket[apply] accepts only two arguments,
+@racket[call/cc] has no prompt-tag argument and captures up to the
+nearest enclosing prompt of any tag, @racket[call/prompt] expects a
+symbol for a prompt tag, and @racket[continuation-prompt-available?]
+checks only whether the immediately enclosing prompt has the given tag.}
+
+
+@section{Paths}+
+A @deftech{path string} is is a @tech{string} that is not non-empty+and to contains no nul bytes.
+
+@defproc[(path-string? [v any/c]) boolean?]{+
+Returns @racket[#t] if @racket[v] is a path string, @racket[#f] otherwise.}
+
+@defproc[(relative-path? [path path-string?]) boolean?]{+
+Returns @racket[#t] if @racket[v] is a relative path, @racket[#f] otherwise.}
+
+@defproc[(build-raw-path [base path-string?] [rel path-string?] ...) path-string?]{+
+Combines @racket[base] path (absolute or relative) with the relative
+paths @racket[rel], adding path separators as needed.}
+
+@defproc[(build-path [base path-string?] [rel path-string?] ...) path-string?]{+
+Similar to @racket[build-raw-path], but any @filepath{.} or+@filepath{..} element in a @racket[rel] is syntactically eliminated,+and separators in @racket[rel] are normalized. Removing @filepath{..}+elements may involve syntactically resolving elements at the end of
+@racket[base]. Furthermore, if base is at some point reduced to
+@racket["."], it will not be prefixed on the result.}
+
+@defproc[(split-path [path path-string?]) pair?]{+
+Splits @racket[path] into its directory (if any) and a final element
+components. If @racket[path] has only a single element, the
+@racket[car] of the result is @racket[#f], and the @racket[cdr] is
+@racket[path] unchanged; otherwise, the final element is returned
+without trailing separators.}
+
+@defproc[(explode-path [path path-string?]) (listof path-string?)]{+
+Split @racket[path] into a list of individual path elements by
+repeatedly applying @racket[split-path].}
+
+@defproc[(simple-form-path [path path-string?]) path-string?]{+
+Syntactically normalizes @racket[path] by eliminating @filepath{.} and+@filepath{..} elements (except for @filepath{..} at the start that+cannot be eliminated), removing redundant path separators, and making
+all path separators the platform default (on Windows).}
+
+@defproc[(find-relative-path [base path-string?] [path path-string?]) path-string?]{+
+Attempts to finds a path relative to @racket[base] that accesses the
+same file or directory as @racket[path]. Both @racket[base] and
+@racket[path] must be normalized in the sense of
+@racket[simple-form-path], otherwise @filepath{.} and @filepath{..}+elements are treated normal path elements. Assuming that @racket[base]
+and @racket[path] are normalized, the result is always normalized.
+
+The result path depends on whether @racket[base] and @racket[path] are
+relative or absolute:
+
+@itemlist[
+
+ @item{If both are relative, the result is always a relative path. If+ @racket[base] starts with @filepath{..} elements that are not+ matched by @racket[path], then elements are drawn from
+ @racket[(hash-ref (runtime-env) 'dir)].}
+
+ @item{If both are absolute, the result is absolute if @racket[base]+ and @racket[path] do not share a root element, otherwise the
+ result is relative.}
+
+ @item{If @racket[path] is absolute and @racket[base] is relative,+ @racket[path] is returned as-is. The intent of this mode is to
+ preserve the ``absoluteness'' of @racket[path] in a setting
+ that otherwise works in terms of relative paths.}
+
+ @item{If @racket[base] is absolute and @racket[path] is relative,+ @racket[path] is converted to absolute via
+ @racket[path->complete-path], and the result is as when both
+ are absolute (so, the result may still be absolute).}
+
+]}
+
+@defproc[(path-only [path path-string?]) path-string?]{+
+Returns @racket[path] without its final path element in the case that
+@racket[path] is not syntactically a directory. If @racket[path] has
+only a single, non-directory path element, @racket["."] is returned.
+If @racket[path] is syntactically a directory, then @racket[path] is
+returned unchanged.}
+
+@defproc[(file-name-from-path [path path-string?]) (or/c path-string? #f)]{+
+Returns the last element of @racket[path] in the case that
+@racket[path] is not syntactically a directory, @racket[#f]
+otherwise.}
+
+@defproc[(path->complete-path [path path-string?]) path-string?]{+
+Returns @racket[path] if it is absolute, otherwise returns
+@racket[(build-path (hash-ref (runtime-env) 'dir) path)].}
+
+@defproc[(path-replace-extension [path path-string?] [suffix string?]) path-string?]{+
+Removes any @litchar{.} suffix from the last element of @racket[path],+and then appends @racket[suffix] to the end of the path. A @litchar{.}+at the start of a path element does not count as a file suffix.}
+
+@defidform[at-source]{+
+Expands to a function that acts like @racket[build-path] starting from
+the enclosing module's directory. That is, expands to a function
+roughly equivalent to
+
+@racketblock[(lambda args
+ (apply build-path (cons (path-only (quote-module-path))
+ args)))]
+
+If the argument to the function is an absolute path, however, the
+enclosing module's directory is ignored, and the function acts simply
+like @racket[build-path].}
+
+
+@section{Opaque Records}+
+@defproc[(opaque [key any/c] [val any/c]) any/c]{+
+Returns an opaque record that encapsulates @racket[val] with access
+allowed via @racket[key].}
+
+@defproc[(opaque-ref [key any/c] [v any/c] [failure-val any/c]) any/c]{+
+Returns the value encapsulated in @racket[v] if its is an opaque
+object with access allowed via @racket[key], @racket[failure-val] otherwise.}
+
+
+@section{Variables}+
+A @tech{variable} is a value with a name that contains an another+value. The contained value is initially undefined, and attempting to
+access the contained value before it's set results in an error where
+the variable's name is used in the error message. A variable's
+contained value can be set only once.
+
+@defproc[(variable? [v any/c]) boolean?]{+
+Returns @racket[#t] if @racket[v] is a variable, @racket[#f] otherwise.}
+
+
+@defproc[(variable [name symbol?]) variable?]{+
+Creates a variable named by @racket[name] and without a value until
+one is installed with @racket[variable-set!].}
+
+@defproc[(variable-set! [var variable?] [val any/c]) void?]{+
+Sets the value contained by @racket[var] to @racket[val] or errors if
+@racket[var] already has a contained value.}
+
+@defproc[(variable-ref [var variable?]) any/c]{+
+Returns the value contained by @racket[var] or errors if @racket[var]
+does not yet have a contained value.}
+
+
+@section{Modules and Evaluation}+
+A @deftech{module path} is a path string or a symbol, where a symbol+must contain only the letters @litchar{A}-@litchar{Z},+@litchar{a}-@litchar{z}, @litchar{A}-@litchar{Z},+@litchar{0}-@litchar{9}, @litchar{-}, @litchar{+}, @litchar{+}, or+@litchar{/}. Furthermore, @litchar{/} in a symbol module path cannot+be at the start, end, or adjacent to another @litchar{/}.+
+@defproc[(module-path? [v any/c]) boolean?]{+
+Returns @racket[#t] if @racket[v] is a @tech{module path}, @racket[#f]+otherwise.}
+
+@defproc[(build-module-path [base module-path?] [rel-path path-string?]) module-path?]{+
+Analogous to @racket[build-path], but for @tech{module paths}. The+@racket[rel-path] string must end with @litchar{.zou}, and the+characters of @racket[rel-path] must be allowable in a symbol module
+paths, except for a @litchar{.} in @filepath{.} and @filepath{..}+elements or a @litchar{.zuo} suffix.}+
+@defproc[(module->hash [mod-path module-path?]) hash?]{+
+Loads @racket[mod-path] if it has not been loaded already, and returns
+the @tech{hash table} representation of the loaded module. See also+Secref["module-protocol"]}
+
+@defproc[(dynamic-require [mod-path module-path?] [export symbol?]) any/c]{+
+Like @racket[module->hash], but extracts an exported value. The module
+referenced by @racket[mod-path] must be implemented in
+@racketmodname[zuo], @racketmodname[zuo/hygienic], or a derived
+compatible language.}
+
+@defproc[(kernel-eval [s-exp any/c]) any/c]{+
+Evaluates a term as if it appeared in a @racketmodname[zuo/kernel] module
+(but the result does not have to be a @tech{hash table}).}+
+@defproc[(kernel-env) hash?]{+
+Returns a @tech{hash table} that maps each primitive and constant name+available in the body of a @racketmodname[zuo/kernel] module to its value.}
+
+
+@section{void}+
+@defproc[(void? [v any/c]) boolean?]{+
+Returns @racket[#t] if @racket[v] is the unique @deftech{void} value,+@racket[#f] otherwise.}
+
+@defproc[(void [v any/c] ...) void?]{+
+Accepts any number of arguments and ignored them, returning the void
+value.}
+
+
+@section{Reading and Writing Objects}+
+@defproc[(string-read [str string?] [start integer? 0] [where any/c #f]) list?]{+
+Reads all S-expressions in @racket[str], starting at index
+@racket[start] and returning a list of the S-expressions (in order as
+they appeared in the string). The @racket[where] argument, if not
+@racket[#f], is used to report the source of errors.}
+
+
+@deftogether[(
+@defproc[(~v [v any/c] ...) string?]
+@defproc[(~a [v any/c] ...) string?]
+@defproc[(~s [v any/c] ...) string?]
+)]{+
+Like @realracket*[~v ~a ~s], but with no formatting options. These
+three format options corresponds to @realracket[print] style,
+@realracket[display] style, and @realracket[write] style,
+respectively.
+
+Unlike uninterned symbols in @racketmodname[racket], Zuo uninterned
+symbols format in @realracket[print] and @realracket[write] styles with
+@litchar{#<symbol:}...@litchar{>}. @tech{Opaque objects},+@tech{handles}, and @tech{variables} print with+@litchar{#<:}...@litchar{>} notation in all styles.}+
+@deftogether[(
+@defproc[(display [v any/c]) void?]
+@defproc[(displayln [v any/c]) void?]
+)]{+
+Convenience output functions that are analogous to @realracket*[display
+displayln] from @racketmodname[racket]. They use @racket[~a] and
+@racket[(fd-open-output 'stdout)].}
+
+
+@defproc[(error [v any/c] ...) void?]{+
+Errors (and exits) after printing the @racket[v]s to standard error,
+using an error color if standard error is a terminal.
+
+If the first @racket[v] is a string, its character are printed output
+@realracket[display]-style, and then @litchar{: } is printed. All+other @racket[v]s (including the first one if it's not a string) are
+combined using @racket[~v], and that resulting string is written
+@realracket[display]-style.}
+
+
+@defproc[(alert [v any/c] ...) void?]{+
+Prints to standard output using the same formatting rules as
+@racket[error], but in an alert color for terminals. This function is
+useful for simple logging and debugging tasks.}
+
+
+@defproc[(arity-error [name (or/c string? #f)] [args list?]) void?]{+
+Errors (and exits) after printing an error about @racket[name]
+receiving the wrong number of arguments, where @racket[args] are the
+arguments that were supplied.}
+
+@defproc[(arg-error [who symbol?] [what string?] [v any/c]) void?]{+
+Errors (and exits) after printing an error from @racket[who] about a
+@racket[what] expected in place of @racket[v].}
+
+
+@section{Syntax Objects}+
+A @deftech{syntax object} combines a symbol with a binding scope,+where the two are used to determine a binding when the identifier is
+used in a macro expansion.
+
+@deftogether[(
+@defproc[(identifier? [v any/c]) boolean?]
+@defproc[(syntax-e [v identifier?]) symbol?]
+@defproc[(syntax->datum [v any/c]) any/c]
+@defproc[(datum->syntax [ctx identifier?] [v any/c]) any/c]
+@defproc[(bound-identifier=? [id1 identifier?]
+ [id2 identifier?]) boolean?]
+)]{+
+Analogous to @realracket*[identifier? syntax-e syntax->datum
+datum->syntax bound-identifier=?] from @racketmodname[racket]. Plain
+symbols count as an identifier, however, and for
+@racket[bound-identifier=?], a symbol is equal only to itself. The
+@racket[datum->syntax] function always just returns its second
+argument.}
+
+@defproc[(syntax-error [message string?] [stx any/c]) void?]{+
+Exits as an error after printing @racket[message], @litchar{: }, and+@racket[(~s (syntax->datum stx))].}
+
+@deftogether[(
+@defproc[(bad-syntax [stx any/c]) void?]
+@defproc[(misplaced-syntax [stx any/c]) void?]
+@defproc[(duplicate-identifier [stx any/c]) void?]
+)]{+
+Calls @racket[syntax-error] with a suitable error message and @racket[stx].}
+
+@deftogether[(
+@defproc[(context-consumer [proc procedure]) context-consumer?]
+@defproc[(context-consumer? [v any/c]) boolean?]
+)]{+
+The @racket[context-consumer] constructor wraps a procedure to
+indicate that it expects three arguments as a macro transformer; see
+@racket[define-syntax] for more information. The
+@racket[context-consumer?] predicate recognizes values produced by
+@racket[context-consumer].}
+
+
+@section{Files, Streams, and Processes}+
+Files, input and out streams more generally, and processes are all
+represented as @tech{handles}.+
+@defproc[(handle? [v any/c]) boolean?]{+
+Returns @racket[#t] if @racket[v] is a @tech{handle}, @racket[#f]+otherwise.}
+
+@defproc[(fd-open-input [filename (or/c path-string? 'stdin integer?)]
+ [options hash? (hash)])
+ handle?]{+
+Opens a file for reading, obtains a reference to standard input when
+@racket[filename] is @racket['stdin], or (on Unix) obtains a
+reference to an existing file descriptor when @racket[filename]
+is an integer. The result handle can be used
+with @racket[fd-read] and closed with @racket[fd-close].
+
+No keys are currently recognized for @racket[options], so it must be
+an empty hash table.}
+
+
+@deftogether[(
+@defproc[(fd-open-output [filename (or/c path-string? 'stdout 'stderr integer?)]
+ [options hash? (hash)]) handle?]
+@defthing[:error hash?]
+@defthing[:truncate hash?]
+@defthing[:must-truncate hash?]
+@defthing[:append hash?]
+@defthing[:update hash?]
+@defthing[:can-update hash?]
+)]{+
+The @racket[fd-open-output] procedure opens a file for writing,
+obtains a reference to standard output when @racket[filename] is
+@racket['stdout], obtains a reference to standard error when
+@racket[filename] is @racket['stderr], or (on Unix) obtains a
+reference to an existing file descriptor when @racket[filename]
+is an integer. When opening a file,
+@racket[options] specifies options as described below, but
+@racket[options] must be empty for @racket['stdout] or
+@racket['stderr]. The result handle can be used with @racket[fd-write]
+and closed with @racket[fd-close].
+
+In @racket[options], a single key is currently recognized:
+@racket['exists]. The mapping for @racket['exists] must be one of the
+symbols accepted for @racket[#:exists] by
+@realracket[open-output-file] from @racketmodname[racket], but not
+@racket['replace] or @racket['truncate/replace], and the default
+mapping is @racket['error]. Any other key in @racket[options] is an
+error.
+
+The @racket[:error], @racket[:truncate], @racket[:must-truncate],
+@racket[:append], @racket[:update], and @racket[:can-update] hash
+tables each map @racket['exists] to the corresponding mode.}
+
+@defproc[(fd-close [handle handle?]) void?]{+
+Closes the file or stream associated with @racket[handle], if it
+refers to an open input or output stream. Any other kind of
+@racket[handle] triggers an error.}
+
+@defproc[(fd-read [handle handle?] [amount (or/c integer? eof 'avail)]) (or/c string? eof)]{+
+Reads from the input file or input stream associated with
+@racket[handle], erroring for any other kind of @racket[handle]. The
+@racket[amount] argument can be a non-negative integer to read up to
+that many bytes, @racket[eof] to read all content up to an
+end-of-file, or @racket['avail] where supported (on Unix) to read as
+many bytes as available in non-blocking mode. The result is
+@racket[eof] if @racket[amount] is not @racket[0] or @racket['avail]
+and no bytes are available before an end-of-file; otherwise, it is a
+string containing the read bytes.
+
+The number of bytes in the returned string can be less than
+@racket[amount] if the number of currently available bytes is less
+than @racket[amount] but at least one byte. The result can be an empty
+string only if @racket[amount] is @racket[0] or @racket['avail].}
+
+@defproc[(fd-write [handle handle?] [str string?]) void?]{+
+Writes the bytes of @racket[str] to the output file or output stream
+associated with @racket[handle], erroring for any other kind of
+@racket[handle].}
+
+@defproc[(fd-terminal? [handle handle?] [check-ansi? any/c #f]) boolean?]{+
+Returns @racket[#t] if the open input or output stream associated with
+@racket[handle] is a terminal, @racket[#f] otherwise. If
+@racket[check-ansi?] is true, the result is @racket[#t] only if the
+terminal is likely to support ANSI escape codes.
+
+When using ANSI escapes that change the character style, consider
+bracketing a change and restore with @racket[suspend-signal] and
+@racket[resume-signal] to avoid leaving a terminal in a mangled state
+after Ctl-C.}
+
+@defproc[(fd-valid? [handle handle?]) boolean?]{+
+Reports whether a file descriptor opened by appears to be a valid file
+descriptor, which is potentially useful after supplying an integer to
+@racket[fd-open-input] or @racket[fd-open-output] }
+
+@deftogether[(
+@defproc[(file->string [name path-string]) string?]
+@defproc[(display-to-file [str string?] [name path-string] [options hash? (hash)]) void?]
+)]{+
+Convenience function to open @racket[name] and read its content into a
+string or to write @racket[str] as its new content.}
+
+@defthing[eof any/c]{+
+A constant representing an end-of-file.}
+
+@deftogether[(
+@defproc[(cleanable-file [name path?]) handle?]
+@defproc[(cleanable-cancel [cleanable handle?]) void?]
+)]{+
+The @racket[cleanable-file] function register @racket[name] as a file
+name to delete on any exit, including errors or termination signals,
+unless @racket[cleanable-cancel] is called on the handle to cancel the
+clean-up action.}
+
+
+@defproc[(process [executable path-string?] [args string-tree?] ... [options hash? (hash)]) hash?]{+
+Creates a new process to run @racket[executable] with arguments as the
+flattened sequence @racket[args]. The result is a @tech{hash table} that at least+contains the key @racket['process] mapped to a handle representing the
+new process. The process handle can be used with @racket[process-wait]
+and @racket[process-status].
+
+If @racket[options] is supplied, it controls the process creation and
+may cause additional keys to be mapped in the result. The recognized
+keys are as follows, and supplying an unrecognized key in
+@racket[options] is an error:
+
+@itemlist[
+
+@item{@racket['dir] mapped to a path string: the working directory of+ the new porcess; if @racket[executable] is a relative path, it
+ is relative to this directory}
+
+@item{@racket['env] mapped to a list of pairs of strings: environment+ variables for the new process, where the @racket[car] or each
+ pair is an environment variable name and the @racket[cdr] is its
+ value}
+
+@item{@racket['stdin] mapped to @racket['pipe]: creates a new output+ stream connected to the new process's standard input; the result
+ hash table contains @racket['stdin] mapped to the new stream handle}
+
+@item{@racket['stdin] mapped to an input stream: supplies (a copy of)+ the input stream as the new process's standard input}
+
+@item{@racket['stdout] mapped to @racket['pipe]: creates a new input+ stream connected to the new process's standard output; the
+ result hash table contains @racket['stdout] mapped to the new
+ stream handle}
+
+@item{@racket['stdout] mapped to an output stream: supplies (a copy+ of) the output stream as the new process's standard input}
+
+@item{@racket['stderr] mapped to @racket['pipe]: creates a new input+ stream connected to the new process's standard error; the result
+ hash table contains @racket['stderr] mapped to the new stream
+ handle}
+
+@item{@racket['stderr] mapped to an output stream: supplies (a copy+ of) the output stream as the new process's standard error}
+
+@item{@racket['cleanable?] mapped to boolean (or any value): if+ @racket[#f], the Zuo process can exit without waiting for the
+ created process to terminate; otherwise, and by default, the Zuo
+ process waits for every processes created with @racket[process]
+ to terminate before exiting itself, whether exiting normally, by
+ an error, or by a received termination signal (such as Ctl-C).}
+
+@item{@racket['exact?] mapped to boolean (or any value): if not+ @racket[#f], a single @racket[arg] must be provided, and it is
+ provided as-is for the created process's command line on
+ Windows. A non-@racket[#f] value for @racket['exact?] is not
+ allowed on Unix.}
+
+@item{@racket['exec?] mapped to boolean (or any value): if not+ @racket[#f], the target executable is run in the current
+ process, after waiting for any other subprocesses and deleting
+ cleanables. A non-@racket[#f] value for @racket['exact?] is not
+ allowed on Windows or, more generally, when @racket[(hash-ref
+ (runtime-env) 'can-exec?)] produced @racket[#f].}
+
+]
+
+See also @racket[shell].}
+
+@defproc[(process-wait [process handle?] ...) handle?]{+
+Waits until the process represented by a @racket[process] has
+terminated, erroring if a @racket[process] is any other kind of
+handle. The result is the handle for a terminated process that's one
+of the argument @racket[process] handles; waiting again on the same
+handle will produce a result immediately.}
+
+@defproc[(process-status [process handle?]) (or/c 'running integer?)]{+
+Returns @racket['running] if the process represented by
+@racket[process] is still running, the exit value if the process has
+exited (@racket[0] normally means succes), erroring for any other kind
+of handle.}
+
+
+@defproc[(find-executable-path [name path-string?]) (or/c path-string? #f)]{+
+Returns an absolute path to a file @racket[name], potentially by
+consulting the @envvar{PATH} environment variable. If @racket[name] is+an absolute path already, and if a file @racket[name] exists, the
+@racket[name] is returned as-is---except that @filepath{.exe} is added+on Windows if it produces an existent path name while @racket[name] by
+itself does not exist. Otherwise, if a file exists relative to path in
+@envvar{PATH} (with @filepath{.exe} potentially added on Windows),+that file's path is returned.
+
+The @envvar{PATH} environment variable is treated as a list of+@litchar{:}-separated paths on Unix and @litchar{;}-separated paths on+Windows. On Windows, the current directory is automatically added to
+the start of @envvar{PATH}.}+
+@deftogether[(
+@defproc[(string->shell [str string?]) string?]
+@defproc[(shell->strings [str string?] [starts-exe? any/c #f]) list?]
+)]{+
+The @racket[string->shell] function converts a string to a
+command-line fragment that encodes the same string. The
+@racket[shell->strings] function takes a command-line fragment and
+parses it into a list of strings in the same way the shell would. On
+Windows, the shell parses an executable name differently than
+arguments in a command, so provide a true value as
+@racket[starts-exe?] if the command-line fragment @racket[str] starts
+with an executable name.}
+
+
+@section{Filesystem}+
+@defproc[(stat [name path-string?] [follow-links? any/c #t]) (or/c hash? #f)]{+
+Returns information about the file, directory, or link referenced by
+@racket[name]. If @racket[follow-links?] is @racket[#f], then when
+@racket[name] refers to a link, information is reported about the
+link; otherwise, information is reported about the target of a link.
+
+If no such file, directory, or link exists, the result is @racket[#f].
+Otherwise, the hash table has similar keys and values as
+@realracket[file-or-directory-stat] from @racketmodname[racket], but
+with only certain keys per platform:
+
+@itemlist[
+
+ @item{Unix: @racket['device-id], @indexed-racket['inode],+ @racket['mode], @racket['type] (abbreviated),
+ @racket['hardlink-count], @racket['user-id],
+ @racket['group-id], @racket['device-id-for-special-file],
+ @racket['size], @racket['block-size], @racket['block-count],
+ @racket['access-time-seconds], @racket['modify-time-seconds],
+ @racket['change-time-seconds],
+ @racket['access-time-nanoseconds],
+ @racket['modify-time-nanoseconds], and
+ @racket['change-time-nanoseconds]}
+
+ @item{Windows: @racket['device-id], @indexed-racket['inode],+ @racket['mode] (read and write bits only), @racket['type]
+ (abbreviated), @racket['hardlink-count], @racket['size],
+ @racket['access-time-seconds], @racket['modify-time-seconds],
+ @racket['creation-time-seconds],
+ @racket['access-time-nanoseconds],
+ @racket['modify-time-nanoseconds], and
+ @racket['creation-time-nanoseconds]}
+
+]
+
+The abbreviated @racket['type] field contains @racket['file],
+@racket['dir], or @racket['link], with @racket['link] only on Unix and
+only when @racket[follow-links?] is @racket[#f].}
+
+@defproc[(ls [dir path-string?]) list?]{+
+Returns a list of path strings for files in @racket[dir].}
+
+@defproc[(ls* [dir path-string?]) list?]{+
+Like @racket[ls], but builds a path using @racket[dir] for each
+element of the result list.}
+
+@defproc[(rm [name path-string?]) void?]{+
+Deletes the file or link @racket[name].}
+
+@defproc[(rm* [name path-string?]) void?]{+
+Deletes the file, directory, or link @racket[name], including the
+directory content if @racket[name] refers to a directory (and not to a
+link to a directory). Unlike @racket[rm], it's not an error if
+@racket[name] does not refer to an existing file, directory, or link.}
+
+@defproc[(mv [name path-string?] [new-name path-string?]) void?]{+
+Renames the file, directory, or link @racket[name] to @racket[new-name].}
+
+@defproc[(mkdir [dir path-string?]) void?]{+
+Creates a directory @racket[dir].}
+
+@defproc[(mkdir-p [dir path-string?]) void?]{+
+Creates a directory @racket[dir] if it does not already exist, along
+with its ancector directories.}
+
+@defproc[(rmdir [dir path-string?]) void?]{+
+Deletes a directory @racket[dir].}
+
+@defproc[(symlink [target path-string?] [name path-string?]) void?]{+
+Creates a symbolic link @racket[name] with the content @racket[target]. This
+function is not supported on Windows.}
+
+@defproc[(readlink [name path-string?]) void?]{+
+Gets the content of a link @racket[name]. This function is not
+supported on Windows.}
+
+@defproc[(cp [source path-string?] [destination path-string?]) void?]{+
+Copies the file at @racket[source] to @racket[destination],
+preserving permissions and replacing (or attempting to replace)
+@racket[destination] if it exists.}
+
+@defproc[(cp* [source path-string?] [destination path-string?]) void?]{+
+Copies the file, directory, or link @racket[source] to a corresponding
+new file, directory, or link @racket[destination], including the
+directory content if @racket[source] refers to a directory (and not to
+a link to a directory),.}
+
+@deftogether[(
+@defproc[(file-exists? [name path-string?]) booelan?]
+@defproc[(directory-exists? [name path-string?]) booelan?]
+@defproc[(link-exists? [name path-string?]) booelan?]
+)]{+
+Uses @racket[stat] to check for a file, directory, or link,
+respectively.}
+
+
+@section{Run Time Configuration}+
+@defproc[(runtime-env) hash?]{+
+Returns a @tech{hash table} containing information about the current+Zuo process. The hash table includes the following keys:
+
+@itemlist[
+
+@item{@racket['args]: comment-line arguments provided when the+ process was started, not counting Zuo configuration arguments or
+ the name of a script to run}
+
+@item{@racket['dir]: the current directory}+
+@item{@racket['env]: a list of pairs of strings for environment variables}+
+@item{@racket['script]: the script provided to Zuo to run, which might+ be @racket[""] to indicate a script read from standard input}
+
+@item{@racket['exe]: an absolute path for the running Zuo executable}+
+@item{@racket['system-type]: @racket['unix] or @racket['windows]}+
+@item{@racket['sys-dir] (Windows only): the path to the system directory}+
+@item{@racket['can-exec?]: a boolean whether @racket[process] supports+ a true value for the @racket['exec?] option}
+
+@item{@racket['version]: Zuo's version number as an integer}+
+]}
+
+@defproc[(system-type) symbol?]{+
+Returns @racket[(hash-ref (runtime-env) 'system-type)].}
+
+@defproc[(current-time) pair?]{+
+Reports the current wall-clock time as a pair: seconds since January
+1, 1970 and additional nanoseconds.}
+
+@defproc[(dump-image-and-exit [output handle?]) void?]{+
+Writes an image of the current Zuo process to @racket[output], which
+must be an open output file or stream, and then exits.
+
+This function is intended to be used after some set of modules has
+been loaded, so that the loaded modules are included in the image. The
+dump fails if if any @tech{handle} is encountered as reachable from+loaded modules, however.}
+
+@defproc[(exit [status integer? 0]) void?]{+
+Exits the Zuo process with the given @racket[status], where @racket[0]
+normally means ``success.''}
+
+
+@deftogether[(
+@defproc[(suspend-signal) void?]
+@defproc[(resume-signal) void?]
+)]{+
+Suspends or resumes recognition of termination signals, such as Ctl-C.
+Calls can be nested, and each call to @racket[suspend-signal] must be
+balanced by a call to @racket[resume-signal] to re-enable signal
+handling.}
--- /dev/null
+++ b/zuo-doc/overview.scrbl
@@ -1,0 +1,324 @@
+#lang scribble/manual
+@(require (for-label zuo-doc/fake-zuo))
+
+@title{Zuo Overview}+
+Zuo is a Racket variant in the sense that program files start with
+@hash-lang[], and the module path after @hash-lang[] determines the
+parsing and expansion of the file content. Zuo, however, has a
+completely separate implementation. So, even though its programs start
+with @hash-lang[], Zuo programs are not meant to be run via Racket.
+
+While @racket[@#,hash-lang[] @#,racketmodname[zuo/base]] accesses a
+base language, the primary intended use of Zuo is with
+@racket[@#,hash-lang[] @#,racketmodname[zuo]], which includes the
+@racketmodname[zuo/build] library for using @seclink["zuo-build"]{Zuo+as a @tt{make} replacement}.+
+The name ``Zuo'' is derived from the Chinese word for ``make.''
+
+
+@section[#:tag "running"]{Building and Running Zuo}+
+Compile @filepath{zuo.c} from the Zuo sources with a C compiler. No+additional are files needed for compilation, other than system and
+C-library headers. No compiler flags should be needed, although flags
+like @exec{-o zuo} or @exec{-O2} are a good idea.+
+You can also use @exec{configure}, @exec{make}, and @exec{make+install}, where @exec{make} targets mostly invoke a Zuo script after+compiling @filepath{zuo.c}. If you don't use @exec{configure} but+compile to @exec{zuo} in the current directory, then @exec{./zuo+build.zuo} and @exec{./zuo build.zuo install} (omit the @exec{./} on Windows)+will do the same thing as @exec{make} and @exec{make install} with+a default configuration.
+
+The Zuo executable runs only modules. If you run Zuo with no
+command-line arguments, then it loads @filepath{main.zuo} in the+current directory. Otherwise, the first argument to Zuo is a file to
+run or a directory containing a @filepath{main.zuo} to run, and+additional arguments are delivered to that program via the
+@racket[runtime-env] procedure. Either way, if this initial script has
+a @racketidfont{main} submodule, the submodule is run.+
+Note that starting Zuo with the argument @filepath{.} equivalent to+the argument @filepath{./main.zuo}, which is a convenient shorthand+for using @exec{zuo} as a replacement for @exec{make} while still+passing arguments. When Zuo receives the empty string (which would be
+invalid as a file path) as a first argument, it reads a module from
+standard input.
+
+
+@section{Library Modules and Startup Performance}+
+Except for the built-in @racketmodname[zuo/kernel] language module,
+Zuo finds languages and modules through a collection of libraries. By
+default, Zuo looks for a directory @filepath{lib} relative to the+executable as the root of the library-collection tree. You can supply
+an alternate collection path with the @Flag{X} command-line flag.+
+You can also create an instance of Zuo with a set of libraries
+embedded as an image. Embedding an image has two advantages:
+
+@itemlist[
+
+ @item{No extra directory of library modules is necessary, as long as+ all relevant libraries are embedded.}
+
+ @item{Zuo can start especially quickly, competitive with the fastest+ command-line programs.}
+
+]
+
+The @filepath{local/image.zuo} script included with the Zuo sources+generates a @filepath{.c} file that is a copy of @filepath{zuo.c} plus+embedded modules. By default, the @racketmodname[zuo] module and its
+dependencies are included, but you can specify others with
+@DPFlag{lib}. In addition, the default collection-root path is+disabled in the generated copy, unless you supply
+@DFlag{keep-collects} when running @filepath{image.zuo}.+
+When you use @exec{configure} and @exec{make} @exec{./zuo build.zuo} to+build Zuo, the default build target creates a @filepath{to-run/zuo}+that embeds the @racketmodname[zuo] library, as well as a
+@filepath{to-install/zuo} that has the right internal path to find+other libraries after @exec{make install} or @exec{./zuo build.zuo+install}.
+
+You can use images without embedding. The @racket[dump-image-and-exit]
+Zuo kernel permitive creates an image containing all loaded modules,
+and a @Flag{B} or @DFlag{boot} command-line flag for Zuo uses the+given boot image on startup.
+
+A boot image is machine-independent, whether in a stand-alone file or
+embedded in @filepath{.c} source.+
+
+@section{Embedding Zuo in Another Application}+
+Zuo can be embedded in a larger application, with or without an
+embedded boot image. To support embedding, compile @filepath{zuo.c} or+the output of @filepath{local/image.zuo} with the @tt{ZUO_EMBEDDED}+preprocessor macro defined (to anything); the @filepath{zuo.h} header+will be used in that case, and @filepath{zuo.h} should also be used by+the embedding application. Documentation for the embedding API is
+provided as comments within @filepath{zuo.h}.+
+
+@section{Zuo Datatypes}+
+Zuo's kernel supports the following kinds of data:
+
+@itemlist[
+
+ @item{booleans;}+
+ @item{integers as 64-bit two's complement with modular arithmetic}+
+ @item{strings as byte strings (optionally prefixed with @litchar{#}+ and with @litchar{\n}, @litchar{\r}, @litchar{\t},+ @litchar{\"}, @litchar{\\}, and octal escapes);}+
+ @item{symbols, both interned (never garbage collected) and+ uninterned;}
+
+ @item{lists;}+
+ @item{@deftech{hash tables}, which are symbol-keyed persistent maps+ (and don't actually employ hashing internally);}
+
+ @item{procedures, including first-class continuations reified as+ procedures;}
+
+ @item{@deftech{variables}, which are named, set-once, single-valued+ containers;}
+
+ @item{@deftech{opaque objects} that pair a key and a value, where the+ value can be accessed only by supplying the key (which is
+ typically kept private using lexical scope); and}
+
+ @item{@deftech{handles}, which represent system resources like files+ or processes.}
+
+]
+
+Notable omissions include floating-point numbers, characters, Unicode
+strings, and vectors. Paths are represented using byte strings (with
+an implied UTF-8 encoding for Windows wide-character paths).
+
+
+@section{Zuo Implementation and Macros}+
+The @filepath{zuo.c} source implements @racketmodname[zuo/kernel],+which is a syntactically tiny language plus around 100 primitive
+procedures. Since Zuo is intended for scripting, it's heavy on
+filesystem, I/O, and process primitives, and almost half of the
+primitives are for those tasks (while another 1/3 of the primitives are
+just for numbers, strings, and @tech{hash tables}).+
+Zuo data structures are immutable except for @tech{variable} values,+and even a variable is set-once; attempting to get a value of the
+variable before it has been set is an error. (Variables are used to
+implement @racket[letrec], for example.) Zuo is not purely functional,
+because it includes imperative I/O and errors, but it actively
+discourages in-process state by confining imperative actions to
+external interactions. Along those lines, an error in Zuo always
+terminates the program; there is no exception system (and therefore no
+way within Zuo to detect early use of an unset variable).
+
+The @racketmodname[zuo] language is built on top of
+@racketmodname[zuo/kernel], but not directly. There's an internal
+``looper'' language that just adds simple variants of @racket[letrec],
+@racket[cond], and @racket[let*], because working without those is
+especially tedious. Then there's an internal ``stitcher'' language
+that is the only use of the ``looper'' language; it adds its own
+@racket[lambda] (which implicit @racket[begin]) @racket[let] (with
+multiple clauses), @racket[let*], @racket[letrec] (with multiple
+binding clauses), @racket[and], @racket[or], @racket[when],
+@racket[unless], and a kind of @racket[define] and @racket[include].
+
+Two macro implementations are built with the ``stitcher'' layer. One
+is based on the same set-of-scopes model as Racket, and that macro
+system is used for and provided by @racketmodname[zuo/hygienic]. The
+other is non-hygienic and uses a less expressive model of scope, which
+a programmer might notice if, say, writing macro-generating macros;
+that macro system is used for and provided by @racketmodname[zuo],
+because it's a lot faster and adequate for most scripting purposes.
+The two macro system implementations are mostly the same source, which
+is parameterized over the representation of scope and binding, and
+implemented through a combination of @racketmodname[zuo/datum] and the
+``stitcher'' layer's @racket[include].
+
+Naturally, you can mix and match @racketmodname[zuo] and
+@racketmodname[zuo/hygienic] modules in a program, but you can't use
+macros from one language within the other language. More generally,
+Zuo defines a @hash-lang[] protocol that lets you build arbitrary new
+languages (from the character/byte level), as long as they ultimately
+can be expressed in @racketmodname[zuo/kernel].
+
+
+@section[#:tag "module-protocol"]{Zuo Module Protocol}+
+At Zuo's core, a module is represented as a @tech{hash table}. There+are no constraints on the keys of the hash table, and different layers
+on top of the core module protocol can assign meanings to keys. For
+example, the @racketmodname[zuo] and @racketmodname[zuo/hygienic]
+layers use a common key for accessing @racket[provide]d bindings, but
+different keys for propagating binding information for macro
+expansions.
+
+The core module system assigns a meaning to one key,
+@racket['read-and-eval], which is supplied by a module that implements
+a @hash-lang[] language. The value of @racket['read-and-eval] is a
+procedure of three arguments:
+
+@itemlist[
+
+ @item{a string for the text of a module using the language,}+
+ @item{a position within the string that starts a module body after+ @hash-lang[] and the language name, and}
+
+ @item{a module path that will be mapped to the result of evaluating+ the module (i.e., the path to the text's source).}
+
+]
+
+The procedure must return a hash table representing the evaluated
+module. A @racket['read-and-eval] procedure might use
+@racket[string-read] to read input, it might use
+@racket[kernel-eval] to evaluate read or generated terms, and it might
+use @racket[module->hash] to access other modules in the process of
+parsing a new module---but a @racket['read-and-eval] procedure is
+under no obligation to use any of those.
+
+A call @racket[(module->hash _M)] primitive checks whether the module
+@racket[_M] is already loaded and returns its hash table if so. The
+@racket[zuo/kernel] module is always preloaded, but other modules may
+be preloaded in an image that was created by
+@racket[dump-image-and-exit]. If a module @racket[_M] is not already
+loaded, @racket[module->hash] reads the beginning of @racket[_M]'s
+source to parse the @hash-lang[] specification and get the path of the
+language module @racket[_L]; a recursive call @racket[(module->hash
+_L)] gets @racket[_L], and @racket[_L]'s @racket['read-and-eval]
+procedure is applied to the source of @racket[_M] to get @racket[_M]'s
+representation as a hash. That representation is both recorded for
+future use and returned from the original @racket[(module->hash _M)]
+call.
+
+The Zuo startup sequence assigns a meaning to a second key in a
+module's hash table: @racket['submodules]. The value of
+@racket['submodules] should be a hash table that maps keys to thunks,
+each representing a submodule. When Zuo runs an initial script, it
+looks for a @racket['main] submodule and runs it (i.e., calls the
+thunk) if present.
+
+
+@section[#:tag "paths"]{Path Handling}+
+Working with paths is a central issue in many scripting tasks, and
+it's certainly a key problem for a build system. Zuo embeds some
+specific choices about how to work with paths:
+
+@itemlist[
+
+ @item{Zuo relies on syntactic normalization of paths. For example,+ starting with @filepath{a/b} and building @filepath{../c} from+ there produces the path @filepath{a/c}, even if @filepath{a/b}+ on the filesystem is a symbolic link to to the relative path
+ @filepath{x/y/z}---in which case the filesystem would resolve+ @filepath{a/b/../c} the same as @filepath{a/x/y/z/../c}, which+ is @filepath{a/z/y/c} and not @filepath{a/c}.+
+ In short, mixing directory symbolic links with Zuo's path
+ functions can be different than what the filesystem would do,
+ so take care to avoid cases that would not work. Symbolic links
+ to files will not create problems, so consider just never using
+ directory links.}
+
+ @item{There is no way to change the working directory of the Zuo+ process. Having a fixed current directory means that relative
+ paths work in many more situations than they would otherwise.
+ Relative paths are communicated to system facilities still in
+ relative form, leaving it up to the operating system to resolve
+ the path relative to the current working directory.
+
+ When starting a subprocess, you can pick the working directory
+ for the subprocess. In that case, you must take care to adjust
+ relative paths communicated to the process, and
+ @racket[find-relative-path] can help.}
+
+ @item{Zuo uses and propagates relative paths as much as possible.+ This convention is partly enabled by the fact that the working
+ directory cannot change within the Zuo process. It also helps
+ avoid trouble from a mismatch between syntactic and
+ filesystem-based path resolution, as might be created with
+ symbolic directory links; for example, even if you used
+ symbolic links or one of multiple filesystem mounts to access a
+ Zuo working tree, staying within that tree avoids complications
+ with the path that reaches the tree.
+
+ The way that you start a Zuo script affects the script's
+ operation in terms of absolute or relative paths. If you start
+ a Zuo script with a relative patch, such as @exec{zuo+ scripts/go.zuo}, the @racket[quote-module-path] form will
+ report a relative path for the enclosing script. If you start
+ it with an absolute path, such as @exec{zuo+ /home/racket/scripts/go.zuo}, then @racket[quote-module-path]
+ reports an absolute path. Similarly, with
+ @racketmodname[zuo/build], when you use a relative path to
+ refer to a dependency, then information about the dependency
+ can be recorded in relative form, but referring to a dependency
+ with an absolute path means that information is recorded with
+ an absolute path (even if that could be made relative to the
+ dependent target's path).}
+
+ @item{The @racket[build/build] library encourages an explicit+ distinction between ``source'' and ``build'' directories,
+ neither of which necessarily corresponds to the current working
+ directory. This distinction, along with the fact that the
+ working directory doesn't change, helps to create composable
+ build scripts. See @secref["build-targets"] for more
+ information.}
+
+]
--- /dev/null
+++ b/zuo-doc/real-racket.rkt
@@ -1,0 +1,25 @@
+#lang at-exp racket/base
+(require scribble/manual
+ (for-syntax racket/base)
+ (for-label racket/base
+ racket/contract/base
+ racket/cmdline))
+
+(provide realracket
+ realracket*
+ (for-label any/c
+ listof
+ ->))
+
+(define-syntax (realracket stx)
+ (syntax-case stx ()
+ [(_ id) @#`racket[#,(datum->syntax #'here (syntax-e #'id))]]))
+
+(define-syntax (realracket* stx)
+ (syntax-case stx ()
+ [(_ id) @#'realracket[id]]
+ [(_ id1 id2) @#'elem{@realracket[id1] and @realracket[id2]}]+ [(_ id1 id2 id3) @#'elem{@realracket[id1], @realracket[id2], and @realracket[id3]}]+ [(_ id0 id ...) @#'elem{@realracket[id0], @realracket*[id ...]}]))+
+
--- /dev/null
+++ b/zuo-doc/zuo-build.scrbl
@@ -1,0 +1,608 @@
+#lang scribble/manual
+@(require scribble/bnf
+ (for-label zuo-doc/fake-zuo
+ racket/contract/base)
+ "defzuomodule.rkt")
+
+@(define shake-url "https://shakebuild.com/")
+
+@title[#:tag "zuo-build"]{Zuo as a @tt{make} Replacement}+
+@defzuomodule[zuo/build]
+
+The @racketmodname[zuo/build] library is modeled on @exec{make} and+@hyperlink[shake-url]{Shake} for tracking dependencies+and build steps. The library has two layers:
+
+@itemlist[
+
+ @item{The core @tech{target} datatype and build engine, as reflected+ by functions like @racket[target] and @racket[build].}
+
+ @item{A makefile-like, declarative form for dependencies as+ implemented by the @racket[make-targets] function.}
+
+]
+
+A @tech{target} represents either an input to a build (such as a+source file) or a generated output, and a target can depend on any
+number of other targets. A target's output is represented by 40-character
+string that is normally a SHA-1 hash; the @racket[build] procedure
+records hashes and dependencies in a database located alongside
+non-input targets, so it can avoid rebuilding targets when nothing has
+changed since the last build. Unlike @tt{make}, timestamps are used+only as a shortcut to avoiding computing the SHA-1 of a file (i.e., if
+the timestamp has not changes, the SHA-1 result is assumed to be
+unchanged).
+
+``Recursive make'' is encouraged in the sense that a target's build
+rule can call @racket[build] to start a nested build, or it can call
+@racket[build/dep] to build or register a dependency that is
+discovered in the process of building.
+
+@section[#:tag "make-target"]{Creating Targets}+
+Construct a @deftech{target} with either @racket[input-file-target]+(given a file name), @racket[input-data-target] (given a value whose
+@racket[~s] form is hashed), or @racket[target] (given a filename for a
+real target or a symbol for a @tech{phony} target).+
+Only a target created with @racket[target] can have dependencies, but
+they are not specified when @racket[target] is called, because
+computing dependencies for a target may involve work that can be
+skipped if the target isn't needed. Instead, @racket[target] takes a
+@racket[_get-rule] procedure that will be called if the dependencies
+are needed. The @racket[_get-rule] procedure returns up to three
+results in a @racket[rule] record: a list of dependencies; the hash of
+an already-built version of the target, if one exists, where
+@racket[file-sha1] is used by default; and a @racket[_rebuild]
+procedure that is called if the returned hash, the hash of
+dependencies (rebuilt if needed), and recorded results from a previous
+build together determine that a rebuild is needed.
+
+When a target's @racket[_rebuild] function is called, it optionally
+returns a hash for the result of the build if the target's
+@racket[rule] had one, otherwise @racket[file-sha1] is used to get a
+result hash. Either way, it's possible that the result hash is the
+same the one returned by @racket[_get-rule]; that is, maybe a
+dependency of the target changed, but the change turned out not to
+affect the built result. In that case, rebuilding for other targets
+that depend on this one can be short-circuited.
+
+Finally, in the process of building a target, a @racket[_rebuild]
+procedure may discover additional dependencies. A discovered
+dependency sent to @racket[build/dep] is recorded as a dependency of
+the target in addition to the ones that were reported by
+@racket[_get-deps]. Any changes in these additional targets trigger a
+rebuild of the target in the future. Meanwhile, the build system
+assumes that if none of the dependencies change, then the set of
+additional dependencies discovered by @racket[_rebuild] would be the
+same; that assumption allows the build system to skip
+@racket[_rebuild] and its discoveries if none of the dependencies have
+changed.
+
+A @deftech{phony} target is like a regular target, but one that always+needs to be rebuilt. A typical use of a phony target is to give a name
+to a set of ``top-level'' targets or to implement an action along the
+lines of @exec{make install}. Create a phony target with+@racket[target] and a symbol name.
+
+A target can declare multiple outputs by specifying additional outputs
+in a @racket['co-outputs] option. The target's @racket[_rebuild]
+procedure will be called if any of the additional outputs are missing
+or not consistent with the result of an earlier build.
+
+In many cases, a plain path string can be used as a target as a
+shorthand for applying @racket[input-file-target] to the path string.
+
+@section[#:tag "build-targets"]{Building Targets}+
+There is no global list of targets that @racket[build] draws from.
+Instead, @racket[build] starts with a given target, and it learns
+about other targets a @racket[_get-dep] procedures return them and as
+@racket[_rebuild] procedures expose them via @racket[build/dep]. If
+@racket[build] discovers multiple non-input targets with the same
+filename, then it reports an error.
+
+The @racket[build/command-line] function is a convenience to implement
+get @tt{make}-like command-line handling for building targets. The+@racket[build/command-line] procedure takes a list of targets, and it
+calls @racket[build] on one or more of them based on command-line
+arguments (with help from @racket[find-target]).
+
+All relative paths are considered relative to the start-time current
+directory. This convention works well for running a Zuo script that's
+in a source directory while the current directory is the build
+directory, as long as the script references source files with
+@racket[at-source] to make them relative to the script. For
+multi-directory builds, a good convention is for each directory to
+have a script that exports a @racketidfont{targets-at} procedure,+where @racketidfont{targets-at} takes an @racket[_at-dir] procedure+(supplied as just @racket[build-path] by default) to apply to each
+target path when building a list of targets, and a hash table of
+variables (analogous to variables that a makefile might provide to
+another makefile via @tt{make} arguments).+
+As a further convenience following the @racketidfont{targets-at}+model, the @racket[provide-targets] form takes an identifier for such a
+@racketidfont{targets-at} procedure, and it both exports+@racketidfont{targets-at} and creates a @racket[main] @tech{submodule}+that calls @racket[build/command-line*] on with the
+@racketidfont{targets-at} procedure.+
+As a naming convention, consider using @filepath{main.zuo} in a+directory where build results are intended to be written, but use
+@filepath{build.zuo} in a source directory that is intended to be+(potentially) separate from the build directory. In other words, use
+@filepath{main.zuo} as a replacement for @filepath{Makefile} and+@filepath{build.zuo} as a replacement for @filepath{Makefile.in} in a+@exec{configure}-style build. You may even have a @exec{configure}+script that generates a @filepath{main.zuo} script in a build+directory so that @exec{zuo .} is a replacement for @exec{make}.+The generated @filepath{main.zuo} could import the source directory's+@filepath{build.zuo} and calls @racket[build/command-line*] on with+the imported @racketidfont{targets-at} procedure plus+@racket[at-source]:
+
+@racketblock[
+@#,hash-lang[] @#,racketmodname[zuo]
+(require @#,elem[@racketvalfont{"}@nonterm{srcdir}@racketvalfont{/build.zuo"}])+(build/command-line* targets-at at-source)
+]
+
+However, correctly encoding @nonterm{srcdir} can be tricky when+working from something like a shell configure script or batch file to
+generate @filepath{main.zuo}. You may find it easier to write the path+to a separate file using a shell-variable assignment syntax, and then
+have the generated @filepath{main.zuo} read from that file. The+@racket[bounce-to-targets] form implements that pattern. For example,
+if @filepath{Mf-config} is written in the same directory with a+@litchar{srcdir=} line to specify the source directory (where no+escapes are needed for the path after @litchar{=}), then a+@filepath{mzin.zuo} of them form+
+@racketblock[
+@#,hash-lang[] @#,racketmodname[zuo]
+(bounce-to-targets "Mf-config" 'srcdir "build.zuo")
+]
+
+reads @filepath{Mf-config} to find and dispatch to+@filepath{build.zuo} in the same way as the earlier example module.+
+
+@section{Recording Results}+
+Build results are stored in a @filepath{_zuo.db} file in the same+directory as a target (by default). Cached SHA-1 results with associated
+file timestamps are stored in a @filepath{_zuo_tc.db} in the same+directory (i.e., the cached value for dependency is kept with the
+target, which is in a writable build space, while an input-file target
+might be in a read-only source space). A target's options can specify
+an alternative directory to use for @filepath{_zuo.db} and+@filepath{_zuo_tc.db}. Timestamp recording in @filepath{_zuo_tc.db}+is disabled if the @envvar{SOURCE_DATE_EPOCH} environment variable is set.+
+In the unfortunate case that a @filepath{_zuo.db} or+@filepath{_zuo_tc.db} file gets mangled, then it may trigger an error+that halts the build system, but the @filepath{_zuo.db} or+@filepath{_zuo_tc.db} file will be deleted in reaction to the error.+Another attempt at the build should recover, while perhaps rebuilding
+more than it would have otherwise, since the result of previous builds
+might have been lost.
+
+Specify a location for the @filepath{_zuo.db} and+@filepath{_zuo_tc.db} files associated with a target via the+@racket['db-dir] target option. The @racket[make-targets] function
+recognizes as @racket[:db-dir] clause to set the option for all of the
+targets that it creates.
+
+@section{Parallelism}+
+A build runs in a @tech{threading context}, so a target's+@racket[_get-deps] or @racket[_rebuild] procedure can use
+@racket[thread-process-wait] can be used to wait on a process. Doing
+so can enable parallelism among targets, depending on the
+@racket['jobs] option provided to @racket[build] or
+@racket[build/command-line], a @DFlag{jobs} command-line argument+parsed by @racket[build/command-line], or the @envvar{ZUO_JOBS}+environment variable.
+
+When calling @racket[build] for a nested build from a target's
+@racket[_get-deps] or @racket[_rebuild] procedures, supply the
+@tech{build token} that is passed to @racket[_get-deps] to the+@racket[build] call. That way, parallelism configured for the
+enclosing build will be extended to the nested build.
+
+
+@section{Build API}+
+
+@defproc[(target? [v any/c]) boolean?]{+
+Returns @racket[#t] if @racket[v] is @tech{target}, @racket[#f]+otherwise.}
+
+
+@defproc[(target-name [t target?]) (or/c symbol? path-string?)]{+
+Returns the name of a target, which is a path for most targets, but a
+symbol for an input-data target or a @tech{phony} target.}+
+
+@defproc[(target-path [t target?]) path-string?]{+
+The same as @racket[target-name] for a target whose name is a path,
+and an error for other targets.}
+
+@defproc[(target-shell [t target?]) string?]{+
+Composes @racket[target-path] with @racket[string->shell]. Use this
+when getting a target name to include in a shell command.}
+
+
+@defproc[(input-file-target [path path-string?]) target?]{+
+Creates a @tech{target} that represents an input file. An input-file+target has no build procedure, and it's state is summarized as a hash
+via @racket[file-sha1].}
+
+
+@defproc[(input-data-target [name symbol?] [content any/c]) target?]{+
+Similar to @racket[input-file-target] for a would-be file that
+contains @racket[(~s content)].
+
+The result of @racket[(symbol->string name)] must be distinct among
+all the input-data dependencies of a particular target, but it does
+not need to be globally unique.}
+
+
+@defproc*[([(target [name path-string?]
+ [get-deps (path-string? token? . -> . rule?)]
+ [options hash? (hash)])
+ target?]
+ [(target [name symbol?]
+ [get-deps (token? . -> . phony-rule?)]
+ [options hash? (hash)])
+ target?])]{+
+Creates a @tech{target} that can have dependencies. If @racket[name]+is a path string, then it represents a file build target whose results
+are recorded to avoid rebuilding. If @racket[name] is a symbol, then
+it represents a @tech{phony} target that is always rebuilt.+
+In the case of a file target, @racket[get-deps] receives @racket[name]
+back, because that's often more convenient for constructing a target
+when applying an @racket[_at-dir] function to create @racket[name].
+
+The @deftech{build token} argument to @racket[get-deps] represents the+target build in progress. It's useful with @racket[file-sha1] to take
+advantage of caching, with @racket[build/dep] to report
+discovered targets, and with @racket[build/no-dep] or @racket[build].
+
+The following keys are recognized in @racket[options]:
+
+@itemlist[
+
+@item{@racket['co-outputs] mapped to a list of path strings: paths+ that are also generated by the target in addition to
+ @racket[name] when @racket[name] is a path string; the target's
+ build function will be called if the combination of
+ @racket[name] and these files is out-of-date.}
+
+@item{@racket['precious?] mapped to any value: if non-@racket[#f] for+ a non-phony target, @racket[name] is not deleted if the
+ @racket[get-deps] function or its result's @racket[_rebuild]
+ function fails.}
+
+@item{@racket['command?] mapped to any value: if non-@racket[#f], when+ @racket[build/command-line] runs the target as the first one
+ named on the command line, all arguments from the command line
+ after the target name are provided @racket[_get-deps] as
+ additional arguments. When building a target directly instead
+ of through @racket[build/command-line], use
+ @racket[command-target->target] to supply arguments.}
+
+@item{@racket['noisy?] mapped to any value: if non-@racket[#f], then a+ message prints via @racket[alert] whenever when the target is
+ found to be already up to date.}
+
+@item{@racket['quiet?] mapped to any value: if non-@racket[#f], then+ even when @racket[build] runs the target directly or as the
+ dependency of a @tech{phony} target, it does not print a message+ via @racket[alert] when the target is up to date, unless the
+ target is also noisy. When a phony target is quiet, it builds
+ its dependencies as quiet.}
+
+@item{@racket['eager?] mapped to any value: if non-@racket[#f], then+ the target's build step is not run in a separate thread, which
+ has the effect of ordering the build step before others that do
+ run in a separate thread.}
+
+@item{@racket['db-dir] mapped to a path or @racket[#f]: if+ non-@racket[#f], build information for the target is stored in
+ @filepath{_zuo.db} and @filepath{_zuo_tc.db} files in the+ specified directory, instead of the directory of @racket[path].}
+
+]}
+
+@deftogether[(
+@defproc[(rule [dependencies (listof (or/c target? path-string?))]
+ [rebuild (or/c (-> (or/c sha1? any/c)) #f) #f]
+ [sha1 (or/c sha1? #f) #f])
+ rule?]
+@defproc[(rule? [v any/c]) boolean?]
+)]{+
+The @racket[rule] procedure combines the three results expected from a
+procedure passed to @racket[target]. See @secref["make-target"].
+
+A path string can be reported as a dependency in
+@racket[dependencies], in which case it is coerced to a target using
+@racket[input-file-target]. If @racket[sha1] is @racket[#f],
+@racket[file-sha1] is used to compute the target's current hash, and
+@racket[rebuild] is not expected to return a hash. If @racket[sha1] is
+not @racket[#f], then if @racket[rebuild] is called, it must return a
+new hash.}
+
+
+@deftogether[(
+@defproc[(phony-rule [dependencies (listof (or/c target? path-string?))]
+ [rebuild (-> any/c)])
+ phony-rule?]
+@defproc[(phony-rule? [v any/c]) boolean?]
+)]{+
+The @racket[phony-rule] procedure combines the two results expected
+from a procedure passed to @racket[target] to create a @tech{phony}+target. Compared to the non-phonu protocol, the result SHA-1 is
+omitted.}
+
+@defproc[(token? [v any/c]) boolean?]{+
+Returns @racket[#t] if @racket[v] is a token representing a target
+build, @racket[#f] otherwise.}
+
+
+@defproc[(build [target (or/c target? path-string? (listof (or/c target? path-string?)))]
+ [token (or/c #f token?) #f]
+ [options hash? (hash)])
+ void?]{+
+Builds @racket[target] as a fresh build process, independent of any
+that might already be running (in the sense described below). A list
+of targets as @racket[target] is coerced to a phony target that
+depends on the given list.
+
+If @racket[target] is a path, then it is coerced to target via
+@racket[input-file-target], but the only effect will be to compute the
+file's SHA-1 or error if the file does not exist.
+
+The @racket[options] argument supplies build options, and the
+following keys are recognized:
+
+@itemlist[
+
+@item{@racket['jobs] mapped to a positive integer: controls the+ maximum build steps that are allowed to proceed concurrently,
+ and this concurrency turns into parallelism when a task uses a
+ process and @racket[thread-process-wait]; the @envvar{ZUO_JOBS}+ environment variable determines the default if it is set,
+ otherwise the default is 1}
+
+@item{@racket['log?] mapped to any value: enables logging of rebuild+ reasons via @racket[alert] when the value is not @racket[#f];
+ logging also can be enabled by setting the
+ @envvar{ZUO_BUILD_LOG} environment variable}+
+]
+
+If @racket[token] is not @racket[#f], it must be a @tech{build token}+that was passed to a target's @racket[_get-deps] to represent a build
+in progress (but paused to run this one). The new build process uses
+parallelism available within the in-progress build for the new build
+process.
+
+Whether or not @racket[token] is @racket[#f], the new build is
+independent of other builds in the sense that target results for
+others build are not reused for this one. That is, other builds and
+this one might check the states of some of the same files, but any
+triggered actions are separate, and @tech{phony} targets are similarly+triggered independently. Use @racket[build/dep] or
+@racket[build/no-dep], instead, to recursively trigger targets within
+the same build.}
+
+
+@defproc[(build/dep [target (or target? path-string?)] [token token?]) void?]{+
+Like @racket[build], but continues a build in progress as represented
+by a @racket[token] that was passed to a target's @racket[_get-deps]
+or @racket[_rebuild] procedure. Targets reachable through
+@racket[target] may have been built or have be in progress already,
+for example. After @racket[target] is built, it is registered as a
+dependency of the target that received @racket[token] (if the target
+is not @tech{phony}).}+
+
+@defproc[(build/no-dep [target (or target? path-string?)] [token token?]) void?]{+
+Like @racket[build/dep] to continue a build in progress, but does not
+register a dependency. Using @racket[build/no-dep] has an effect
+similar to @hyperlink[shake-url]{Shake}'s ``order only'' dependencies.}+
+
+@defproc[(build/command-line [targets (listof target?)] [options hash? (hash)]) void?]{+
+Parses command-line arguments to build one or more targets in
+@racket[targets], where the first one is built by default. The
+@racket[options] argument is passed along to @racket[build], but may
+be adjusted via command-line flags such as @DFlag{jobs}.+
+If @racket[options] has a mapping for @racket['args], the value is
+used as the command-line arguments to parse instead of
+@racket[(hash-ref (system-env) 'args)]. If @racket[options] has a
+mapping for @racket['usage], the value is used as the usage options
+string.}
+
+
+@defproc[(build/command-line* [targets-at (procedure? hash? . -> . (listof target?))]
+ [at-dir (path-string? ... . -> . path-string?) build-path]
+ [options hash? (hash)])
+ void?]{+
+Adds a layer of target-variable parsing to
+@racket[build/command-line]. Command-line arguments of the form
+@nonterm{name}@litchar{=}@nonterm{value} are parsed as variable+assignments, where @nonterm{name} is formed by @litchar{a}-@litchar{z},+@litchar{A}-@litchar{Z}, @litchar{_}, and @litchar{0}-@litchar{9}, but+not starting @litchar{0}-@litchar{9}. These variables can appear+anywhere in the command line and are removed from the argument list
+sent on to @racket[build/command-line], but no argument after a
+@racket{--} argument is parsed as a variable assignment.+
+The @racket[targets-at] procedure is applied to @racket[at-dir] and a
+hash table of variables, where each variable name is converted to a
+symbol and the value is left exact as after @litchar{=}.}+
+@defproc[(find-target [name string?]
+ [targets (listof target?)]
+ [fail-k procedure? (lambda () (error ....))])
+ (or/c target? #f)]{+
+Finds the first target in @racket[targets] that is a match for
+@racket[name], returning @racket[#f] is not match is found. A
+@racket[name] matches when it is the same as n entire symbol or path
+target name or when it matches a suffix that is preceded by
+@litchar{/} or @litchar{\\}. If no match is found, @racket[fail-k]+is called in tail position.}
+
+@defproc[(make-at-dir [path path-string?]) (path-string? ... . -> . path-string?)]{+
+Creates a function that is similar to on created by @racket[at-source],
+but relative to @racket[path].}
+
+@deftogether[(
+@defproc[(command-target? [v any/c]) boolean?]
+@defproc[(command-target->target [target command-target?]
+ [args list?])
+ target?]
+)]{+
+The @racket[command-target?] predicate recognizes a target with the
+@racket['target?] option, and @racket[command-target->target] converts
+such a target to one where @racket[args] are the argument when the
+target is built.}
+
+@deftogether[(
+@defproc[(file-sha1 [file path-string?] [token (or/c token? #f)]) sha1?]
+@defproc[(sha1? [v any/c]) booelan?]
+)]{+
+The @racket[file-sha1] procedure returns the SHA-1 hash of the content
+of @racket[file], or it returns @racket[no-sha1] if @racket[file] does
+not exist.
+
+The @racket[sha1?] predicate recognizes values that are either a
+40-character string or @racket[no-sha1].}
+
+@defthing[no-sha1 sha1? ""]{+
+The empty string represents a non-existent target or one that needs to
+be rebuilt.}
+
+@defform[(provide-targets targets-at-id)]{+
+Provides @racket[targets-at-id] as @racketidfont{targets-at}, and+creates a @racketidfont{main} submodule that runs+@racket[(build/command-line* targets-at-id build-path)]. A script
+using @racket[provide-targets] thus works as a makefile-like script or
+as an input to a larger build.}
+
+@defform[(bounce-to-targets config-file-expr key-symbol-expr script-file-expr)]{+
+Chains to targets from (the path produced by)
+@racket[script-file-expr] relative to the directory recorded in (the
+file whose path is produced by) @racket[config-file-expr] using the
+key (produced by) @racket[key-symbol-expr], supplying the enclosing
+script's directory as the target directory.
+
+The path produced by @racket[config-file-expr] is interpreted relative
+to the enclosing module. If the path in that file for
+@racket[key-symbol-expr] is relative, it is treated relative to the
+@racket[config-file-expr] path.
+
+See @secref["build-targets"] for an explanation of how
+@racket[bounce-to-targets] is useful. The expansion of
+@racket[bounce-to-targets] is roughly as follows:
+
+@racketblock[
+ (define config (config-file->hash (at-source config-file-expr)))
+ (define at-config-dir (make-at-dir (or (car (split-path config-file)) ".")))
+ (define script-file (at-config-dir (hash-ref config key-symbol-expr)
+ script-file-expr))
+ (build/command-line* (dynamic-require script-file 'targets-at)
+ at-source)
+]}
+
+@defproc[(make-targets [specs list?]) list?]{+
+Converts a @tt{make}-like specification into a list of targets for use+with @racket[build]. In this @tt{make}-like specification, extra+dependencies can be listed separately from a build rule, and
+dependencies can be written in terms of paths instead of @tech{target}+objects.
+
+Although it might seem natural for this @tt{make}-like specification+to be provided as a syntactic form, typical makefiles use patterns and
+variables to generate sets of rules. In Zuo, @racket[map] and similar
+are available for generating sets of rules. So, @racket[make-targets]
+takes an S-expression representation of the declaration as
+@racket[specs], and plain old quasiquote and splicing can be used to
+construct @racket[specs].
+
+The @racket[specs] argument is a list of @defterm{lines}, where each+line has one of the following shapes:
+
+@racketblock[
+ `[:target ,_path (,_dep-path-or-target ...) ,_build-proc ,_option ...]
+ `[:depend ,_path (,_dep-path-or-target ...)]
+ `[:target (,_path ...) (,_dep-path-or-target ...) ,_build-proc ,_option ...]
+ `[:depend (,_path ...) (,_dep-path-or-target ...)]
+ `[:db-dir ,_path]
+]
+
+A @racket[':target] line defines a build rule that is implemented by
+@racket[_build-proc], while a @racket[':depend] line adds extra
+dependencies for a @racket[_path] that also has a @racket[':target]
+line. A @racket[':depend] line with multiple @racket[_path]s is the
+same as a sequence of @racket[':depend] lines with the same
+@racket[_dep-path-or-target] list, but a @racket[':target] line with multiple
+@racket[_path]s creates a single target that builds all of the
+@racket[_path]s.
+
+In @racket[':target] and @racket[':depend] lines, a @racket[_path] is
+normally a path string, but it can be a symbol for a @tech{phony}+target. When a @racket[':target] has multiple @racket[_path]s, they
+must all be path strings.
+
+A @racket[_build-proc] accepts a path (if not phony) and a @tech{build+token}, just like a @racket[_get-deps] procedure for @racket[target],
+but @racket[_build-proc] should build the target like the
+@racket[_rebuild] procedure for @racket[rule] (or @racket[phony-rule]).
+When a @racket[':target] line has multiple @racket[_path]s, only the
+first one is passed to the @racket[_build-proc].
+
+A @racket[_dep-path-or-target] is normally a path string. If it is the
+same path as the @racket[_path] of a @racket[':target] line, then a
+dependency is established on that target. If
+@racket[_dep-path-or-target] is any other path string, it is coerced
+to an input-file target. A @racket[_dep-path-or-target] can also be a
+target that is created outside the @racket[make-targets] call.
+
+An @racket[_option] can be @racket[':precious], @racket[':command],
+@racket[':noisy], @racket[':quiet], or @racket[':eager] to set the
+corresponding option (see @racket[target]) in a target.}
+
+A @racket[':db-dir] line (appearing at most once) specifies where
+build information should be recorded for all targets. Otherwise, the
+build result for each target is stored in the target's directory.
--- /dev/null
+++ b/zuo-doc/zuo-lib.scrbl
@@ -1,0 +1,318 @@
+#lang scribble/manual
+@(require scribble/bnf
+ (for-label zuo-doc/fake-zuo
+ racket/contract/base)
+ "real-racket.rkt"
+ "defzuomodule.rkt")
+
+@title[#:tag "zuo-lib" #:style '(toc)]{Zuo Libraries}+
+The @racketmodname[zuo] language includes libraries added to
+@racketmodname[zuo/base] to support scripting and build tasks.
+
+@local-table-of-contents[]
+
+@; ------------------------------------------------------------
+
+@section[#:tag "zuo-cmdline"]{Command-Line Parsing}+
+@defzuomodule[zuo/cmdline]
+
+@defform[#:literals(:program :usage :args-in :init :multi :once-each :once-any :args)
+ (command-line flag-clause ... args-clause)
+ #:grammar ([flag-clause (code:line :program expr)
+ (code:line :usage expr)
+ (code:line :args-in expr)
+ (code:line :init expr)
+ (code:line :multi flag-spec ...)
+ (code:line :once-each flag-spec ...)
+ (code:line :once-any flag-spec ...)]
+ [flag-spec (accum-id flags id ... help-spec
+ accum-body ...+)
+ (flags id ... help-spec
+ proc-body ...+)]
+ [flags string
+ (string ...)]
+ [help-spec string
+ (string-expr ...)]
+ [args-clause code:blank
+ (code:line :args args-formals
+ proc-body ...)])]{+
+Analogous to @realracket*[command-line] from
+@racketmodname[racket/cmdline].
+
+One small difference is that @racket[:args-in] is used to specify a
+list of incoming arguments instead of @racket[#:argv] for an incoming
+vector of arguments. The default @racket[:args-in] uses
+@racket[(hash-ref (runtime-env) 'args '())]. Another difference is the
+addition of @racket[:usage], which supplies a usage-options string
+as an alternative to the one inferred from an @racket[:args] clause.
+
+A more significant difference is that @racketmodname[zuo] does not
+have mutable data structures, so an explicit accumulator must be
+threaded through flag parsing. An @racket[:init] clause provides the
+initial accumulator value defaulting to @racket[(hash)]. Each
+@racket[flag-spec] either starts with an @racket[accum-id], which is
+bound to the value accumulated so far, or its body produces a function
+to receive the accumulated value; either way, the result of the body
+or procedure is a new accumulated value. Finally, the body of an
+@racket[args-clause] must produce a function to receive the
+accumulated value.}
+
+@; ------------------------------------------------------------
+
+@section[#:tag "zuo-glob"]{Glob Matching}+
+@defzuomodule[zuo/glob]
+
+@defproc[(glob->matcher [glob string?]) procedure?]{+
+Creates a procedure that takes a string and reports @racket[#t] if the
+string matches the pattern @racket[glob], @racket[#f] otherwise.
+
+The pattern language of @racket[glob] is based on shell globbing:
+
+@itemlist[
+
+ @item{@litchar{?} matches any character;}+
+ @item{@litchar{*} matches any squence of characters; and}+
+ @item{@litchar{[}@italic{range}@litchar{]} matches any character in+ @italic{range}, and @litchar{[^}@italic{range}@litchar{]}+ matches any character not in @italic{range}.}+
+]
+
+In a @italic{range}, most characters stand for themselves as elements+of the range, including @litchar{*} and @litchar{?}, including+@litchar{]} when it appears first, and including @litchar{-} when it+appears first or last. When @litchar{-} appears between two characters+in @italic{range}, then the second character's value must be at least+as large as the first, and all character in from the first (inclusive)
+to the second (inclusive) are included in the range.
+
+A leading @litchar{.} or a @litchar{/} in an input string are not+treated specially. That is, @racket["*"] matches @racket[".apple"] and
+@racket["a/pple"] as well as @racket["apple"]. Use @racket[split-path]
+and a secondary check for a leading @litchar{.} to imitate shell-like+path-sensitive globbing.}
+
+
+@defproc[(glob-match? [glob string?] [str string?]) boolean?]{+
+Equivalent to @racket[((glob->matcher glob) str)].}
+
+@; ------------------------------------------------------------
+
+@section[#:tag "zuo-thread"]{Cooperative Threads}+
+@defzuomodule[zuo/thread]
+
+To use cooperative threads, create a @deftech{threading context} with+@racket[call-in-main-thread], and perform a thread operations---such
+as creating a new thread with @racket[thread] or a channel with
+@racket[channel]---during the body of the thunk provided to
+@racket[call-in-main-thread]. Threads can block either on channels or
+on a process handle as from @racket[process]. Only one thread runs at
+a time, where a thread switch happens only when a thread terminates or
+uses a (potentially) blocking operation.
+
+@defproc[(call-in-main-thread [thunk procedure]) any/c]{+
+Creates a new @tech{threading context}, calling @racket[thunk] in the+main thread of the context, and returning the value of @racket[thunk]
+after all threads in the context have either completed or are blocked
+on a channel. An error is reported if no thread can run and the main
+thread is blocked on a channel.}
+
+@deftogether[(
+@defproc[(thread [thunk procedure?]) thread?]
+@defproc[(thread? [v any/c]) boolean?]
+@defproc[(channel) channel?]
+@defproc[(channel? [v any/c]) boolean?]
+@defproc[(channel-put [ch channel?] [v any/c]) channel?]
+@defproc[(channel-get [ch channel?]) any/c]
+)]{+
+Analogous to @realracket*[thread thread? make-channel channel? channel-put
+channel-get] from @racketmodname[racket], but channels are
+asynchronous (with an unbounded queue) instead of synchronous.
+
+Except for @racket[thread?] and @racket[channel?], these procedures
+can be used only in a @tech{threading context}. A channel can be used+only in the threading context where it was created.
+
+Beware that attempting to use these operations outside of a threading
+context will @emph{not} necessarily trigger an error, and may instead+deliver an opaque threading request to the enclosing continuation
+prompt.}
+
+@defproc[(thread-process-wait [process handle?] ...) handle?]{+
+Like @racket[process-wait], but can only be used in a @tech{threading+context}, and counts as a blocking operation that can allow other
+threads to run.}
+
+@; ------------------------------------------------------------
+
+@section[#:tag "zuo-shell"]{Shell Commands}+
+@defzuomodule[zuo/shell]
+
+@defproc[(shell [command string-tree?] ... [options hash? (hash)]) hash?]{+
+Like @racket[process], but runs the combination of @racket[command]
+strings as a shell command (via @exec{/bin/sh} on Unix or+@exec{cmd.exe} on Windows).+
+The @racket[command] strings are combined into a single command string
+in the same as by @racket[build-shell]. Spaces in a @racket[command]
+are left as-is; so, for example, @racket["ls -a"] as a sole
+@racket[command] string is the same as a sequence @racket["ls"] then
+@racket["-a"]. Use @racket[string->shell] to protect characters like
+spaces, and especially to convert from a path (that might have spaces
+or other special characters) to part of a command.}
+
+
+@defproc[(shell/wait [command string-tree?] ... [options hash? (hash)])
+ void?]{+
+Like @racket[shell], but first @racket[displayln]s the command string,
+uses @racket[thread-process-wait] (or @racket[process-wait] if
+@racket[options] has a true value for @racket['no-thread?]) to wait on
+the shell process, and reports an error if the process has a
+non-@racket[0] exit code.
+
+If @racket[options] includes @racket['quiet?] mapped to a true value,
+then @racket[command] is not shown using @racket[displayln]. If
+@racket[options] includes @racket['desc] mapped to a string value, the
+string is used in place of @racket["shell command"] when reporting an
+error. Any @racket['quiet?], @racket['no-thread?], or @racket['desc]
+mapping is removed from @racket[options] before passing it on to
+@racket[process].}
+
+
+@defproc[(build-shell [shell-strs string-tree?] ...) string?]{+
+Appends the flattened @racket[shell-strs] sequence with separating
+spaces to form a larger shell-command sequence. An empty-string among
+@racket[shell-strs] is dropped, instead of creating extra spaces.
+
+Note that @racket[build-shell] does @emph{not} attempt to protect any of the+@racket[shell-strs] as a literal. Use @racket[string->shell] to convert
+an individual path or literal string to a shell-command argument
+encoding that string.}
+
+@; ------------------------------------------------------------
+
+@section[#:tag "zuo-c"]{C Tools}+
+@defzuomodule[zuo/c]
+
+The C-tool procedures provided by @racketmodname[zuo/c] accept a
+@deftech{tool configuration} hash table to describe a C compiler,+linker, archiver, and associated flags. When potential configuration
+is missing, a default suitable for the current system is used. Values
+in a tool configuration hash table are shell-command fragments, not
+individual arguments. For example, it could make sense to configure
+@racket['CC] as @racket["libtool cc"], which would run @exec{libtool}+in compilation mode, instead of trying to run a compile whose
+executable name includes a space.
+
+The following keys are recognized in a tool configuration:
+
+@itemlist[
+
+@item{@racket['CC]: a C compiler}+
+@item{@racket['CPPFLAGS]: C preprocessor flags}+
+@item{@racket['CFLAGS]: C compilation and linking flags}+
+@item{@racket['LDFLAGS]: C linker flags}+
+@item{@racket['LIBS]: additional C libraries}+
+@item{@racket['AR]: library archiver}+
+@item{@racket['ARFLAGS]: library archiver flags}+
+]
+
+
+@defproc*[([(c-compile [.o path-string?] [.c path-string?] [config hash?]) void?]
+ [(c-compile [out path-string?] [ins (listof path-string?)] [config hash?]) void?])]{+
+Compiles @racket[.c] to @racket[.o] using the @tech{tool+configuration} @racket[config], or combines compiling and linking by
+with @racket[ins] compiled and linked to @racket[out] using
+@racket[config].}
+
+@defproc[(c-link [.exe path-string?] [ins (listof path-string?)] [config hash?]) void?]{+
+Links the files @racket[ins] to create the executable @racket[.exe]
+using the @tech{tool configuration} @racket[config].}+
+@defproc[(c-ar [.a path-string?] [ins (listof path-string?)] [config hash?]) void?]{+
+Combines the object files @racket[ins] to create the archive
+@racket[.a] using the @tech{tool configuration} @racket[config].}+
+@defproc[(.c->.o [.c path-string?]) path-string?]{+
+Adjusts the filename @racket[.c] to be the conventional name of its
+compiled object file on the current system.}
+
+@defproc[(.exe [name path-string?]) path-string?]{+
+Adds @filepath{.exe} to the end of @racket[name] if conventional on+the current system.}
+
+@defproc[(.a [name path-string?]) path-string?]{+
+Derives the conventional archive name for a library @racket[name] on
+the current system.}
+
+@defproc[(config-merge [config hash?] [key symbol?] [shell-str string?]) hash?]{+
+Adds @racket[shell-str] to the shell-command fragment for @racket[key]
+in the @tech{tool configuration} @racket[config].}+
+
+@defproc[(config-include [config hash?] [path path-string?] ...) hash?]{+
+Adds the @racket[path]s as include directories in the @tech{tool+configuration} @racket[config].}
+
+
+@defproc[(config-define [config hash?] [def string?] ...) hash?]{+
+Adds the preprocessor definitions @racket[def]s to preprocessor flags
+in the @tech{tool configuration} @racket[config].}+
+@; ------------------------------------------------------------
+
+@section[#:tag "zuo-config"]{Configuration Parsing}+
+@defzuomodule[zuo/config]
+
+@defproc[(config-file->hash [file path-string?] [overrides hash? (hash)]) hash?]{+
+Parses @racket[file] as having configuration lines of the form
+@nonterm{name} @litchar{=} @nonterm{value}, with any number of ignored+spaces at the start of the line, end of the line, or around the
+@litchar{=}, and with a trailing @litchar{\} on a line deleted along+with its newline (to create a single line). Each @nonterm{name}+consists of alphanumeric characters and @litchar{_}; the symbol form+of the name is used as a key in the resulting hash table, mapped to
+the @nonterm{value} as a string. Lines in @racket[file] that do not+match the configuration format are ignored. If a same @nonterm{name}+is configured multiple times, the last mapping overrides earlier
+ones.
+
+After reading @racket[file], keys from @racket[overrides] are merged
+to the result hash table, where values in @racket[overrides] replace
+ones read from @racket[file].}
+
--- /dev/null
+++ b/zuo-doc/zuo.scrbl
@@ -1,0 +1,18 @@
+#lang scribble/manual
+
+@title{Zuo: A Tiny Racket for Scripting}+
+You should use Racket to write scripts. But for the case where you
+need something much smaller than Racket for some reason, or the case
+you're trying to script the build of Racket itself, Zuo is a tiny
+Racket with primitives for dealing with files and running processes.
+
+@table-of-contents[]
+
+@include-section["overview.scrbl"]
+@include-section["lang-zuo.scrbl"]
+@include-section["zuo-build.scrbl"]
+@include-section["zuo-lib.scrbl"]
+@include-section["lang-zuo-hygienic.scrbl"]
+@include-section["lang-zuo-datum.scrbl"]
+@include-section["lang-zuo-kernel.scrbl"]
--- /dev/null
+++ b/zuo.c
@@ -1,0 +1,6948 @@
+/* Like Zuo overall, the kernel implementation here is layered as much
+ as possible. There should be little need for forward function
+ declarations. */
+
+#define ZUO_VERSION 1
+
+#if defined(_MSC_VER) || defined(__MINGW32__)
+# define ZUO_WINDOWS
+#else
+# define ZUO_UNIX
+#endif
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+#ifdef ZUO_UNIX
+# include <fcntl.h>
+# include <unistd.h>
+# include <errno.h>
+# include <sys/types.h>
+# include <sys/wait.h>
+# include <sys/stat.h>
+# include <sys/time.h>
+# include <time.h>
+# include <dirent.h>
+# include <signal.h>
+#endif
+#ifdef ZUO_WINDOWS
+# include <windows.h>
+# include <direct.h>
+# include <io.h>
+# include <sys/stat.h>
+# include <fcntl.h>
+#endif
+
+#if 0
+# include <assert.h>
+# define ASSERT(x) assert(x)
+#else
+# define ASSERT(x) do { } while (0)+#endif
+
+/* `zuo_int_t` should be a 64-bit integer type, so we don't have to
+ worry about Y2038 or large file sizes. `zuo_int32_t` should be a
+ 32-bit integer type, obviously. `zuo_intptr_t` is an integer the
+ same width as a pointer. */
+#ifdef ZUO_UNIX
+#include <stdint.h>
+
+typedef int64_t zuo_int_t;
+typedef uint64_t zuo_uint_t;
+
+typedef int32_t zuo_int32_t;
+typedef uint32_t zuo_uint32_t;
+
+typedef intptr_t zuo_intptr_t;
+
+typedef int zuo_raw_handle_t;
+#endif
+#ifdef ZUO_WINDOWS
+/* avoiding stdint to work with very old compilers */
+typedef long long zuo_int_t;
+typedef unsigned long long zuo_uint_t;
+
+typedef int zuo_int32_t;
+typedef unsigned int zuo_uint32_t;
+
+# ifdef _WIN64
+typedef long long zuo_intptr_t;
+# else
+typedef long zuo_intptr_t;
+# endif
+
+typedef HANDLE zuo_raw_handle_t;
+#endif
+
+/* the "image.zuo" script looks for this line: */
+#define EMBEDDED_IMAGE 0
+
+#ifndef ZUO_LIB_PATH
+# define ZUO_LIB_PATH "lib"
+#endif
+static const char *zuo_lib_path = ZUO_LIB_PATH;
+
+#ifdef ZUO_EMBEDDED
+# include "zuo.h"
+#endif
+
+/* configurable lower bound on how much space to use: */
+#ifndef ZUO_MIN_HEAP_SIZE
+# define ZUO_MIN_HEAP_SIZE (32*1024*1024)
+#endif
+
+/*======================================================================*/
+/* run-time configuration */
+/*======================================================================*/
+
+static const char *zuo_file_logging = NULL;
+static int zuo_logging = 0;
+static int zuo_probe_each = 0;
+static int zuo_probe_counter = 0;
+
+static void zuo_configure() {+ const char *s;
+
+ if ((s = getenv("ZUO_LIB_PATH"))) {+ zuo_lib_path = s;
+ }
+
+ if (getenv("ZUO_LOG"))+ zuo_logging = 1;
+
+ if ((s = getenv("ZUO_PROBE_EACH"))) {+ while (isdigit(*s)) {+ zuo_probe_each = (zuo_probe_each * 10) + (s[0] - '0');
+ s++;
+ }
+ }
+}
+
+/*======================================================================*/
+/* object layouts */
+/*======================================================================*/
+
+typedef enum {+ zuo_singleton_tag,
+ zuo_pair_tag,
+ zuo_integer_tag,
+ zuo_string_tag,
+ zuo_symbol_tag,
+ zuo_trie_node_tag,
+ zuo_variable_tag,
+ zuo_primitive_tag,
+ zuo_closure_tag,
+ zuo_handle_tag,
+ zuo_opaque_tag,
+ zuo_cont_tag,
+ zuo_forwarded_tag
+} zuo_tag_t;
+
+typedef struct zuo_t {+ zuo_int32_t tag;
+ /* every subtype must have more to make it at least as
+ large as `zuo_forwarded_t` */
+} zuo_t;
+
+typedef struct {+ zuo_t obj;
+ zuo_t *forward;
+} zuo_forwarded_t;
+
+typedef struct {+ zuo_t obj;
+ zuo_int32_t index;
+} zuo_fasl_forwarded_t;
+
+typedef struct {+ zuo_t obj;
+ zuo_int_t i;
+} zuo_integer_t;
+
+#define ZUO_INT_I(p) (((zuo_integer_t *)(p))->i)
+#define ZUO_UINT_I(p) ((zuo_uint_t)(((zuo_integer_t *)(p))->i))
+
+typedef struct {+ zuo_t obj;
+ zuo_t *car;
+ zuo_t *cdr;
+} zuo_pair_t;
+
+#define ZUO_CAR(p) (((zuo_pair_t *)(p))->car)
+#define ZUO_CDR(p) (((zuo_pair_t *)(p))->cdr)
+
+#ifdef ZUO_SAFER_INTERP
+# define _zuo_car(p) zuo_car(p)
+# define _zuo_cdr(p) zuo_cdr(p)
+#else
+# define _zuo_car(p) ZUO_CAR(p)
+# define _zuo_cdr(p) ZUO_CDR(p)
+#endif
+
+typedef struct {+ zuo_t obj;
+ zuo_intptr_t len; /* must be at the same place as forwarding */
+ unsigned char s[1];
+} zuo_string_t;
+
+/* Since `len` overlaps with forwarding, we can tentatively get the "length" from any object */
+#define ZUO_STRING_LEN(obj) (((zuo_string_t *)(obj))->len)
+
+#define ZUO_STRING_ALLOC_SIZE(len) (sizeof(zuo_string_t) + (len))
+#define ZUO_STRING_PTR(obj) ((char *)&((zuo_string_t *)(obj))->s)
+
+typedef struct {+ zuo_t obj;
+ zuo_int32_t id;
+ zuo_t *str;
+} zuo_symbol_t;
+
+#define ZUO_TRIE_BFACTOR_BITS 4
+#define ZUO_TRIE_BFACTOR (1 << ZUO_TRIE_BFACTOR_BITS)
+#define ZUO_TRIE_BFACTOR_MASK (ZUO_TRIE_BFACTOR -1)
+
+typedef struct zuo_trie_node_t {+ zuo_t obj;
+ zuo_int_t count;
+ zuo_t *key;
+ zuo_t *val;
+ struct zuo_t* next[ZUO_TRIE_BFACTOR];
+} zuo_trie_node_t;
+
+typedef struct {+ zuo_t obj;
+ zuo_t *name;
+ zuo_t *val;
+} zuo_variable_t;
+
+typedef zuo_t *(*zuo_dispatcher_proc_t)(void *proc, zuo_t *arguments);
+
+typedef struct {+ zuo_t obj;
+ zuo_dispatcher_proc_t dispatcher;
+ void *proc;
+ zuo_int32_t arity_mask;
+ zuo_t *name;
+} zuo_primitive_t;
+
+/* only try to count up to this high for arity checking: */
+#define ZUO_MAX_PRIM_ARITY 10
+
+typedef struct {+ zuo_t obj;
+ zuo_t *lambda;
+ zuo_t *env;
+} zuo_closure_t;
+
+typedef enum {+ zuo_handle_open_fd_in_status,
+ zuo_handle_open_fd_out_status,
+ zuo_handle_closed_status,
+ zuo_handle_process_running_status,
+ zuo_handle_process_done_status,
+ zuo_handle_cleanable_status,
+} zuo_handle_status_t;
+
+typedef struct zuo_handle_t {+ zuo_t obj;
+ zuo_int_t id;
+ union {+ struct {+ zuo_handle_status_t status;
+ union {+ zuo_raw_handle_t handle;
+ zuo_int_t result;
+ } u;
+ } h;
+ zuo_t *forward; /* make sure the object is big enough */
+ } u;
+} zuo_handle_t;
+
+#define ZUO_HANDLE_RAW(obj) (((zuo_handle_t *)(obj))->u.h.u.handle)
+
+typedef struct {+ zuo_t obj;
+ zuo_t *tag;
+ zuo_t *val;
+} zuo_opaque_t;
+
+typedef enum {+ zuo_apply_cont,
+ zuo_begin_cont,
+ zuo_let_cont,
+ zuo_if_cont,
+ zuo_done_cont
+} zuo_cont_tag_t;
+
+typedef struct zuo_cont_t {+ zuo_t obj;
+ zuo_cont_tag_t tag;
+ zuo_t *data;
+ zuo_t *env;
+ zuo_t *in_proc; /* string or #f */
+ zuo_t *next;
+} zuo_cont_t;
+
+/* GC roots: */
+static struct {+ /* Roots kept in an image dump: */
+ struct {+ /* singleton values */
+ zuo_t *o_undefined; /* internal use only */
+ zuo_t *o_true;
+ zuo_t *o_false;
+ zuo_t *o_null;
+ zuo_t *o_eof;
+ zuo_t *o_void;
+ zuo_t *o_empty_hash;
+
+ /* sentinel for the interpreter */
+ zuo_t *o_done_k;
+
+ /* intrinsic functions that manipulate interpreter state */
+ zuo_t *o_apply;
+ zuo_t *o_call_cc;
+ zuo_t *o_call_prompt;
+ zuo_t *o_kernel_eval;
+
+ /* private primitives */
+ zuo_t *o_kernel_read_string;
+ zuo_t *o_module_to_hash_star;
+ zuo_t *o_get_read_and_eval;
+ zuo_t *o_register_module;
+
+ /* symbol table, root environment, and modules */
+ zuo_t *o_intern_table;
+ zuo_t *o_top_env;
+ zuo_t *o_modules;
+
+ /* symbols for kernel core forms */
+ zuo_t *o_quote_symbol;
+ zuo_t *o_lambda_symbol;
+ zuo_t *o_let_symbol;
+ zuo_t *o_begin_symbol;
+ zuo_t *o_if_symbol;
+ } image;
+
+ /* Roots that are not included in a dump: */
+ struct {+ /* CEK-style interp--continue registers */
+ zuo_t *o_interp_e;
+ zuo_t *o_interp_v;
+ zuo_t *o_interp_env;
+ zuo_t *o_interp_k;
+ zuo_t *o_interp_in_proc; /* used for a stack trace on error */
+
+ zuo_t *o_interp_meta_k; /* list of (cons <cont> <tag>) */
+
+ /* for cycle detection */
+ zuo_t *o_pending_modules;
+
+#ifdef ZUO_UNIX
+ /* process status table and fd table */
+ zuo_t *o_pid_table;
+ zuo_t *o_fd_table;
+#endif
+ zuo_t *o_cleanable_table;
+
+ /* startup info */
+ zuo_t *o_library_path;
+ zuo_t *o_runtime_env;
+
+ /* data to save across a GC that's possibly triggered by interp */
+ zuo_t *o_stash;
+ } runtime;
+} zuo_roots;
+
+#define z zuo_roots.image
+#define Z zuo_roots.runtime
+
+static zuo_int32_t zuo_symbol_count = 0;
+static zuo_int32_t zuo_handle_count = 0;
+
+/*======================================================================*/
+/* sanity checks */
+/*======================================================================*/
+
+void zuo_panic(const char *s) {+ fprintf(stderr, "%s\n", s);
+ exit(1);
+}
+
+void zuo_check_sanity() {+ if (sizeof(zuo_int32_t) != 4)
+ zuo_panic("wrong int32 size");+ if (sizeof(zuo_int_t) != 8)
+ zuo_panic("wrong int size");+ if ((void*)&(((zuo_string_t *)NULL)->len) != (void*)&(((zuo_forwarded_t *)NULL)->forward))
+ zuo_panic("string len field misplaced");+}
+
+/*======================================================================*/
+/* signal forward declarations */
+/*======================================================================*/
+
+static zuo_t *zuo_resume_signal();
+static zuo_t *zuo_suspend_signal();
+
+/*======================================================================*/
+/* memory manager */
+/*======================================================================*/
+
+#define ALLOC_ALIGN(i) (((i) + (sizeof(zuo_intptr_t) - 1)) & ~(sizeof(zuo_intptr_t) -1))
+
+static zuo_int_t heap_size = ZUO_MIN_HEAP_SIZE;
+static void *to_space = NULL;
+static zuo_int_t allocation_offset = 0;
+static zuo_int_t total_allocation = 0;
+static zuo_int_t gc_threshold = 0;
+
+typedef struct old_space_t {+ void *space;
+ struct old_space_t *next;
+} old_space_t;
+static old_space_t *old_spaces;
+
+static zuo_t *zuo_new(int tag, zuo_int_t size) {+ zuo_t *obj;
+
+ ASSERT(size >= sizeof(zuo_forwarded_t));
+
+ size = ALLOC_ALIGN(size);
+
+ if (to_space == NULL) {+ to_space = malloc(heap_size);
+ gc_threshold = heap_size;
+ }
+
+ if (allocation_offset + size > heap_size) {+ old_space_t *new_old_spaces;
+ new_old_spaces = malloc(sizeof(old_space_t));
+ new_old_spaces->space = to_space;
+ new_old_spaces->next = old_spaces;
+ old_spaces = new_old_spaces;
+
+ if (heap_size < size)
+ heap_size = size * 2;
+ to_space = malloc(heap_size);
+ allocation_offset = 0;
+ }
+
+ obj = (zuo_t *)((char *)to_space + allocation_offset);
+ obj->tag = tag;
+
+ allocation_offset += size;
+ total_allocation += size;
+
+ return obj;
+}
+
+static zuo_int_t object_size(zuo_int32_t tag, zuo_int_t maybe_string_len) {+ switch(tag) {+ case zuo_singleton_tag:
+ return sizeof(zuo_forwarded_t);
+ case zuo_integer_tag:
+ return sizeof(zuo_integer_t);
+ case zuo_string_tag:
+ return ZUO_STRING_ALLOC_SIZE(maybe_string_len);
+ case zuo_pair_tag:
+ return sizeof(zuo_pair_t);
+ case zuo_symbol_tag:
+ return sizeof(zuo_symbol_t);
+ case zuo_trie_node_tag:
+ return sizeof(zuo_trie_node_t);
+ case zuo_variable_tag:
+ return sizeof(zuo_variable_t);
+ case zuo_primitive_tag:
+ return sizeof(zuo_primitive_t);
+ case zuo_closure_tag:
+ return sizeof(zuo_closure_t);
+ case zuo_handle_tag:
+ return sizeof(zuo_handle_t);
+ case zuo_opaque_tag:
+ return sizeof(zuo_opaque_t);
+ case zuo_cont_tag:
+ return sizeof(zuo_cont_t);
+ default:
+ case zuo_forwarded_tag:
+ return sizeof(zuo_forwarded_t);
+ }
+}
+
+void zuo_update(zuo_t **addr_to_update) {+ zuo_t *obj = *addr_to_update;
+
+ if (obj->tag != zuo_forwarded_tag) {+ zuo_int_t size = ALLOC_ALIGN(object_size(obj->tag, ZUO_STRING_LEN(obj)));
+ zuo_t *new_obj = (zuo_t *)((char *)to_space + allocation_offset);
+ allocation_offset += size;
+
+ memcpy(new_obj, obj, size);
+ obj->tag = zuo_forwarded_tag;
+ ((zuo_forwarded_t *)obj)->forward = new_obj;
+ }
+
+ *addr_to_update = ((zuo_forwarded_t *)obj)->forward;
+}
+
+static void zuo_trace(zuo_t *obj) {+ switch(obj->tag) {+ case zuo_singleton_tag:
+ case zuo_integer_tag:
+ case zuo_string_tag:
+ case zuo_handle_tag:
+ case zuo_forwarded_tag:
+ break;
+ case zuo_pair_tag:
+ zuo_update(&((zuo_pair_t *)obj)->car);
+ zuo_update(&((zuo_pair_t *)obj)->cdr);
+ break;
+ case zuo_symbol_tag:
+ zuo_update(&((zuo_symbol_t *)obj)->str);
+ break;
+ case zuo_trie_node_tag:
+ {+ int i;
+ zuo_update(&((zuo_trie_node_t *)obj)->key);
+ zuo_update(&((zuo_trie_node_t *)obj)->val);
+ for (i = 0; i < ZUO_TRIE_BFACTOR; i++)
+ zuo_update(&((zuo_trie_node_t *)obj)->next[i]);
+ }
+ break;
+ case zuo_variable_tag:
+ zuo_update(&((zuo_variable_t *)obj)->name);
+ zuo_update(&((zuo_variable_t *)obj)->val);
+ break;
+ case zuo_primitive_tag:
+ zuo_update(&((zuo_primitive_t *)obj)->name);
+ break;
+ case zuo_closure_tag:
+ zuo_update(&((zuo_closure_t *)obj)->lambda);
+ zuo_update(&((zuo_closure_t *)obj)->env);
+ break;
+ case zuo_opaque_tag:
+ zuo_update(&((zuo_opaque_t *)obj)->tag);
+ zuo_update(&((zuo_opaque_t *)obj)->val);
+ break;
+ case zuo_cont_tag:
+ zuo_update(&((zuo_cont_t *)obj)->data);
+ zuo_update(&((zuo_cont_t *)obj)->env);
+ zuo_update(&((zuo_cont_t *)obj)->in_proc);
+ zuo_update(&((zuo_cont_t *)obj)->next);
+ break;
+ }
+}
+
+static void zuo_trace_objects() {+ zuo_int_t trace_offset = 0;
+
+ while (trace_offset < allocation_offset) {+ zuo_t *obj = (zuo_t *)((char *)to_space + trace_offset);
+ zuo_trace(obj);
+ trace_offset += ALLOC_ALIGN(object_size(obj->tag, ZUO_STRING_LEN(obj)));
+ }
+}
+
+static void zuo_finish_gc(void *old_space, old_space_t *old_old_spaces) {+ free(old_space);
+ while (old_old_spaces != NULL) {+ old_space_t *next_old_old_spaces = old_old_spaces->next;
+ free(old_old_spaces->space);
+ free(old_old_spaces);
+ old_old_spaces = next_old_old_spaces;
+ }
+
+ total_allocation = allocation_offset;
+ gc_threshold = total_allocation * 2;
+ if (gc_threshold < ZUO_MIN_HEAP_SIZE)
+ gc_threshold = ZUO_MIN_HEAP_SIZE;
+}
+
+static void zuo_collect() {+ void *old_space = to_space;
+ old_space_t *old_old_spaces = old_spaces;
+
+ zuo_suspend_signal();
+
+ old_spaces = NULL;
+ heap_size = total_allocation;
+ to_space = malloc(heap_size);
+ allocation_offset = 0;
+
+ /* roots */
+ {+ zuo_t **p = (zuo_t **)&zuo_roots;
+ int i, len;
+ len = sizeof(zuo_roots) / sizeof(zuo_t*);
+ for (i = 0; i < len; i++) {+ zuo_update(p+i);
+ }
+ }
+
+ /* collect */
+ zuo_trace_objects();
+
+ /* cleanup */
+ zuo_finish_gc(old_space, old_old_spaces);
+
+ zuo_resume_signal();
+}
+
+static void zuo_check_collect() {+ if (total_allocation >= gc_threshold)
+ zuo_collect();
+}
+
+static void zuo_replace_heap(void *space, zuo_int_t size, zuo_int_t offset) {+ allocation_offset = offset;
+
+ zuo_finish_gc(to_space, old_spaces);
+
+ old_spaces = NULL;
+ heap_size = size;
+ to_space = space;
+}
+
+/*======================================================================*/
+/* table of primitives used for fasl */
+/*======================================================================*/
+
+#define ZUO_MAX_PRIMITIVE_COUNT 128
+static zuo_primitive_t zuo_registered_prims[ZUO_MAX_PRIMITIVE_COUNT];
+static int zuo_registered_prim_count;
+
+static void zuo_register_primitive(zuo_dispatcher_proc_t dispatcher, void *proc, zuo_int32_t arity_mask) {+ if (zuo_registered_prim_count == ZUO_MAX_PRIMITIVE_COUNT)
+ zuo_panic("primitive table is too small");+
+ zuo_registered_prims[zuo_registered_prim_count].dispatcher = dispatcher;
+ zuo_registered_prims[zuo_registered_prim_count].proc = proc;
+ zuo_registered_prims[zuo_registered_prim_count].arity_mask = arity_mask;
+ zuo_registered_prim_count++;
+}
+
+static zuo_int32_t zuo_primitive_to_id(zuo_primitive_t *obj) {+ int i;
+ for (i = 0; i < zuo_registered_prim_count; i++)
+ if (obj->proc == zuo_registered_prims[i].proc)
+ return i;
+ zuo_panic("could not find primitive");+ return 0;
+}
+
+static void zuo_id_to_primitive(zuo_int32_t i, zuo_primitive_t *obj) {+ obj->dispatcher = zuo_registered_prims[i].dispatcher;
+ obj->proc = zuo_registered_prims[i].proc;
+ obj->arity_mask = zuo_registered_prims[i].arity_mask;
+}
+
+/*======================================================================*/
+/* heap fasl */
+/*======================================================================*/
+
+typedef struct {+ zuo_int32_t magic;
+ zuo_int32_t map_size; /* in int32s */
+ zuo_int32_t image_size; /* in int32s */
+ zuo_int32_t symbol_count;
+} zuo_fasl_header_t;
+
+static zuo_int32_t zuo_magic() {+ /* gets magic specific to the current machine's endianness */
+ return *(zuo_int32_t *)"\0zuo";
+}
+
+typedef enum {+ zuo_fasl_out,
+ zuo_fasl_in
+} zuo_fasl_mode_t;
+
+typedef struct {+ zuo_fasl_mode_t mode;
+} zuo_fasl_stream_t;
+
+typedef struct {+ zuo_fasl_stream_t stream;
+ void *heap, *shadow_heap;
+ zuo_int32_t heap_size;
+
+ zuo_t **objs;
+ zuo_int32_t *map; /* offset in image */
+ zuo_int32_t map_size, map_offset;
+
+ zuo_int32_t *image;
+ zuo_int32_t image_size, image_offset;
+} zuo_fasl_stream_out_t;
+
+typedef struct {+ zuo_fasl_stream_t stream;
+ void *heap;
+ zuo_int32_t heap_size;
+ zuo_int32_t *map;
+ zuo_int32_t *image;
+ zuo_int32_t offset;
+} zuo_fasl_stream_in_t;
+
+static void zuo_ensure_image_room(zuo_fasl_stream_out_t *stream) {+ if (stream->image_size == stream->image_offset) {+ zuo_int32_t *new_image = malloc(stream->image_size * 2 * sizeof(zuo_int32_t));
+ memcpy(new_image, stream->image, (stream->image_offset) * sizeof(zuo_int32_t));
+ free(stream->image);
+ stream->image = new_image;
+ stream->image_size *= 2;
+ }
+}
+
+static void zuo_ensure_map_room(zuo_fasl_stream_out_t *stream) {+ if (stream->map_size == stream->map_offset) {+ zuo_t **new_objs = malloc(stream->map_size * 2 * sizeof(zuo_t*));
+ zuo_int32_t *new_map = malloc(stream->map_size * 2 * sizeof(zuo_int32_t));
+ memcpy(new_objs, stream->objs, (stream->map_offset) * sizeof(zuo_t*));
+ memcpy(new_map, stream->map, (stream->map_offset) * sizeof(zuo_int32_t));
+ free(stream->objs);
+ free(stream->map);
+ stream->objs = new_objs;
+ stream->map = new_map;
+ stream->map_size *= 2;
+ }
+}
+
+static void zuo_fasl_ref(zuo_t **_obj, zuo_fasl_stream_t *_stream) {+ if (_stream->mode == zuo_fasl_in) {+ zuo_fasl_stream_in_t *stream = (zuo_fasl_stream_in_t *)_stream;
+ zuo_int32_t delta = stream->map[stream->image[stream->offset++]];
+ *_obj = (zuo_t *)((char *)stream->heap + delta);
+ } else {+ zuo_fasl_stream_out_t *stream = (zuo_fasl_stream_out_t *)_stream;
+ zuo_t *obj = *_obj;
+ zuo_intptr_t delta = ((char *)obj) - ((char *)stream->heap);
+ zuo_t *shadow_obj = (zuo_t *)(((char *)stream->shadow_heap) + delta);
+
+ ASSERT((delta >= 0) && (delta < stream->heap_size));
+
+ zuo_ensure_image_room(stream);
+
+ if (shadow_obj->tag == zuo_forwarded_tag) {+ stream->image[stream->image_offset++] = ((zuo_fasl_forwarded_t *)shadow_obj)->index;
+ } else {+ zuo_ensure_map_room(stream);
+
+ shadow_obj->tag = zuo_forwarded_tag;
+ ((zuo_fasl_forwarded_t *)shadow_obj)->index = stream->map_offset;
+
+ stream->image[stream->image_offset++] = stream->map_offset;
+ stream->objs[stream->map_offset++] = *_obj;
+ }
+ }
+}
+
+static void zuo_fasl_int32(zuo_int32_t *_i, zuo_fasl_stream_t *_stream) {+ if (_stream->mode == zuo_fasl_in) {+ zuo_fasl_stream_in_t *stream = (zuo_fasl_stream_in_t *)_stream;
+ *_i = stream->image[stream->offset++];
+ } else {+ zuo_fasl_stream_out_t *stream = (zuo_fasl_stream_out_t *)_stream;
+ zuo_ensure_image_room(stream);
+ stream->image[stream->image_offset++] = *_i;
+ }
+}
+
+#define BUILD_INT(lo, hi) (((zuo_int_t)(hi) << 32) | ((zuo_int_t)(lo) & 0xFFFFFFFF))
+
+static void zuo_fasl_int(zuo_int_t *_i, zuo_fasl_stream_t *_stream) {+ zuo_int32_t lo, hi;
+ lo = *_i & (zuo_int_t)0xFFFFFFFF;
+ hi = *_i >> 32;
+ zuo_fasl_int32(&lo, _stream);
+ zuo_fasl_int32(&hi, _stream);
+ *_i = BUILD_INT(lo, hi);
+}
+
+static void zuo_fasl_char(unsigned char *_c, zuo_fasl_stream_t *stream) {+ zuo_int32_t i = *_c;
+ zuo_fasl_int32(&i, stream);
+ *_c = i;
+}
+
+static void zuo_fasl(zuo_t *obj, zuo_fasl_stream_t *stream) {+ {+ zuo_int32_t tag = obj->tag;
+ zuo_fasl_int32(&tag, stream);
+ obj->tag = tag;
+ }
+
+ switch(obj->tag) {+ case zuo_singleton_tag:
+ break;
+ case zuo_integer_tag:
+ zuo_fasl_int(&((zuo_integer_t *)obj)->i, stream);
+ break;
+ case zuo_string_tag:
+ {+ int i;
+ zuo_int_t len = ((zuo_string_t *)obj)->len;
+ /* restore assumes that a string starts with its length */
+ zuo_fasl_int(&len, stream);
+ ((zuo_string_t *)obj)->len = len;
+ for (i = 0; i < ((zuo_string_t *)obj)->len; i++)
+ zuo_fasl_char(&((zuo_string_t *)obj)->s[i], stream);
+ }
+ break;
+ case zuo_pair_tag:
+ zuo_fasl_ref(&((zuo_pair_t *)obj)->car, stream);
+ zuo_fasl_ref(&((zuo_pair_t *)obj)->cdr, stream);
+ break;
+ case zuo_symbol_tag:
+ zuo_fasl_int32(&((zuo_symbol_t *)obj)->id, stream);
+ zuo_fasl_ref(&((zuo_symbol_t *)obj)->str, stream);
+ break;
+ case zuo_trie_node_tag:
+ {+ int i;
+ zuo_int32_t mask;
+ if (stream->mode == zuo_fasl_in)
+ zuo_fasl_int32(&mask, stream);
+ else {+ mask = 0;
+ for (i = 0; i < ZUO_TRIE_BFACTOR; i++)
+ if (((zuo_trie_node_t *)obj)->next[i] != z.o_undefined)
+ mask |= (1 << i);
+ zuo_fasl_int32(&mask, stream);
+ }
+ zuo_fasl_ref(&((zuo_trie_node_t *)obj)->key, stream);
+ zuo_fasl_ref(&((zuo_trie_node_t *)obj)->val, stream);
+ for (i = 0; i < ZUO_TRIE_BFACTOR; i++)
+ if (mask & (1 << i))
+ zuo_fasl_ref(&((zuo_trie_node_t *)obj)->next[i], stream);
+ else
+ ((zuo_trie_node_t *)obj)->next[i] = z.o_undefined;
+ }
+ break;
+ case zuo_variable_tag:
+ {+ zuo_fasl_ref(&((zuo_variable_t *)obj)->name, stream);
+ zuo_fasl_ref(&((zuo_variable_t *)obj)->val, stream);
+ break;
+ }
+ case zuo_primitive_tag:
+ {+ zuo_int32_t primitive_id;
+ if (stream->mode == zuo_fasl_out) {+ primitive_id = zuo_primitive_to_id((zuo_primitive_t *)obj);
+ zuo_fasl_int32(&primitive_id, stream);
+ } else {+ zuo_fasl_int32(&primitive_id, stream);
+ zuo_id_to_primitive(primitive_id, (zuo_primitive_t *)obj);
+ }
+
+ zuo_fasl_ref(&((zuo_primitive_t *)obj)->name, stream);
+ }
+ break;
+ case zuo_closure_tag:
+ zuo_fasl_ref(&((zuo_closure_t *)obj)->lambda, stream);
+ zuo_fasl_ref(&((zuo_closure_t *)obj)->env, stream);
+ break;
+ case zuo_opaque_tag:
+ zuo_fasl_ref(&((zuo_opaque_t *)obj)->tag, stream);
+ zuo_fasl_ref(&((zuo_opaque_t *)obj)->val, stream);
+ break;
+ case zuo_cont_tag:
+ zuo_fasl_ref(&((zuo_cont_t *)obj)->data, stream);
+ zuo_fasl_ref(&((zuo_cont_t *)obj)->env, stream);
+ zuo_fasl_ref(&((zuo_cont_t *)obj)->in_proc, stream);
+ zuo_fasl_ref(&((zuo_cont_t *)obj)->next, stream);
+ break;
+ case zuo_handle_tag:
+ zuo_panic("cannot dump heap with handles");+ break;
+ case zuo_forwarded_tag:
+ ASSERT(0);
+ break;
+ }
+}
+
+static void zuo_fasl_roots(zuo_fasl_stream_t *stream) {+ zuo_t **p = (zuo_t **)&zuo_roots.image;
+ int i, len = sizeof(zuo_roots.image) / sizeof(zuo_t*);
+ for (i = 0; i < len; i++)
+ zuo_fasl_ref(p+i, stream);
+}
+
+static char *zuo_fasl_dump(zuo_int_t *_len) {+ zuo_fasl_stream_out_t stream;
+ zuo_int32_t total_size, header_size = sizeof(zuo_fasl_header_t) / sizeof(zuo_int32_t);
+ zuo_int32_t *dump;
+ zuo_int32_t map_done;
+
+ /* make sure everything is in contiguous memory: */
+ zuo_collect();
+
+ stream.stream.mode = zuo_fasl_out;
+
+ stream.heap = to_space;
+ stream.heap_size = allocation_offset;
+ stream.shadow_heap = malloc(allocation_offset);
+ memset(stream.shadow_heap, 0, allocation_offset);
+
+ stream.map_size = 1024;
+ stream.map_offset = 0;
+ stream.map = malloc(stream.map_size * sizeof(zuo_int32_t));
+ stream.objs = malloc(stream.map_size * sizeof(zuo_t*));
+
+ stream.image_size = 4096;
+ stream.image_offset = 0;
+ stream.image = malloc(stream.image_size * sizeof(zuo_int32_t));
+
+ zuo_fasl_roots(&stream.stream);
+
+ /* analogous to the collector's trace_objects loop: */
+ for (map_done = 0; map_done < stream.map_offset; map_done++) {+ zuo_t *obj = stream.objs[map_done];
+
+ /* register location of this object in the image */
+ stream.map[map_done] = stream.image_offset;
+
+ zuo_fasl(obj, &stream.stream);
+ }
+
+ total_size = header_size + stream.map_offset + stream.image_offset;
+ dump = malloc(total_size * sizeof(zuo_int32_t));
+
+ ((zuo_fasl_header_t *)dump)->magic = zuo_magic();
+ ((zuo_fasl_header_t *)dump)->map_size = stream.map_offset;
+ ((zuo_fasl_header_t *)dump)->image_size = stream.image_offset;
+ ((zuo_fasl_header_t *)dump)->symbol_count = zuo_symbol_count;
+ memcpy(dump + header_size, stream.map, stream.map_offset * sizeof(zuo_int32_t));
+ memcpy(dump + header_size + stream.map_offset, stream.image, stream.image_offset * sizeof(zuo_int32_t));
+
+ free(stream.image);
+ free(stream.objs);
+ free(stream.map);
+ free(stream.shadow_heap);
+
+ *_len = total_size * sizeof(zuo_int32_t);
+ return (char *)dump;
+}
+
+#define SWAP_ENDIAN(n) \
+ ((((n) & 0xFF) << 24) | (((n) & 0xFF00) << 8) | (((n) & 0xFF0000) >> 8) | (((n) >> 24) & 0xFF))
+
+static void zuo_fasl_restore(char *dump_in, zuo_int_t len) {+ zuo_fasl_stream_in_t stream;
+ zuo_int32_t *dump = (zuo_int32_t *)dump_in, i, map_len, alloc_factor = 2;
+ zuo_int32_t header_size = sizeof(zuo_fasl_header_t) / sizeof(zuo_int32_t);
+ zuo_int32_t magic = zuo_magic();
+
+ if (((zuo_fasl_header_t *)dump)->magic != magic) {+ if (((zuo_fasl_header_t *)dump)->magic == SWAP_ENDIAN(magic)) {+ /* adapt little-endian to big-endian, or vice versa */
+ for (i = 0; i < len / sizeof(zuo_int32_t); i++)
+ dump[i] = SWAP_ENDIAN(dump[i]);
+ } else
+ zuo_panic("image does not start with zuo magic");+ }
+
+ map_len = ((zuo_fasl_header_t *)dump)->map_size;
+
+ stream.stream.mode = zuo_fasl_in;
+
+ stream.map = dump + header_size;
+ stream.image = dump + header_size + map_len;
+ stream.heap_size = 0;
+ stream.offset = 0;
+
+ /* compute heap size and replace image offsets with heap offsets */
+ for (i = 0; i < map_len; i++) {+ zuo_int32_t delta = stream.map[i];
+ zuo_int32_t tag = stream.image[delta];
+ zuo_int_t sz;
+
+ ASSERT((tag >= 0) && (tag < zuo_forwarded_tag));
+
+ if (tag == zuo_string_tag)
+ sz = object_size(tag, BUILD_INT(stream.image[delta+1], stream.image[delta+2]));
+ else
+ sz = object_size(tag, 0);
+
+ stream.map[i] = stream.heap_size;
+ stream.heap_size += ALLOC_ALIGN(sz);
+ }
+
+ stream.heap = malloc(stream.heap_size * alloc_factor);
+
+ zuo_fasl_roots(&stream.stream);
+
+ for (i = 0; i < map_len; i++) {+ zuo_t *obj = (zuo_t *)((char *)stream.heap + stream.map[i]);
+ zuo_fasl(obj, &stream.stream);
+ }
+
+ zuo_symbol_count = ((zuo_fasl_header_t *)dump)->symbol_count;
+ zuo_handle_count = 0;
+
+ zuo_replace_heap(stream.heap, stream.heap_size * alloc_factor, stream.heap_size);
+}
+
+/*======================================================================*/
+/* object constructors */
+/*======================================================================*/
+
+static zuo_t *zuo_integer(zuo_int_t i) {+ zuo_integer_t *obj = (zuo_integer_t *)zuo_new(zuo_integer_tag, sizeof(zuo_integer_t));
+ obj->i = i;
+ return (zuo_t *)obj;
+}
+
+static zuo_t *zuo_cons(zuo_t *car, zuo_t *cdr) {+ zuo_pair_t *obj = (zuo_pair_t *)zuo_new(zuo_pair_tag, sizeof(zuo_pair_t));
+ obj->car = car;
+ obj->cdr = cdr;
+ return (zuo_t *)obj;
+}
+
+static zuo_t *zuo_uninitialized_string(zuo_intptr_t len) {+ zuo_string_t *obj = (zuo_string_t *)zuo_new(zuo_string_tag, ZUO_STRING_ALLOC_SIZE(len));
+ obj->len = len;
+ return (zuo_t *)obj;
+}
+
+static zuo_t *zuo_sized_string(const char *str, zuo_intptr_t len) {+ zuo_t *obj = zuo_uninitialized_string(len);
+ memcpy(ZUO_STRING_PTR(obj), str, len);
+ ZUO_STRING_PTR(obj)[len] = 0;
+ return obj;
+}
+
+static zuo_t *zuo_string(const char *str) {+ return zuo_sized_string(str, strlen(str));
+}
+
+static zuo_t *zuo_trie_node() {+ int i;
+ zuo_trie_node_t *obj = (zuo_trie_node_t *)zuo_new(zuo_trie_node_tag, sizeof(zuo_trie_node_t));
+
+ obj->count = 0;
+ obj->key = z.o_undefined;
+ obj->val = z.o_undefined;
+ for (i = 0; i < ZUO_TRIE_BFACTOR; i++)
+ obj->next[i] = z.o_undefined;
+
+ return (zuo_t *)obj;
+}
+
+static zuo_t *zuo_make_symbol_from_string(zuo_t *str) {+ zuo_symbol_t *obj = (zuo_symbol_t *)zuo_new(zuo_symbol_tag, sizeof(zuo_symbol_t));
+ obj->id = zuo_symbol_count++;
+ obj->str = str;
+ return (zuo_t *)obj;
+}
+
+static zuo_t *zuo_make_symbol(const char *in_str) {+ return zuo_make_symbol_from_string(zuo_string(in_str));
+}
+
+/* If `str_obj` is undefined, it's allocated as needed.
+ If `str_obj` us false, the result can be false. */
+static zuo_t *zuo_symbol_from_string(const char *in_str, zuo_t *str_obj) {+ const unsigned char *str = (const unsigned char *)in_str;
+ zuo_int_t i;
+ zuo_trie_node_t *node = (zuo_trie_node_t *)z.o_intern_table;
+
+ for (i = 0; str[i]; i++) {+ int c = str[i], lo = c & ZUO_TRIE_BFACTOR_MASK, hi = c >> ZUO_TRIE_BFACTOR_BITS;
+ if (node->next[lo] == z.o_undefined) {+ if (str_obj == z.o_false)
+ return z.o_false;
+ node->next[lo] = zuo_trie_node();
+ }
+ node = (zuo_trie_node_t *)node->next[lo];
+ if (node->next[hi] == z.o_undefined)
+ node->next[hi] = zuo_trie_node();
+ node = (zuo_trie_node_t *)node->next[hi];
+ }
+
+ if (node->val == z.o_undefined) {+ if (str_obj == z.o_false)
+ return z.o_false;
+ else if (str_obj == z.o_undefined)
+ node->val = zuo_make_symbol(in_str);
+ else
+ node->val = zuo_make_symbol_from_string(str_obj);
+ }
+ /* the symbol table doesn't use the `key` field */
+
+ return node->val;
+}
+
+static zuo_t *zuo_symbol(const char *in_str) {+ return zuo_symbol_from_string(in_str, z.o_undefined);
+}
+
+static zuo_t *zuo_variable(zuo_t *name) {+ zuo_variable_t *obj = (zuo_variable_t *)zuo_new(zuo_variable_tag, sizeof(zuo_variable_t));
+ obj->name = name;
+ obj->val = z.o_undefined;
+ return (zuo_t *)obj;
+}
+
+static zuo_t *zuo_primitive(zuo_dispatcher_proc_t dispatcher, void *proc, zuo_int32_t arity_mask, zuo_t *name) {+ zuo_register_primitive(dispatcher, proc, arity_mask);
+ /* if `name` is undefined, we're just registering a primitive to be used for an image */
+ if (name == z.o_undefined)
+ return z.o_undefined;
+ else {+ zuo_primitive_t *obj = (zuo_primitive_t *)zuo_new(zuo_primitive_tag, sizeof(zuo_primitive_t));
+ obj->dispatcher = dispatcher;
+ obj->proc = proc;
+ obj->arity_mask = arity_mask;
+ obj->name = name;
+ return (zuo_t *)obj;
+ }
+}
+
+static zuo_t *zuo_closure(zuo_t *lambda, zuo_t *env) {+ zuo_closure_t *obj = (zuo_closure_t *)zuo_new(zuo_closure_tag, sizeof(zuo_closure_t));
+ obj->lambda = lambda;
+ obj->env = env;
+ return (zuo_t *)obj;
+}
+
+static zuo_t *zuo_handle(zuo_raw_handle_t handle, zuo_handle_status_t status) {+ zuo_handle_t *obj = (zuo_handle_t *)zuo_new(zuo_handle_tag, sizeof(zuo_handle_t));
+ obj->id = zuo_handle_count++;
+ obj->u.h.u.handle = handle;
+ obj->u.h.status = status;
+ return (zuo_t *)obj;
+}
+
+static zuo_t *zuo_opaque(zuo_t *tag, zuo_t *val) {+ zuo_opaque_t *obj = (zuo_opaque_t *)zuo_new(zuo_opaque_tag, sizeof(zuo_opaque_t));
+ obj->tag = tag;
+ obj->val = val;
+ return (zuo_t *)obj;
+}
+
+static zuo_t *zuo_cont(zuo_cont_tag_t tag, zuo_t *data, zuo_t *env, zuo_t *in_proc, zuo_t *next) {+ zuo_cont_t *obj = (zuo_cont_t *)zuo_new(zuo_cont_tag, sizeof(zuo_cont_t));
+ obj->tag = tag;
+ obj->data = data;
+ obj->env = env;
+ obj->in_proc = in_proc;
+ obj->next = next;
+ return (zuo_t *)obj;
+}
+
+/*======================================================================*/
+/* tries */
+/*======================================================================*/
+
+/* A trie is used for the symbol table and for "hash tables" that are
+ symbol-keyed persistent maps. */
+
+static zuo_t *trie_lookup(zuo_t *trie, zuo_int_t id) {+ ASSERT(trie->tag == zuo_trie_node_tag);
+
+ while (id > 0) {+ trie = ((zuo_trie_node_t *)trie)->next[id & ZUO_TRIE_BFACTOR_MASK];
+ if (trie == z.o_undefined) return z.o_undefined;
+ id = id >> ZUO_TRIE_BFACTOR_BITS;
+ }
+
+ return ((zuo_trie_node_t *)trie)->val;
+}
+
+static zuo_t *zuo_trie_lookup(zuo_t *trie, zuo_t *sym) {+ return trie_lookup(trie, ((zuo_symbol_t *)sym)->id);
+}
+
+/* trie mutation, used only for the inital env */
+static void trie_set(zuo_t *trie, zuo_int_t id, zuo_t *key, zuo_t *val) {+ while (id > 0) {+ zuo_t *next = ((zuo_trie_node_t *)trie)->next[id & ZUO_TRIE_BFACTOR_MASK];
+ if (next == z.o_undefined) {+ next = zuo_trie_node();
+ ((zuo_trie_node_t *)trie)->next[id & ZUO_TRIE_BFACTOR_MASK] = next;
+ trie = next;
+ } else
+ trie = next;
+ id = id >> ZUO_TRIE_BFACTOR_BITS;
+ }
+ ((zuo_trie_node_t *)trie)->key = key;
+ ((zuo_trie_node_t *)trie)->val = val;
+}
+
+static void zuo_trie_set(zuo_t *trie, zuo_t *sym, zuo_t *val) {+ ASSERT(trie_lookup(trie, ((zuo_symbol_t *)sym)->id) == z.o_undefined);
+ trie_set(trie, ((zuo_symbol_t *)sym)->id, sym, val);
+ ((zuo_trie_node_t *)trie)->count++;
+}
+
+static zuo_trie_node_t *trie_clone(zuo_t *trie) {+ zuo_trie_node_t *new_trie = (zuo_trie_node_t *)zuo_new(zuo_trie_node_tag, sizeof(zuo_trie_node_t));
+ memcpy(new_trie, trie, sizeof(zuo_trie_node_t));
+ return new_trie;
+}
+
+static zuo_t *trie_extend(zuo_t *trie, zuo_int_t id, zuo_t *key, zuo_t *val, int *added) {+ zuo_trie_node_t *new_trie;
+
+ if (trie == z.o_undefined) {+ new_trie = (zuo_trie_node_t *)zuo_trie_node();
+ trie = (zuo_t *)new_trie;
+ *added = 1;
+ } else
+ new_trie = trie_clone(trie);
+
+ if (id > 0) {+ int i = id & ZUO_TRIE_BFACTOR_MASK;
+ new_trie->next[i] = trie_extend(((zuo_trie_node_t *)trie)->next[i], id >> ZUO_TRIE_BFACTOR_BITS, key, val, added);
+ new_trie->count += *added;
+ } else {+ if (new_trie->val == z.o_undefined) *added = 1;
+ new_trie->count += *added;
+ new_trie->key = key;
+ new_trie->val = val;
+ }
+
+ return (zuo_t *)new_trie;
+}
+
+static zuo_t *zuo_trie_extend(zuo_t *trie, zuo_t *sym, zuo_t *val) {+ int added = 0;
+ return trie_extend(trie, ((zuo_symbol_t *)sym)->id, sym, val, &added);
+}
+
+static zuo_t *trie_remove(zuo_t *trie, zuo_int_t id, int depth) {+ zuo_trie_node_t *new_trie;
+
+ if (trie == z.o_undefined)
+ return z.o_undefined;
+ else if (id > 0) {+ int i = id & ZUO_TRIE_BFACTOR_MASK;
+ zuo_t *sub_trie = trie_remove(((zuo_trie_node_t *)trie)->next[i], id >> ZUO_TRIE_BFACTOR_BITS, depth+1);
+ if (sub_trie == ((zuo_trie_node_t *)trie)->next[i])
+ return trie;
+
+ new_trie = trie_clone(trie);
+ ((zuo_trie_node_t *)new_trie)->next[i] = sub_trie;
+ new_trie->count -= 1;
+
+ if ((sub_trie != z.o_undefined)
+ || (new_trie->val != z.o_undefined))
+ return (zuo_t *)new_trie;
+ } else {+ if (((zuo_trie_node_t *)trie)->val == z.o_undefined)
+ return trie;
+
+ new_trie = trie_clone(trie);
+ new_trie->count -= 1;
+ new_trie->key = z.o_undefined;
+ new_trie->val = z.o_undefined;
+ }
+
+ if (depth > 0) {+ int i;
+ for (i = 0; i < ZUO_TRIE_BFACTOR; i++)
+ if (new_trie->next[i] != z.o_undefined)
+ return (zuo_t *)new_trie;
+ return z.o_undefined;
+ }
+
+ return (zuo_t *)new_trie;
+}
+
+static zuo_t *zuo_trie_remove(zuo_t *trie, zuo_t *sym) {+ return trie_remove(trie, ((zuo_symbol_t *)sym)->id, 0);
+}
+
+static int zuo_trie_keys_subset_p(zuo_t *trie1_in, zuo_t *trie2_in) {+ if (trie1_in == trie2_in)
+ return 1;
+ else if (trie1_in == z.o_undefined)
+ return 1;
+ else if (trie2_in == z.o_undefined)
+ return 0;
+ else {+ zuo_trie_node_t *trie1 = (zuo_trie_node_t *)trie1_in;
+ zuo_trie_node_t *trie2 = (zuo_trie_node_t *)trie2_in;
+ int i;
+
+ if (trie1->count > trie2->count)
+ return 0;
+
+ for (i = 0; i < ZUO_TRIE_BFACTOR; i++) {+ if (!zuo_trie_keys_subset_p(trie1->next[i], trie2->next[i]))
+ return 0;
+ }
+
+ return 1;
+ }
+}
+
+static zuo_t *zuo_trie_keys(zuo_t *trie_in, zuo_t *accum) {+ int i;
+ zuo_trie_node_t *trie = (zuo_trie_node_t *)trie_in;
+
+ if (trie->key != z.o_undefined)
+ accum = zuo_cons(trie->key, accum);
+
+ for (i = 0; i < ZUO_TRIE_BFACTOR; i++) {+ if (trie->next[i] != z.o_undefined)
+ accum = zuo_trie_keys(trie->next[i], accum);
+ }
+
+ return accum;
+}
+
+/*======================================================================*/
+/* terminal support */
+/*======================================================================*/
+
+static int zuo_ansi_ok = 1;
+
+static void zuo_init_terminal() {+#ifdef ZUO_WINDOWS
+ int i;
+ HANDLE h;
+
+ for (i = 0; i < 3; i++) {+ _setmode(i, _O_BINARY);
+
+ if (i != 0) {+ h = GetStdHandle((i == 1) ? STD_OUTPUT_HANDLE : STD_ERROR_HANDLE);
+ if (GetFileType(h) == FILE_TYPE_CHAR) {+ /* Try to enable ANSI escape codes, which should work for a recent
+ enough version of Windows */
+ DWORD mode = 0;
+ GetConsoleMode(h, &mode);
+# ifndef ENABLE_VIRTUAL_TERMINAL_PROCESSING
+# define ENABLE_VIRTUAL_TERMINAL_PROCESSING 0x4
+# endif
+ zuo_ansi_ok = SetConsoleMode(h, mode | ENABLE_VIRTUAL_TERMINAL_PROCESSING);
+ }
+ }
+ }
+#endif
+}
+
+static zuo_raw_handle_t zuo_get_std_handle(int which) {+#ifdef ZUO_UNIX
+ return which;
+#endif
+#ifdef ZUO_WINDOWS
+ HANDLE h;
+
+ switch (which) {+ case 0:
+ which = STD_INPUT_HANDLE;
+ break;
+ case 1:
+ which = STD_OUTPUT_HANDLE;
+ break;
+ default:
+ which = STD_ERROR_HANDLE;
+ break;
+ }
+
+ return GetStdHandle(which);
+#endif
+}
+
+int zuo_is_terminal(zuo_raw_handle_t fd) {+#ifdef ZUO_UNIX
+ return isatty(fd);
+#endif
+#ifdef ZUO_WINDOWS
+ if (GetFileType((HANDLE)fd) == FILE_TYPE_CHAR) {+ DWORD mode;
+ if (GetConsoleMode((HANDLE)fd, &mode))
+ return 1;
+ }
+ return 0;
+#endif
+}
+
+static void zuo_print_terminal(int which, const char *str) {+ if (zuo_is_terminal(zuo_get_std_handle(which))) {+ fprintf((which == 1) ? stdout : stderr, "%s", str);
+ }
+}
+
+static void zuo_error_color() {+ zuo_suspend_signal();
+ zuo_print_terminal(2, "\033[91m");
+}
+
+static void zuo_alert_color() {+ zuo_suspend_signal();
+ zuo_print_terminal(1, "\033[94m");
+}
+
+static void zuo_normal_color(int which) {+ zuo_print_terminal(which, "\033[0m");
+ fflush((which == 1) ? stdout : stderr);
+ zuo_resume_signal();
+}
+
+/*======================================================================*/
+/* printing */
+/*======================================================================*/
+
+typedef enum {+ zuo_print_mode,
+ zuo_write_mode,
+ zuo_display_mode
+} zuo_print_mode_t;
+
+typedef struct {+ char *s;
+ zuo_int_t size, len;
+} zuo_out_t;
+
+static void out_init(zuo_out_t *out) {+ out->size = 32;
+ out->len = 0;
+ out->s = malloc(out->size);
+}
+
+static void out_done(zuo_out_t *out) {+ free(out->s);
+}
+
+static void out_char(zuo_out_t *out, int c) {+ if (out->len == out->size) {+ zuo_int_t new_size = out->size * 2;
+ char *s = malloc(new_size);
+ memcpy(s, out->s, out->size);
+ free(out->s);
+ out->s = s;
+ out->size = new_size;
+ }
+
+ out->s[out->len++] = c;
+}
+
+static void out_string(zuo_out_t *out, const char *s) {+ while (*s != 0) {+ out_char(out, *s);
+ s++;
+ }
+}
+
+static void zuo_out(zuo_out_t *out, zuo_t *obj, zuo_print_mode_t mode) {+ /* recur to zuo_out directly only for atomic thigs, otherwise use `stack` */
+ zuo_t *stack = z.o_null;
+ /* slight hack: use various singletons for recur mode */
+# define ZUO_OUT_RECUR z.o_false
+# define ZUO_OUT_PAIR_RECUR z.o_true
+# define ZUO_OUT_HASH1_RECUR z.o_eof
+# define ZUO_OUT_HASH_RECUR z.o_null
+
+ while (1) {+ if (obj == z.o_undefined)
+ out_string(out, "#<undefined>");
+ else if (obj == z.o_null) {+ if (mode == zuo_print_mode)
+ out_string(out, "'");
+ out_string(out, "()");
+ } else if (obj == z.o_false)
+ out_string(out, "#f");
+ else if (obj == z.o_true)
+ out_string(out, "#t");
+ else if (obj == z.o_eof)
+ out_string(out, "#<eof>");
+ else if (obj == z.o_void)
+ out_string(out, "#<void>");
+ else if (obj->tag == zuo_integer_tag) {+ zuo_int_t i = ZUO_INT_I(obj), di, n, w, add_back = 0;
+ if (i < 0) {+ out_char(out, '-');
+ i = (zuo_int_t)(0-(zuo_uint_t)i);
+ if (i < 0) {+ /* min int */
+ i = -(i+1);
+ add_back = 1;
+ }
+ }
+ di = i / 10;
+ for (n = 1, w = 1; di >= n; n *= 10, w++);
+ while (n >= 1) {+ out_char(out, '0' + (i / n));
+ i = i - ((i / n) * n);
+ n /= 10;
+ i += add_back;
+ add_back = 0;
+ }
+ } else if (obj->tag == zuo_string_tag) {+ zuo_string_t *str = (zuo_string_t *)obj;
+ if (mode == zuo_display_mode) {+ int i;
+ for (i = 0; i < str->len; i++)
+ out_char(out, str->s[i]);
+ } else {+ int i;
+ out_string(out, "\"");
+ for (i = 0; i < str->len; i++) {+ int c = str->s[i];
+ if ((c == '"') || (c == '\\')) {+ out_char(out, '\\');
+ out_char(out, c);
+ } else if (c == '\n') {+ out_char(out, '\\');
+ out_char(out, 'n');
+ } else if (c == '\r') {+ out_char(out, '\\');
+ out_char(out, 'r');
+ } else if (c == '\t') {+ out_char(out, '\\');
+ out_char(out, 't');
+ } else if (isprint(c)) {+ out_char(out, c);
+ } else {+ out_char(out, '\\');
+ if ((c == 0) && ((str->s[i+1] < '0') || (str->s[i+1] > '7')))
+ out_char(out, '0');
+ else {+ out_char(out, '0' + ((c >> 6) & 0x7));
+ out_char(out, '0' + ((c >> 3) & 0x7));
+ out_char(out, '0' + ((c >> 0) & 0x7));
+ }
+ }
+ }
+ out_string(out, "\"");
+ }
+ } else if (obj->tag == zuo_symbol_tag) {+ if ((mode == zuo_display_mode)
+ || (obj == zuo_symbol_from_string(ZUO_STRING_PTR(((zuo_symbol_t *)obj)->str), z.o_false))) {+ if (mode == zuo_print_mode)
+ out_char(out, '\'');
+ zuo_out(out, ((zuo_symbol_t *)obj)->str, zuo_display_mode);
+ } else {+ out_string(out, "#<symbol:");
+ zuo_out(out, ((zuo_symbol_t *)obj)->str, zuo_display_mode);
+ out_string(out, ">");
+ }
+ } else if (obj->tag == zuo_pair_tag) {+ zuo_pair_t *p = (zuo_pair_t *)obj;
+ out_char(out, '(');+ if (mode == zuo_print_mode) {+ zuo_t *p2 = (zuo_t *)p;
+ while (p2->tag == zuo_pair_tag)
+ p2 = ((zuo_pair_t *)p2)->cdr;
+ if (p2 == z.o_null)
+ out_string(out, "list ");
+ else if (ZUO_CDR(p)->tag != zuo_pair_tag)
+ out_string(out, "cons ");
+ else
+ out_string(out, "list* ");
+ }
+ stack = zuo_cons(zuo_cons(ZUO_OUT_PAIR_RECUR, p->cdr), stack);
+ stack = zuo_cons(zuo_cons(ZUO_OUT_RECUR, p->car), stack);
+ } else if (obj->tag == zuo_primitive_tag) {+ out_string(out, "#<procedure:");
+ zuo_out(out, ((zuo_primitive_t *)obj)->name, zuo_display_mode);
+ out_string(out, ">");
+ } else if (obj == z.o_apply) {+ out_string(out, "#<procedure:apply>");
+ } else if (obj == z.o_call_cc) {+ out_string(out, "#<procedure:call/cc>");
+ } else if (obj == z.o_call_prompt) {+ out_string(out, "#<procedure:call/prompt>");
+ } else if (obj == z.o_kernel_eval) {+ out_string(out, "#<procedure:kernel-eval>");
+ } else if (obj->tag == zuo_closure_tag) {+ zuo_t *dd = ZUO_CDR(ZUO_CDR(((zuo_closure_t *)obj)->lambda));
+ out_string(out, "#<procedure");
+ if (ZUO_CAR(dd)->tag == zuo_string_tag) {+ out_string(out, ":");
+ zuo_out(out, ZUO_CAR(dd), zuo_display_mode);
+ }
+ out_string(out, ">");
+ } else if (obj->tag == zuo_opaque_tag) {+ out_string(out, "#<");
+ if ((((zuo_opaque_t *)obj)->tag->tag == zuo_string_tag)
+ || (((zuo_opaque_t *)obj)->tag->tag == zuo_symbol_tag))
+ zuo_out(out, ((zuo_opaque_t *)obj)->tag, zuo_display_mode);
+ else
+ out_string(out, "opaque");
+ out_string(out, ">");
+ } else if (obj->tag == zuo_trie_node_tag) {+ zuo_t *keys = zuo_trie_keys(obj, z.o_null);
+ if (mode == zuo_print_mode) {+ out_string(out, "(hash");
+ if (keys != z.o_null)
+ out_string(out, " ");
+ } else
+ out_string(out, "#hash(");+ stack = zuo_cons(zuo_cons(ZUO_OUT_HASH1_RECUR, zuo_cons(keys, obj)), stack);
+ } else if (obj->tag == zuo_handle_tag) {+ out_string(out, "#<handle>");
+ } else if (obj->tag == zuo_cont_tag) {+ out_string(out, "#<continuation>");
+ } else if (obj->tag == zuo_variable_tag) {+ out_string(out, "#<variable:");
+ zuo_out(out, ((zuo_variable_t *)obj)->name, zuo_display_mode);
+ out_string(out, ">");
+ } else {+ out_string(out, "#<garbage>");
+ }
+
+ while (1) {+ if (stack == z.o_null)
+ return;
+ else {+ zuo_pair_t *op = (zuo_pair_t *)ZUO_CAR(stack);
+ if (op->car == ZUO_OUT_RECUR) {+ stack = ZUO_CDR(stack);
+ obj = op->cdr;
+ break;
+ } else if (op->car == ZUO_OUT_PAIR_RECUR) {+ obj = op->cdr;
+ if (obj->tag == zuo_pair_tag) {+ zuo_pair_t *p = (zuo_pair_t *)obj;
+ out_char(out, ' ');
+ obj = p->car;
+ op->cdr = p->cdr; /* reuse stack frame */
+ break;
+ } else if (obj == z.o_null) {+ stack = _zuo_cdr(stack);
+ out_char(out, ')');
+ } else {+ if (mode != zuo_print_mode) {+ out_char(out, ' ');
+ out_char(out, '.');
+ }
+ out_char(out, ' ');
+ op->cdr = z.o_null; /* reuse stack frame */
+ break;
+ }
+ } else if ((op->car == ZUO_OUT_HASH1_RECUR)
+ || (op->car == ZUO_OUT_HASH_RECUR)) {+ zuo_pair_t *p = (zuo_pair_t *)op->cdr;
+ zuo_t *keys = p->car;
+ zuo_t *ht = p->cdr;
+ if (op->car == ZUO_OUT_HASH_RECUR) {+ /* close key--value pair */
+ if (mode != zuo_print_mode)
+ out_string(out, ")");
+ }
+ if (keys != z.o_null) {+ zuo_t *key = ZUO_CAR(keys);
+ if (op->car == ZUO_OUT_HASH_RECUR) {+ /* space after previous pair */
+ out_string(out, " ");
+ }
+ if (mode != zuo_print_mode)
+ out_string(out, "(");+ zuo_out(out, key, mode); /* a symbol */
+ if (mode == zuo_print_mode)
+ out_string(out, " ");
+ else
+ out_string(out, " . ");
+ obj = zuo_trie_lookup(ht, key);
+ op->car = ZUO_OUT_HASH_RECUR; /* reuse stack frame */
+ p->car = ZUO_CDR(keys);
+ break;
+ } else {+ stack = _zuo_cdr(stack);
+ out_string(out, ")");
+ }
+ } else {+ zuo_panic("unrecognized operation on stack");+ }
+ }
+ }
+ }
+}
+
+static void zuo_fout(FILE *fout, zuo_t *obj, zuo_print_mode_t mode) {+ zuo_out_t out;
+ out_init(&out);
+ zuo_out(&out, obj, mode);
+ fwrite(out.s, 1, out.len, fout);
+ out_done(&out);
+}
+
+static zuo_t *zuo_to_string(zuo_t *objs, zuo_print_mode_t mode) {+ zuo_out_t out;
+ zuo_t *str;
+ out_init(&out);
+
+ while (objs->tag == zuo_pair_tag) {+ zuo_out(&out, ZUO_CAR(objs), mode);
+ objs = ZUO_CDR(objs);
+ if ((mode != zuo_display_mode) && (objs != z.o_null))
+ out_char(&out, ' ');
+ }
+ if (objs != z.o_null)
+ zuo_out(&out, objs, mode);
+
+ str = zuo_sized_string(out.s, out.len);
+ out_done(&out);
+ return str;
+}
+
+static void zuo_fprint(FILE *out, zuo_t *obj) {+ zuo_fout(out, obj, zuo_print_mode);
+}
+
+static void zuo_fdisplay(FILE *out, zuo_t *obj) {+ zuo_fout(out, obj, zuo_display_mode);
+}
+
+static void zuo_fwrite(FILE *out, zuo_t *obj) {+ zuo_fout(out, obj, zuo_write_mode);
+}
+
+static void done_dump_name(zuo_t *showed_name, int repeats) {+ if (showed_name != z.o_false) {+ if (repeats > 0) {+ fprintf(stderr, " {%d}", repeats+1);+ repeats = 0;
+ }
+ fprintf(stderr, "\n");
+ }
+}
+
+static void zuo_stack_trace() {+ zuo_t *k = Z.o_interp_k, *meta_k = Z.o_interp_meta_k;
+ zuo_t *showed_name = z.o_false;
+ int repeats = 0;
+
+ do {+ while (k != z.o_done_k) {+ zuo_t *name = ((zuo_cont_t *)k)->in_proc;
+ if (name->tag == zuo_string_tag) {+ if (name == showed_name)
+ repeats++;
+ else {+ done_dump_name(showed_name, repeats);
+ repeats = 0;
+ showed_name = name;
+ fprintf(stderr, " in %s", ZUO_STRING_PTR(name));
+ }
+ }
+ k = ((zuo_cont_t *)k)->next;
+ }
+ if (meta_k != z.o_null) {+ k = _zuo_car(_zuo_car(meta_k));
+ meta_k = _zuo_cdr(meta_k);
+ }
+ } while (k != z.o_done_k);
+ done_dump_name(showed_name, repeats);
+}
+
+static void zuo_clean_all(); /* a necessary forward reference */
+
+static void zuo_exit_int(int v) {+ zuo_clean_all();
+ exit(v);
+}
+
+static void zuo_sync_in_case_of_fail() {+ /* make sure state consulted by zuo_fail() is in "no context" mode */
+ Z.o_interp_k = z.o_done_k;
+ Z.o_interp_meta_k = z.o_null;
+ Z.o_cleanable_table = z.o_undefined;
+}
+
+static void zuo_fail(const char *str) {+ if (str[0] != 0)
+ zuo_error_color();
+ fprintf(stderr, "%s\n", str);
+ zuo_normal_color(2);
+ zuo_stack_trace();
+ zuo_exit_int(1);
+}
+
+static void zuo_show_err1w(const char *who, const char *str, zuo_t *obj) {+ if (who != NULL)
+ fprintf(stderr, "%s: ", who);
+ fprintf(stderr, "%s: ", str);
+ zuo_fprint(stderr, obj);
+}
+
+static void zuo_fail1w(const char *who, const char *str, zuo_t *obj) {+ zuo_error_color();
+ zuo_show_err1w(who, str, obj);
+ zuo_fail("");+}
+
+static void zuo_fail1w_errno(const char *who, const char *str, zuo_t *obj) {+ const char *msg = strerror(errno);
+ zuo_error_color();
+ zuo_show_err1w(who, str, obj);
+ fprintf(stderr, " (%s)", msg);
+ zuo_fail("");+}
+
+static void zuo_fail1(const char *str, zuo_t *obj) {+ zuo_fail1w(NULL, str, obj);
+}
+
+static void zuo_fail_arg(const char *who, const char *what, zuo_t *obj) {+ const char *not_a;
+ zuo_t *msg;
+
+ if ((what[0] == 'a') || (what[0] == 'e') || (what[0] == 'i') || (what[0] == 'o') || (what[0] == 'u'))
+ not_a = "not an ";
+ else
+ not_a = "not a ";
+ msg = zuo_to_string(zuo_cons(zuo_string(not_a), zuo_cons(zuo_string(what), z.o_null)), zuo_display_mode);
+ zuo_fail1w(who, ZUO_STRING_PTR(msg), obj);
+}
+
+static void check_string(const char *who, zuo_t *obj) {+ if (obj->tag != zuo_string_tag)
+ zuo_fail_arg(who, "string", obj);
+}
+
+static void check_symbol(const char *who, zuo_t *obj) {+ if (obj->tag != zuo_symbol_tag)
+ zuo_fail_arg(who, "symbol", obj);
+}
+
+static void check_integer(const char *who, zuo_t *n) {+ if (n->tag != zuo_integer_tag)
+ zuo_fail_arg(who, "integer", n);
+}
+
+static void check_hash(const char *who, zuo_t *obj) {+ if (obj->tag != zuo_trie_node_tag)
+ zuo_fail_arg(who, "hash table", obj);
+}
+
+/*======================================================================*/
+/* reading */
+/*======================================================================*/
+
+static const char *symbol_chars = "~!@#$%^&*-_=+:<>?/.";
+
+static void zuo_read_fail2(const unsigned char *s, zuo_int_t *_o, zuo_t *where,
+ const char *msg, const char *msg2) {+ const char *in_s = "";
+ const char *where_s = "";
+ if ((where != z.o_undefined) && (where != z.o_false)) {+ in_s = " in ";
+ where_s = ZUO_STRING_PTR(zuo_to_string(where, zuo_write_mode));
+ }
+
+ zuo_error_color();
+ fprintf(stderr, "read: %s%s at position %d%s%s", msg, msg2, (int)*_o, in_s, where_s);
+ zuo_fail("");+}
+
+static void zuo_read_fail(const unsigned char *s, zuo_int_t *_o, zuo_t *where,
+ const char *msg) {+ zuo_read_fail2(s, _o, where, msg, "");
+}
+
+static int peek_input(const unsigned char *s, zuo_int_t *_o, const char *want) {+ int i, c;
+ for (i = 0; want[i]; i++) {+ if (s[(*_o)+i] != want[i])
+ return 0;
+ }
+ c = s[(*_o)+i];
+ if ((c != 0) && (isdigit(c) || isalpha(c) || strchr(symbol_chars, c)))
+ return 0;
+ return 1;
+}
+
+static int all_digits_before_delim(const unsigned char *s, zuo_int_t i) {+ while (isdigit(s[i]) || isalpha(s[i]) || strchr(symbol_chars, s[i])) {+ if (!isdigit(s[i]))
+ return 0;
+ i++;
+ }
+ return 1;
+}
+
+static zuo_t *zuo_in(const unsigned char *s, zuo_int_t *_o, zuo_t *where, int skip_whitespace_only) {+ /* use `stack` insteda of recurring */
+ zuo_t *stack = z.o_null, *obj;
+ int c;
+ /* slight hack: use various singletons for recur mode */
+# define ZUO_IN_DISCARD_RECUR z.o_undefined
+# define ZUO_IN_QUOTE_RECUR z.o_true
+# define ZUO_IN_PAREN_LIST_RECUR z.o_false
+# define ZUO_IN_PAREN_PAIR_RECUR z.o_null
+# define ZUO_IN_PAREN_END_RECUR z.o_eof
+# define ZUO_IN_BRACKET_LIST_RECUR z.o_void
+# define ZUO_IN_BRACKET_PAIR_RECUR z.o_empty_hash
+# define ZUO_IN_BRACKET_END_RECUR z.o_apply
+
+ while (1) {+ /* skip whitespace */
+ while (1) {+ while (isspace(s[*_o]))
+ (*_o)++;
+ if (s[*_o] == ';') {+ while ((s[*_o] != '\n') && (s[*_o] != 0))
+ (*_o)++;
+ } else if (s[*_o] == '#' && s[(*_o) + 1] == ';') {+ (*_o) += 2;
+ stack = zuo_cons(zuo_cons(ZUO_IN_DISCARD_RECUR, z.o_null), stack);
+ } else
+ break;
+ }
+
+ if ((stack == z.o_null) && skip_whitespace_only)
+ return z.o_null;
+
+ c = s[*_o];
+
+ if ((stack != z.o_null) && (ZUO_CAR(ZUO_CAR(stack)) == ZUO_IN_PAREN_END_RECUR)) {+ if (c != ')')
+ zuo_read_fail(s, _o, where, "expected closer after dot");
+ (*_o)++;
+ obj = ZUO_CAR(ZUO_CDR(ZUO_CAR(stack)));
+ stack = ZUO_CDR(stack);
+ } else if ((stack != z.o_null) && (ZUO_CAR(ZUO_CAR(stack)) == ZUO_IN_BRACKET_END_RECUR)) {+ if (c != ']')
+ zuo_read_fail(s, _o, where, "expected closer after dot");
+ (*_o)++;
+ obj = ZUO_CAR(ZUO_CDR(ZUO_CAR(stack)));
+ stack = ZUO_CDR(stack);
+ } else if (c == 0)
+ obj = z.o_eof;
+ else if ((c == '(') || (c == '[')) {+ (*_o)++;
+ obj = z.o_undefined; /* => skip whitespace next */
+ stack = zuo_cons(zuo_cons(((c == '(')+ ? ZUO_IN_PAREN_LIST_RECUR
+ : ZUO_IN_BRACKET_LIST_RECUR),
+ zuo_cons(z.o_null, z.o_null)),
+ stack);
+ } else if ((c == ')') || (c == ']')) {+ zuo_t *want_list = ((c == ')') ? ZUO_IN_PAREN_LIST_RECUR : ZUO_IN_BRACKET_LIST_RECUR);
+ zuo_t *want_pair = ((c == ')') ? ZUO_IN_PAREN_PAIR_RECUR : ZUO_IN_BRACKET_PAIR_RECUR);
+ if ((stack != z.o_null)
+ && ((ZUO_CAR(ZUO_CAR(stack)) == want_list)
+ || (ZUO_CAR(ZUO_CAR(stack)) == want_pair))) {+ obj = ZUO_CAR(ZUO_CDR(ZUO_CAR(stack)));
+ stack = ZUO_CDR(stack);
+ } else {+ zuo_read_fail(s, _o, where, "unbalanced closer");
+ obj = z.o_undefined;
+ }
+ (*_o)++;
+ } else if ((c == '"') || ((c == '#') && (s[(*_o)+1] == '"'))) {+ zuo_int_t sz = 32;
+ zuo_int_t len = 0;
+ char *s2 = malloc(sz);
+ if (c == '#')
+ (*_o)++;
+ (*_o)++;
+ while (1) {+ if (sz == len) {+ char *s3 = malloc(sz * 2);
+ memcpy(s3, s2, sz);
+ free(s2);
+ s2 = s3;
+ sz = sz * 2;
+ }
+ c = s[*_o];
+ if (c == 0) {+ zuo_read_fail(s, _o, where, "missing closing doublequote");
+ } else if (c == '"') {+ (*_o)++;
+ break;
+ } else if (c == '\\') {+ int c2 = s[(*_o)+1];
+ if ((c2 == '\\') || (c2 == '"')) {+ s2[len++] = c2;
+ (*_o) += 2;
+ } else if (c2 == 'n') {+ s2[len++] = '\n';
+ (*_o) += 2;
+ } else if (c2 == 'r') {+ s2[len++] = '\r';
+ (*_o) += 2;
+ } else if (c2 == 't') {+ s2[len++] = '\t';
+ (*_o) += 2;
+ } else if ((c2 >= '0') && (c2 <= '7')) {+ int v = c2 - '0', c3;
+ (*_o) += 2;
+ c3 = s[*_o];
+ if ((c3 >= '0') && (c3 <= '7')) {+ v = (v << 3) + (c3 - '0');
+ (*_o) += 1;
+ if (c2 <= '3') {+ c3 = s[*_o];
+ if ((c3 >= '0') && (c3 <= '7')) {+ v = (v << 3) + (c3 - '0');
+ (*_o) += 1;
+ }
+ }
+ }
+ s2[len++] = v;
+ } else
+ zuo_read_fail(s, _o, where, "bad character after backslash");
+ } else if (c == '\n') {+ zuo_read_fail(s, _o, where, "newline in string literal");
+ } else if (c == '\r') {+ zuo_read_fail(s, _o, where, "carriage return in string literal");
+ } else {+ s2[len++] = c;
+ (*_o)++;
+ }
+ }
+ obj = zuo_sized_string(s2, len);
+ free(s2);
+ } else if (c == '#') {+ (*_o)++;
+ if (peek_input(s, _o, "true")) {+ (*_o) += 4;
+ obj = z.o_true;
+ } else if (peek_input(s, _o, "false")) {+ (*_o) += 5;
+ obj = z.o_false;
+ } else if (peek_input(s, _o, "t")) {+ (*_o) += 1;
+ obj = z.o_true;
+ } else if (peek_input(s, _o, "f")) {+ (*_o) += 1;
+ obj = z.o_false;
+ } else {+ zuo_read_fail(s, _o, where, "bad hash mark");
+ obj = z.o_undefined;
+ }
+ } else if ((isdigit(c) || ((c == '-') && isdigit(s[(*_o)+1])))
+ && all_digits_before_delim(s, (*_o) + 1)) {+ zuo_uint_t n;
+ int neg = (c == '-');
+ if (neg) (*_o)++;
+ n = s[*_o] - '0';
+ (*_o)++;
+ while (isdigit(s[*_o])) {+ zuo_uint_t new_n = (10 * n) + (s[*_o] - '0');
+ if (new_n < n)
+ zuo_read_fail(s, _o, where, "integer overflow");
+ n = new_n;
+ (*_o)++;
+ }
+ if (neg) {+ n = 0 - n;
+ if ((zuo_int_t)n > 0)
+ zuo_read_fail(s, _o, where, "integer overflow");
+ obj = zuo_integer((zuo_int_t)n);
+ } else {+ if ((zuo_int_t)n < 0)
+ zuo_read_fail(s, _o, where, "integer overflow");
+ obj = zuo_integer((zuo_int_t)n);
+ }
+ } else if (c == '\'') {+ (*_o)++;
+ stack = zuo_cons(zuo_cons(ZUO_IN_QUOTE_RECUR, zuo_symbol("quote")), stack);+ obj = z.o_undefined;
+ } else if (c == '`') {+ (*_o)++;
+ stack = zuo_cons(zuo_cons(ZUO_IN_QUOTE_RECUR, zuo_symbol("quasiquote")), stack);+ obj = z.o_undefined;
+ } else if (c == ',') {+ int splicing = 0;
+ (*_o)++;
+ if (s[*_o] == '@') {+ splicing = 1;
+ (*_o)++;
+ }
+ stack = zuo_cons(zuo_cons(ZUO_IN_QUOTE_RECUR, (splicing
+ ? zuo_symbol("unquote-splicing")+ : zuo_symbol("unquote"))),+ stack);
+ obj = z.o_undefined;
+ } else if ((c == '.') && !(isalpha(s[*_o+1]) || isdigit(s[*_o+1]) || strchr(symbol_chars, s[*_o+1]))) {+ if ((stack != z.o_null) && (ZUO_CAR(ZUO_CAR(stack)) == ZUO_IN_PAREN_LIST_RECUR))
+ ZUO_CAR(ZUO_CAR(stack)) = ZUO_IN_PAREN_PAIR_RECUR;
+ else if ((stack != z.o_null) && (ZUO_CAR(ZUO_CAR(stack)) == ZUO_IN_BRACKET_LIST_RECUR))
+ ZUO_CAR(ZUO_CAR(stack)) = ZUO_IN_BRACKET_PAIR_RECUR;
+ else
+ zuo_read_fail(s, _o, where, "misplaced `.`");
+ (*_o)++;
+ obj = z.o_undefined;
+ } else if (isalpha(c) || isdigit(c) || strchr(symbol_chars, c)) {+ zuo_t *sym;
+ zuo_int_t start = *_o, len;
+ char *s2;
+ while (1) {+ c = s[*_o];
+ if ((c != 0) && (isalpha(c) || isdigit(c) || strchr(symbol_chars, c)))
+ (*_o)++;
+ else
+ break;
+ }
+ len = (*_o) - start;
+ s2 = malloc(len+1);
+ memcpy(s2, s + start, len);
+ s2[len] = 0;
+ sym = zuo_symbol(s2);
+ free(s2);
+ obj = sym;
+ } else {+ char sc[2];
+ sc[0] = c;
+ sc[1] = 0;
+ zuo_fail1w("read", "unrecognized character", zuo_string(sc));+ obj = z.o_null;
+ }
+
+ while (1) {+ if (obj == z.o_undefined)
+ break;
+ else if (stack == z.o_null)
+ return obj;
+ else {+ zuo_pair_t *op = (zuo_pair_t *)ZUO_CAR(stack);
+
+ if (op->car == ZUO_IN_QUOTE_RECUR) {+ if (obj == z.o_eof)
+ zuo_read_fail2(s, _o, where, "end of file after ",
+ ZUO_STRING_PTR(((zuo_symbol_t *)op->cdr)->str));
+ obj = zuo_cons(op->cdr, zuo_cons(obj, z.o_null));
+ stack = ZUO_CDR(stack);
+ } else if (op->car == ZUO_IN_DISCARD_RECUR) {+ if (obj == z.o_eof)
+ zuo_read_fail(s, _o, where, "end of file after comment hash-semicolon");
+ stack = ZUO_CDR(stack);
+ break;
+ } else if ((op->car == ZUO_IN_PAREN_LIST_RECUR)
+ || (op->car == ZUO_IN_BRACKET_LIST_RECUR)) {+ if (obj == z.o_eof) {+ zuo_read_fail(s, _o, where, "missing closer");
+ return z.o_undefined;
+ } else {+ zuo_t *pr = zuo_cons(obj, z.o_null);
+ if (ZUO_CAR(op->cdr) == z.o_null)
+ ZUO_CAR(op->cdr) = pr;
+ else
+ ZUO_CDR(ZUO_CDR(op->cdr)) = pr;
+ ZUO_CDR(op->cdr) = pr;
+ break;
+ }
+ } else if ((op->car == ZUO_IN_PAREN_PAIR_RECUR)
+ || (op->car == ZUO_IN_BRACKET_PAIR_RECUR)) {+ if (obj == z.o_eof) {+ zuo_read_fail(s, _o, where, "end of file after dot");
+ return z.o_undefined;
+ } else {+ ZUO_CDR(ZUO_CDR(op->cdr)) = obj;
+ if (op->car == ZUO_IN_PAREN_PAIR_RECUR)
+ op->car = ZUO_IN_PAREN_END_RECUR;
+ else
+ op->car = ZUO_IN_BRACKET_END_RECUR;
+ break;
+ }
+ }
+ }
+ }
+ }
+}
+
+static zuo_t *zuo_string_read(zuo_t *str, zuo_t *start_i, zuo_t *where) {+ const char *who = "string-read";
+ zuo_int_t len, start, i;
+ zuo_t *first = z.o_null, *last = z.o_null, *p;
+ const char *s;
+ zuo_int_t o;
+
+ check_string(who, str);
+ len = ZUO_STRING_LEN(str);
+
+ if (start_i == z.o_undefined)
+ start = 0;
+ else {+ check_integer(who, start_i);
+ start = ZUO_INT_I(start_i);
+ if ((start < 0) || (start > len))
+ zuo_fail1w(who, "starting index is out of bounds", start_i);
+ }
+
+ s = ZUO_STRING_PTR(str);
+ o = start;
+
+ for (i = start; i < len; i++)
+ if (s[i] == 0)
+ zuo_fail1w(who, "nul character in input", str);
+
+ while (1) {+ zuo_t *obj = zuo_in((const unsigned char *)s, &o, where, 0);
+ if (obj == z.o_eof)
+ break;
+ p = zuo_cons(obj, z.o_null);
+ if (first == z.o_null)
+ first = p;
+ else
+ ((zuo_pair_t *)last)->cdr = p;
+ last = p;
+ }
+
+ return first;
+}
+
+static int zuo_is_symbol_module_char(int c) {+ return (c != 0) && (isalpha(c) || isdigit(c) || strchr("-_+/", c));+}
+
+static zuo_t *zuo_read_language(const char *s_in, zuo_int_t *_post, zuo_t *where) {+ const unsigned char *s = (const unsigned char *)s_in;
+ zuo_int_t o = 0, i, j;
+ const char *expect = "#lang ";
+ zuo_t *r;
+
+ zuo_in(s, &o, where, 1);
+ for (i = 0; expect[i]; i++) {+ if (s[o+i] != expect[i])
+ zuo_read_fail(s, &o, where, "expected #lang followed by a space");
+ }
+ for (j = 0; 1; j++) {+ int c = s[o+i+j];
+ if (!zuo_is_symbol_module_char(c))
+ break;
+ }
+ if (!j || !((s[o+i+j] == 0) || isspace(s[o+i+j])))
+ zuo_read_fail(s, &o, where, "expected module library path after #lang");
+
+ r = zuo_sized_string((char *)s+o+i, j);
+ r = zuo_symbol_from_string(ZUO_STRING_PTR(r), r);
+
+ *_post = o+i+j;
+
+ return r;
+}
+
+/*======================================================================*/
+/* primitive wrapper/dispatchers */
+/*======================================================================*/
+
+static zuo_t *dispatch_primitive0(void *proc, zuo_t *args) {+ return ((zuo_t *(*)())proc)();
+}
+
+static zuo_t *zuo_primitive0(zuo_t *(*f)(), zuo_t *name) {+ return zuo_primitive(dispatch_primitive0, (void *)f, (1 << 0), name);
+}
+
+static zuo_t *dispatch_primitive1(void *proc, zuo_t *args) {+ return ((zuo_t *(*)(zuo_t *))proc)(ZUO_CAR(args));
+}
+
+static zuo_t *zuo_primitive1(zuo_t *(*f)(zuo_t *), zuo_t *name) {+ return zuo_primitive(dispatch_primitive1, (void *)f, (1 << 1), name);
+}
+
+static zuo_t *dispatch_primitive2(void *proc, zuo_t *args) {+ return ((zuo_t *(*)(zuo_t *, zuo_t *))proc)(ZUO_CAR(args), ZUO_CAR(ZUO_CDR(args)));
+}
+
+static zuo_t *zuo_primitive2(zuo_t *(*f)(zuo_t *, zuo_t *), zuo_t *name) {+ return zuo_primitive(dispatch_primitive2, (void *)f, (1 << 2), name);
+}
+
+static zuo_t *dispatch_primitive3(void *proc, zuo_t *args) {+ return ((zuo_t *(*)(zuo_t *, zuo_t *, zuo_t *))proc)(ZUO_CAR(args),
+ ZUO_CAR(ZUO_CDR(args)),
+ ZUO_CAR(ZUO_CDR(ZUO_CDR(args))));
+}
+
+static zuo_t *zuo_primitive3(zuo_t *(*f)(zuo_t *, zuo_t *, zuo_t *), zuo_t *name) {+ return zuo_primitive(dispatch_primitive3, (void *)f, (1 << 3), name);
+}
+
+static zuo_t *dispatch_primitivea(void *proc, zuo_t *args) {+ return ((zuo_t *(*)(zuo_t *))proc)((args == z.o_null)
+ ? z.o_undefined
+ : ZUO_CAR(args));
+}
+
+static zuo_t *zuo_primitivea(zuo_t *(*f)(zuo_t *), zuo_t *name) {+ return zuo_primitive(dispatch_primitivea, (void *)f, ((1 << 0) | (1 << 1)), name);
+}
+
+static zuo_t *dispatch_primitiveb(void *proc, zuo_t *args) {+ return ((zuo_t *(*)(zuo_t *, zuo_t *))proc)(ZUO_CAR(args),
+ ((ZUO_CDR(args) == z.o_null)
+ ? z.o_undefined
+ : ZUO_CAR(ZUO_CDR(args))));
+}
+
+static zuo_t *zuo_primitiveb(zuo_t *(*f)(zuo_t *, zuo_t *), zuo_t *name) {+ return zuo_primitive(dispatch_primitiveb, (void *)f, ((1 << 1) | (1 << 2)), name);
+}
+
+static zuo_t *dispatch_primitivec(void *proc, zuo_t *args) {+ return ((zuo_t *(*)(zuo_t *, zuo_t *, zuo_t *))proc)(ZUO_CAR(args), ZUO_CAR(ZUO_CDR(args)),
+ ((ZUO_CDR(ZUO_CDR(args)) == z.o_null)
+ ? z.o_undefined
+ : ZUO_CAR(ZUO_CDR(ZUO_CDR(args)))));
+}
+
+static zuo_t *zuo_primitivec(zuo_t *(*f)(zuo_t *, zuo_t *, zuo_t *), zuo_t *name) {+ return zuo_primitive(dispatch_primitivec, (void *)f, ((1 << 2) | (1 << 3)), name);
+}
+
+static zuo_t *dispatch_primitiveC(void *proc, zuo_t *args) {+ zuo_t *a = ZUO_CAR(args), *b = z.o_undefined, *c = z.o_undefined;
+ args = ZUO_CDR(args);
+ if (args != z.o_null) {+ b = ZUO_CAR(args);
+ args = ZUO_CDR(args);
+ if (args != z.o_null)
+ c = ZUO_CAR(args);
+ }
+ return ((zuo_t *(*)(zuo_t *, zuo_t *, zuo_t *))proc)(a, b, c);
+}
+
+static zuo_t *zuo_primitiveC(zuo_t *(*f)(zuo_t *, zuo_t *, zuo_t *), zuo_t *name) {+ return zuo_primitive(dispatch_primitiveC, (void *)f, ((1 << 1) | (1 << 2) | (1 << 3)), name);
+}
+
+static zuo_t *dispatch_primitiveN(void *proc, zuo_t *args) {+ return ((zuo_t *(*)(zuo_t *))proc)(args);
+}
+
+static zuo_t *zuo_primitiveN(zuo_t *(*f)(zuo_t *), zuo_int_t mask, zuo_t *name) {+ return zuo_primitive(dispatch_primitiveN, (void *)f, mask, name);
+}
+
+/*======================================================================*/
+/* object primitives */
+/*======================================================================*/
+
+static zuo_t *zuo_pair_p(zuo_t *obj) {+ return (obj->tag == zuo_pair_tag) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_null_p(zuo_t *obj) {+ return (obj == z.o_null) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_integer_p(zuo_t *obj) {+ return (obj->tag == zuo_integer_tag) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_string_p(zuo_t *obj) {+ return (obj->tag == zuo_string_tag) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_symbol_p(zuo_t *obj) {+ return (obj->tag == zuo_symbol_tag) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_procedure_p(zuo_t *obj) {+ return (((obj->tag == zuo_primitive_tag)
+ || (obj->tag == zuo_closure_tag)
+ || (obj->tag == zuo_cont_tag)
+ || (obj == z.o_apply)
+ || (obj == z.o_call_cc)
+ || (obj == z.o_call_prompt)
+ || (obj == z.o_kernel_eval))
+ ? z.o_true
+ : z.o_false);
+}
+
+static zuo_t *zuo_hash_p(zuo_t *obj) {+ return (obj->tag == zuo_trie_node_tag) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_list_p(zuo_t *obj) {+ while (obj->tag == zuo_pair_tag)
+ obj = ((zuo_pair_t *)obj)->cdr;
+ return (obj == z.o_null) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_car(zuo_t *obj) {+ if (obj->tag != zuo_pair_tag)
+ zuo_fail_arg("car", "pair", obj);+ return ((zuo_pair_t *)obj)->car;
+}
+
+static zuo_t *zuo_cdr(zuo_t *obj) {+ if (obj->tag != zuo_pair_tag)
+ zuo_fail_arg("cdr", "pair", obj);+ return ((zuo_pair_t *)obj)->cdr;
+}
+
+static zuo_t *zuo_list_ref(zuo_t *lst, zuo_t *index) {+ const char *who = "list-ref";
+ zuo_int_t i;
+ if (index->tag == zuo_integer_tag)
+ i = ZUO_INT_I(index);
+ else
+ i = -1;
+ if (i < 0)
+ zuo_fail_arg(who, "not a nonnegative integer", index);
+ while ((i > 0) && (lst->tag == zuo_pair_tag)) {+ lst = _zuo_cdr(lst);
+ i -= 1;
+ }
+ if (lst->tag != zuo_pair_tag)
+ zuo_fail1w(who, "encountered a non-pair", lst);
+ return _zuo_car(lst);
+}
+
+static zuo_t *zuo_list_set(zuo_t *lst, zuo_t *index, zuo_t *val) {+ const char *who = "list-set";
+ zuo_t *first = z.o_null, *last = z.o_null, *pr;
+ zuo_int_t i;
+ if (index->tag == zuo_integer_tag)
+ i = ZUO_INT_I(index);
+ else
+ i = -1;
+ if (i < 0)
+ zuo_fail_arg(who, "not a nonnegative integer", index);
+ if ((i == 0) && (lst->tag == zuo_pair_tag)) {+ return zuo_cons(val, _zuo_cdr(lst));
+ } else {+ while ((i > 0) && (lst->tag == zuo_pair_tag)) {+ pr = zuo_cons(_zuo_car(lst), z.o_null);
+ if (first == z.o_null)
+ first = pr;
+ else
+ ((zuo_pair_t *)last)->cdr = pr;
+ last = pr;
+ lst = _zuo_cdr(lst);
+ i -= 1;
+ }
+ if (lst->tag != zuo_pair_tag)
+ zuo_fail1w(who, "encountered a non-pair", lst);
+
+ ((zuo_pair_t *)last)->cdr = zuo_cons(val, _zuo_cdr(lst));
+
+ return first;
+ }
+}
+
+static zuo_int_t zuo_length_int(zuo_t *in_l) {+ zuo_t *l = in_l;
+ zuo_int_t len = 0;
+
+ while (l->tag == zuo_pair_tag) {+ l = ((zuo_pair_t *)l)->cdr;
+ len++;
+ }
+
+ if (l != z.o_null)
+ zuo_fail_arg("length", "list", in_l);+
+ return len;
+}
+
+static zuo_t *zuo_length(zuo_t *in_l) {+ return zuo_integer(zuo_length_int(in_l));
+}
+
+static zuo_t *zuo_reverse(zuo_t *in_l) {+ zuo_t *l = in_l, *r = z.o_null;
+ while (l->tag == zuo_pair_tag) {+ r = zuo_cons(_zuo_car(l), r);
+ l = _zuo_cdr(l);
+ }
+
+ if (l != z.o_null)
+ zuo_fail_arg("reverse", "list", in_l);+
+ return r;
+}
+
+static zuo_t *zuo_build_string(zuo_t *chars) {+ zuo_int_t len = 0;
+ zuo_t *l, *str;
+ char *s;
+ for (l = chars; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *a = _zuo_car(l);
+ if ((a->tag != zuo_integer_tag)
+ || (ZUO_INT_I(a) < 0)
+ || (ZUO_INT_I(a) > 255))
+ zuo_fail_arg("string", "integer in [0, 255]", a);+ len++;
+ }
+ s = malloc(len);
+ len = 0;
+ for (l = chars; l != z.o_null; l = _zuo_cdr(l))
+ s[len++] = ZUO_INT_I(_zuo_car(l));
+ str = zuo_sized_string(s, len);
+ free(s);
+ return str;
+}
+
+static zuo_t *zuo_string_length(zuo_t *obj) {+ check_string("string-length", obj);+ return zuo_integer(ZUO_STRING_LEN(obj));
+}
+
+static zuo_int_t check_string_ref_index(const char *who, zuo_t *obj, zuo_t *i, int width) {+ zuo_int_t idx;
+ check_string(who, obj);
+ check_integer(who, i);
+ idx = ZUO_INT_I(i);
+ if ((idx < 0) || ((idx + width) > ZUO_STRING_LEN(obj)))
+ zuo_fail1w(who, "index out of bounds for string", i);
+ return idx;
+}
+
+static zuo_t *zuo_string_ref(zuo_t *obj, zuo_t *i) {+ zuo_int_t idx = check_string_ref_index("string-ref", obj, i, 1);+ return zuo_integer(((zuo_string_t *)obj)->s[idx]);
+}
+
+static zuo_t *zuo_string_u32_ref(zuo_t *obj, zuo_t *i) {+ zuo_int_t idx = check_string_ref_index("string-u32-ref", obj, i, 4);+ zuo_uint32_t v;
+ memcpy(&v, (((zuo_string_t *)obj)->s + idx), sizeof(zuo_uint32_t));
+ return zuo_integer(v);
+}
+
+static zuo_t *zuo_substring(zuo_t *obj, zuo_t *start_i, zuo_t *end_i) {+ const char *who = "substring";
+ zuo_int_t s_idx, e_idx, len;
+ check_string(who, obj);
+ len = ZUO_STRING_LEN(obj);
+ check_integer(who, start_i);
+ s_idx = ZUO_INT_I(start_i);
+ if (end_i == z.o_undefined)
+ e_idx = len;
+ else {+ check_integer(who, end_i);
+ e_idx = ZUO_INT_I(end_i);
+ }
+ if ((s_idx < 0) || (s_idx > len))
+ zuo_fail1w(who, "starting index out of bounds for string", start_i);
+ if ((e_idx < 0) || (e_idx > len))
+ zuo_fail1w(who, "ending index out of bounds for string", end_i);
+ if (e_idx < s_idx)
+ zuo_fail1w(who, "ending index less than starting index", end_i);
+ return zuo_sized_string((const char *)&((zuo_string_t *)obj)->s[s_idx], e_idx - s_idx);
+}
+
+static zuo_t *zuo_string_to_symbol(zuo_t *obj) {+ check_string("string->symbol", obj);+ return zuo_symbol_from_string(ZUO_STRING_PTR(obj), obj);
+}
+
+static zuo_t *zuo_string_to_uninterned_symbol(zuo_t *obj) {+ check_string("string->uninterned-symbol", obj);+ return zuo_make_symbol_from_string(obj);
+}
+
+static zuo_t *zuo_symbol_to_string(zuo_t *obj) {+ check_symbol("symbol->string", obj);+ return ((zuo_symbol_t *)obj)->str;
+}
+
+static zuo_t *zuo_hash(zuo_t *args) {+ zuo_t *l, *ht;
+
+ for (l = args; l->tag == zuo_pair_tag; l = _zuo_cdr(_zuo_cdr(l))) {+ if ((_zuo_car(l)->tag != zuo_symbol_tag)
+ || (_zuo_cdr(l)->tag != zuo_pair_tag))
+ break;
+ }
+ if (l != z.o_null)
+ zuo_fail1w("hash", "arguments not symbol keys interleaved with values", args);+
+ ht = z.o_empty_hash;
+ for (l = args; l->tag == zuo_pair_tag; l = _zuo_cdr(_zuo_cdr(l)))
+ ht = zuo_trie_extend(ht, _zuo_car(l), _zuo_car(_zuo_cdr(l)));
+
+ return ht;
+}
+
+static zuo_t *zuo_hash_count(zuo_t *ht) {+ check_hash("hash-count", ht);+ return zuo_integer(((zuo_trie_node_t *)ht)->count);
+}
+
+static zuo_t *zuo_hash_ref(zuo_t *ht, zuo_t *sym, zuo_t *defval) {+ zuo_t *v;
+ const char *who = "hash-ref";
+ check_hash(who, ht);
+ check_symbol(who, sym);
+ v = zuo_trie_lookup(ht, sym);
+ if (v == z.o_undefined) {+ if (defval == z.o_undefined) zuo_fail1w(who, "key is not present", sym);
+ v = defval;
+ }
+ return v;
+}
+
+static zuo_t *zuo_hash_set(zuo_t *ht, zuo_t *sym, zuo_t *val) {+ const char *who = "hash-set";
+ check_hash(who, ht);
+ check_symbol(who, sym);
+ return zuo_trie_extend(ht, sym, val);
+}
+
+static zuo_t *zuo_hash_remove(zuo_t *ht, zuo_t *sym) {+ const char *who = "hash-remove";
+ check_hash(who, ht);
+ check_symbol(who, sym);
+ return zuo_trie_remove(ht, sym);
+}
+
+static zuo_t *zuo_hash_keys(zuo_t *ht) {+ check_hash("hash-keys", ht);+ return zuo_trie_keys(ht, z.o_null);
+}
+
+static zuo_t *zuo_hash_keys_subset_p(zuo_t *ht, zuo_t *ht2) {+ const char *who = "hash-keys-subset?";
+ check_hash(who, ht);
+ check_hash(who, ht2);
+ return zuo_trie_keys_subset_p(ht, ht2) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_opaque_ref(zuo_t *tag, zuo_t *obj, zuo_t *defval) {+ if (obj->tag == zuo_opaque_tag) {+ if (((zuo_opaque_t *)obj)->tag == tag)
+ return ((zuo_opaque_t *)obj)->val;
+ }
+ return defval;
+}
+
+static void check_ints(zuo_t *n, zuo_t *m, const char *who) {+ check_integer(who, n);
+ check_integer(who, m);
+}
+
+static zuo_t *zuo_add(zuo_t *ns) {+ zuo_uint_t i = 0;
+ while (ns != z.o_null) {+ zuo_t *n = _zuo_car(ns);
+ check_integer("+", n);+ i += ZUO_UINT_I(n);
+ ns = _zuo_cdr(ns);
+ }
+ return zuo_integer((zuo_int_t)i);
+}
+
+static zuo_t *zuo_subtract(zuo_t *ns) {+ zuo_uint_t i;
+ zuo_t *n = _zuo_car(ns);
+ check_integer("-", n);+ i = ZUO_UINT_I(n);
+ ns = _zuo_cdr(ns);
+ if (ns == z.o_null) {+ i = -i;
+ } else {+ while (ns != z.o_null) {+ n = _zuo_car(ns);
+ check_integer("-", n);+ i -= ZUO_UINT_I(n);
+ ns = _zuo_cdr(ns);
+ }
+ }
+ return zuo_integer((zuo_int_t)i);
+}
+
+static zuo_t *zuo_multiply(zuo_t *ns) {+ zuo_uint_t i = 1;
+ while (ns != z.o_null) {+ zuo_t *n = _zuo_car(ns);
+ check_integer("*", n);+ i *= ZUO_UINT_I(n);
+ ns = _zuo_cdr(ns);
+ }
+ return zuo_integer((zuo_int_t)i);
+}
+
+static zuo_t *zuo_quotient(zuo_t *n, zuo_t *m) {+ const char *who = "quotient";
+ zuo_int_t m_i;
+ check_ints(n, m, who);
+ m_i = ZUO_UINT_I(m);
+ if (m_i == 0) zuo_fail1w(who, "divide by zero", m);
+ if (m_i == -1) {+ /* avoid potential overflow a the minimum integer */
+ return zuo_integer((zuo_int_t)(0 - ZUO_UINT_I(n)));
+ }
+ return zuo_integer(ZUO_INT_I(n) / m_i);
+}
+
+static zuo_t *zuo_modulo(zuo_t *n, zuo_t *m) {+ const char *who = "modulo";
+ zuo_int_t m_i;
+ check_ints(n, m, who);
+ m_i = ZUO_UINT_I(m);
+ if (m_i == 0) zuo_fail1w(who, "divide by zero", m);
+ if (m_i == -1) {+ /* avoid potential overflow a the minimum integer */
+ return zuo_integer(0);
+ }
+ return zuo_integer(ZUO_INT_I(n) % m_i);
+}
+
+static zuo_t *zuo_not(zuo_t *obj) {+ return (obj == z.o_false) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_eql(zuo_t *n, zuo_t *m) {+ check_ints(n, m, "=");
+ return (ZUO_INT_I(n) == ZUO_INT_I(m)) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_lt(zuo_t *n, zuo_t *m) {+ check_ints(n, m, "<");
+ return (ZUO_INT_I(n) < ZUO_INT_I(m)) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_le(zuo_t *n, zuo_t *m) {+ check_ints(n, m, "<=");
+ return (ZUO_INT_I(n) <= ZUO_INT_I(m)) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_ge(zuo_t *n, zuo_t *m) {+ check_ints(n, m, ">=");
+ return (ZUO_INT_I(n) >= ZUO_INT_I(m)) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_gt(zuo_t *n, zuo_t *m) {+ check_ints(n, m, ">");
+ return (ZUO_INT_I(n) > ZUO_INT_I(m)) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_bitwise_and(zuo_t *n, zuo_t *m) {+ check_ints(n, m, "bitwise-and");
+ return zuo_integer(ZUO_UINT_I(n) & ZUO_UINT_I(m));
+}
+
+static zuo_t *zuo_bitwise_ior(zuo_t *n, zuo_t *m) {+ check_ints(n, m, "bitwise-ior");
+ return zuo_integer(ZUO_UINT_I(n) | ZUO_UINT_I(m));
+}
+
+static zuo_t *zuo_bitwise_xor(zuo_t *n, zuo_t *m) {+ check_ints(n, m, "bitwise-xor");
+ return zuo_integer(ZUO_UINT_I(n) ^ ZUO_UINT_I(m));
+}
+
+static zuo_t *zuo_bitwise_not(zuo_t *n) {+ check_integer("bitwise-not", n);+ return zuo_integer(~ZUO_UINT_I(n));
+}
+
+static zuo_t *zuo_eq(zuo_t *n, zuo_t *m) {+ return (n == m) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_string_eql(zuo_t *n, zuo_t *m) {+ const char *who = "string=?";
+ check_string(who, n);
+ check_string(who, m);
+ return (((ZUO_STRING_LEN(n) == ZUO_STRING_LEN(m))
+ && !memcmp(ZUO_STRING_PTR(n), ZUO_STRING_PTR(m), ZUO_STRING_LEN(n)))
+ ? z.o_true
+ : z.o_false);
+}
+
+static zuo_t *zuo_string_ci_eql(zuo_t *n, zuo_t *m) {+ const char *who = "string-ci=?";
+ zuo_int_t i;
+ check_string(who, n);
+ check_string(who, m);
+ if (ZUO_STRING_LEN(n) != ZUO_STRING_LEN(m)) return z.o_false;
+ for (i = 0; i < ZUO_STRING_LEN(n); i++)
+ if (tolower(((zuo_string_t *)n)->s[i]) != tolower(((zuo_string_t *)m)->s[i]))
+ return z.o_false;
+ return z.o_true;
+}
+
+static zuo_t *zuo_string_split(zuo_t *str, zuo_t *find_str) {+ const char *who = "string-split";
+ zuo_t *l = z.o_null;
+ zuo_int_t start, i, find_len;
+ const char *fs;
+ int keep_empty;
+
+ check_string(who, str);
+ if (find_str != z.o_undefined) {+ if (find_str->tag == zuo_string_tag)
+ find_len = ZUO_STRING_LEN(find_str);
+ else
+ find_len = 0;
+ if (find_len < 1)
+ zuo_fail_arg(who, "nonempty string", find_str);
+ fs = ZUO_STRING_PTR(find_str);
+ keep_empty = 1;
+ } else {+ fs = " ";
+ find_len = 1;
+ keep_empty = 0;
+ }
+
+ start = 0;
+ for (i = 0; i <= ZUO_STRING_LEN(str) - find_len; i++) {+ if (!memcmp(ZUO_STRING_PTR(str) + i, fs, find_len)) {+ if ((start < i) || keep_empty)
+ l = zuo_cons(zuo_sized_string(ZUO_STRING_PTR(str) + start, i - start), l);
+ i += (find_len-1);
+ start = i+1;
+ }
+ }
+
+ if ((start < ZUO_STRING_LEN(str)) || keep_empty)
+ l = zuo_cons(zuo_sized_string(ZUO_STRING_PTR(str) + start, ZUO_STRING_LEN(str) - start), l);
+
+ return zuo_reverse(l);
+}
+
+static zuo_t *zuo_tilde_v(zuo_t *objs) {+ return zuo_to_string(objs, zuo_print_mode);
+}
+
+static zuo_t *zuo_tilde_s(zuo_t *objs) {+ return zuo_to_string(objs, zuo_write_mode);
+}
+
+static zuo_t *zuo_tilde_a(zuo_t *objs) {+ return zuo_to_string(objs, zuo_display_mode);
+}
+
+static void zuo_falert(FILE* f, zuo_t *objs) {+ if ((objs->tag == zuo_pair_tag)
+ && (_zuo_car(objs)->tag == zuo_string_tag)) {+ zuo_fdisplay(f, _zuo_car(objs));
+ objs = _zuo_cdr(objs);
+ if (objs != z.o_null) fprintf(f, ": ");
+ }
+ zuo_fdisplay(f, zuo_tilde_v(objs));
+}
+
+static zuo_t *zuo_error(zuo_t *objs) {+ zuo_error_color();
+ zuo_falert(stderr, objs);
+ zuo_fail("");+ return z.o_undefined;
+}
+
+static zuo_t *zuo_alert(zuo_t *objs) {+ zuo_alert_color();
+ zuo_falert(stdout, objs);
+ fprintf(stdout, "\n");
+ zuo_normal_color(1);
+ return z.o_void;
+}
+
+static zuo_t *zuo_arg_error(zuo_t *name, zuo_t *what, zuo_t *arg) {+ const char *who = "arg-error";
+ check_symbol(who, name);
+ check_string(who, what);
+ zuo_fail_arg(ZUO_STRING_PTR(((zuo_symbol_t *)name)->str), ZUO_STRING_PTR(what), arg);
+ return z.o_undefined;
+}
+
+
+static zuo_t *zuo_arity_error(zuo_t *name, zuo_t *args) {+ const char *who = "arity-error";
+ zuo_t *msg;
+
+ if ((name != z.o_false) && (name->tag != zuo_string_tag))
+ zuo_fail_arg(who, "string or #f", name);
+ if (zuo_list_p(args) != z.o_true)
+ zuo_fail_arg(who, "list", args);
+
+ msg = zuo_tilde_a(zuo_cons((name == z.o_false) ? zuo_string("[procedure]") : name,+ zuo_cons(zuo_string(": wrong number of arguments: "),+ zuo_cons((args == z.o_null)
+ ? zuo_string("[no arguments]")+ : zuo_tilde_v(args),
+ z.o_null))));
+
+ zuo_fail(ZUO_STRING_PTR(msg));
+ return z.o_undefined;
+}
+
+static void zuo_fail_arity(zuo_t *rator, zuo_t *args) {+ zuo_t *name;
+
+ if (rator->tag == zuo_primitive_tag)
+ name = ((zuo_symbol_t *)((zuo_primitive_t *)rator)->name)->str;
+ else if (rator == z.o_apply)
+ name = zuo_string("apply");+ else if (rator == z.o_call_cc)
+ name = zuo_string("call/cc");+ else if (rator == z.o_call_prompt)
+ name = zuo_string("call/prompt");+ else if (rator == z.o_kernel_eval)
+ name = zuo_string("kernel-eval");+ else if (rator->tag == zuo_closure_tag) {+ zuo_t *body = _zuo_cdr(_zuo_cdr(((zuo_closure_t *)rator)->lambda));
+ if (_zuo_cdr(body) != z.o_null)
+ name = _zuo_car(body);
+ else
+ name = z.o_false;
+ } else
+ name = z.o_false;
+
+ zuo_arity_error(name, args);
+}
+
+static zuo_t *zuo_exit(zuo_t *val) {+ if (val == z.o_undefined)
+ zuo_exit_int(0);
+ else if ((val->tag != zuo_integer_tag)
+ || (ZUO_INT_I(val) < 0)
+ || (ZUO_INT_I(val) > 255))
+ zuo_fail_arg("exit", "integer in [0, 255]", val);+ else
+ zuo_exit_int(ZUO_INT_I(val));
+ return z.o_undefined;
+}
+
+static zuo_t *zuo_list(zuo_t *objs) {+ return objs;
+}
+
+static zuo_t *zuo_append(zuo_t *objs) {+ zuo_t *first = z.o_null, *last = NULL, *p;
+ zuo_t *l = objs, *a;
+ while ((l->tag == zuo_pair_tag)
+ && (_zuo_cdr(l)->tag == zuo_pair_tag)) {+ a = _zuo_car(l);
+ while (a->tag == zuo_pair_tag) {+ p = zuo_cons(_zuo_car(a), z.o_null);
+ if (last)
+ ((zuo_pair_t *)last)->cdr = p;
+ else
+ first = p;
+ last = p;
+ a = _zuo_cdr(a);
+ }
+ if (a != z.o_null)
+ zuo_fail_arg("append", "list", _zuo_car(l));+ l = _zuo_cdr(l);
+ }
+
+ if (l->tag == zuo_pair_tag) {+ if (last)
+ ((zuo_pair_t *)last)->cdr = _zuo_car(l);
+ else
+ first = _zuo_car(l);
+ }
+
+ return first;
+}
+
+static zuo_t *zuo_prompt_avail_p(zuo_t *tag) {+ check_symbol("continuation-prompt-available?", tag);+ if (Z.o_interp_meta_k == z.o_null)
+ return z.o_false;
+ return ((tag == _zuo_cdr(_zuo_car(Z.o_interp_meta_k))) ? z.o_true : z.o_false);
+}
+
+static zuo_t *zuo_variable_p(zuo_t *var) {+ return (var->tag == zuo_variable_tag) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_make_variable(zuo_t *name) {+ check_symbol("variable", name);+ return zuo_variable(name);
+}
+
+static zuo_t *zuo_variable_ref(zuo_t *var) {+ zuo_t *val;
+ if (var->tag != zuo_variable_tag)
+ zuo_fail_arg("variable-ref", "variable", var);+ val = ((zuo_variable_t *)var)->val;
+ if (val == z.o_undefined) {+ zuo_error_color();
+ fprintf(stderr, "undefined: ");
+ zuo_fwrite(stderr, ((zuo_variable_t *)var)->name);
+ zuo_fail("");+ }
+ return val;
+}
+
+static zuo_t *zuo_variable_set(zuo_t *var, zuo_t *val) {+ if (var->tag != zuo_variable_tag)
+ zuo_fail_arg("variable-set!", "variable", var);+ if (((zuo_variable_t *)var)->val != z.o_undefined)
+ zuo_fail1w("variable-set!", "variable already has a value", var);+ ((zuo_variable_t *)var)->val = val;
+ return z.o_void;
+}
+
+static zuo_t *zuo_make_void(zuo_t *args) {+ return z.o_void;
+}
+
+static zuo_t *zuo_kernel_env() {+ return z.o_top_env;
+}
+
+/*======================================================================*/
+/* interpreter */
+/*======================================================================*/
+
+static void bad_form(zuo_t *e) {+ zuo_error_color();
+ fprintf(stderr, "bad kernel syntax: ");
+ zuo_fwrite(stderr, e);
+ zuo_fail("");+}
+
+/* Not strictly necessary, but a handy sanity check on input expressions: */
+static void check_syntax(zuo_t *e) {+ zuo_t *es = zuo_cons(e, z.o_null);
+
+ while (es != z.o_null) {+ e = _zuo_car(es);
+ es = _zuo_cdr(es);
+ if (e->tag == zuo_pair_tag) {+ zuo_t *rator = _zuo_car(e);
+
+ if (rator == z.o_quote_symbol) {+ zuo_t *d = _zuo_cdr(e);
+ if ((d->tag != zuo_pair_tag) || (_zuo_cdr(d) != z.o_null))
+ bad_form(e);
+ } else if (rator == z.o_if_symbol) {+ zuo_t *d = _zuo_cdr(e), *dd, *ddd;
+ if (d->tag != zuo_pair_tag)
+ bad_form(e);
+ dd = _zuo_cdr(d);
+ if (dd->tag != zuo_pair_tag)
+ bad_form(e);
+ ddd = _zuo_cdr(dd);
+ if ((ddd->tag != zuo_pair_tag) || (_zuo_cdr(ddd) != z.o_null))
+ bad_form(e);
+ es = zuo_cons(_zuo_car(ddd), es);
+ es = zuo_cons(_zuo_car(dd), es);
+ es = zuo_cons(_zuo_car(d), es);
+ } else if (rator == z.o_lambda_symbol) {+ zuo_t *d = _zuo_cdr(e), *dd, *ad;
+ if (d->tag != zuo_pair_tag)
+ bad_form(e);
+ ad = _zuo_car(d); /* formals */
+ dd = _zuo_cdr(d);
+ if (dd->tag != zuo_pair_tag)
+ bad_form(e);
+ if (_zuo_cdr(dd) != z.o_null) {+ if (_zuo_car(dd)->tag == zuo_string_tag) {+ /* skip over name string */
+ dd = _zuo_cdr(dd);
+ if (dd->tag != zuo_pair_tag)
+ bad_form(e);
+ } else
+ bad_form(e);
+ }
+ if (_zuo_cdr(dd) != z.o_null)
+ bad_form(e);
+ while (ad->tag == zuo_pair_tag) {+ if (_zuo_car(ad)->tag != zuo_symbol_tag)
+ bad_form(e);
+ ad = _zuo_cdr(ad);
+ }
+ if ((ad != z.o_null)
+ && (ad->tag != zuo_symbol_tag))
+ bad_form(e);
+ es = zuo_cons(_zuo_car(dd), es);
+ } else if (rator == z.o_let_symbol) {+ zuo_t *d = _zuo_cdr(e), *dd, *ad, *aad, *daad, *adaad;
+ if (d->tag != zuo_pair_tag)
+ bad_form(e);
+ ad = _zuo_car(d); /* `((id rhs))` */
+ dd = _zuo_cdr(d);
+ if ((dd->tag != zuo_pair_tag) || (_zuo_cdr(dd) != z.o_null))
+ bad_form(e);
+ if ((ad->tag != zuo_pair_tag) || (_zuo_cdr(ad) != z.o_null))
+ bad_form(e);
+ aad = _zuo_car(ad); /* `(id rhs)` */
+ if ((aad->tag != zuo_pair_tag) || (_zuo_car(aad)->tag != zuo_symbol_tag))
+ bad_form(e);
+ daad = _zuo_cdr(aad); /* `(rhs)` */
+ if ((daad->tag != zuo_pair_tag) || (_zuo_cdr(daad) != z.o_null))
+ bad_form(e);
+ adaad = _zuo_car(daad); /* `rhs` */
+ es = zuo_cons(adaad, es);
+ es = zuo_cons(_zuo_car(dd), es);
+ } else if (rator == z.o_begin_symbol) {+ zuo_t *l = _zuo_cdr(e);
+ if (l->tag != zuo_pair_tag)
+ bad_form(e);
+ while (l->tag == zuo_pair_tag) {+ es = zuo_cons(_zuo_car(l), es);
+ l = _zuo_cdr(l);
+ }
+ if (l != z.o_null)
+ bad_form(e);
+ } else {+ zuo_t *l = e;
+ while (l->tag == zuo_pair_tag) {+ es = zuo_cons(_zuo_car(l), es);
+ l = _zuo_cdr(l);
+ }
+ if (l != z.o_null)
+ bad_form(e);
+ }
+ }
+ }
+}
+
+static zuo_t *env_extend(zuo_t *env, zuo_t *sym, zuo_t *val) {+ ASSERT((env->tag == zuo_trie_node_tag) || (env->tag == zuo_pair_tag));
+ return zuo_cons(zuo_cons(sym, val), env);
+}
+
+static zuo_t *env_lookup(zuo_t *env, zuo_t *sym) {+ while (env->tag == zuo_pair_tag) {+ zuo_t *a = _zuo_car(env);
+ if (_zuo_car(a) == sym)
+ return _zuo_cdr(a);
+ env = _zuo_cdr(env);
+ }
+ return zuo_trie_lookup(env, sym);
+}
+
+static void interp_step() {+ zuo_t *e = Z.o_interp_e;
+
+ if (zuo_probe_each) {+ zuo_probe_counter++;
+ if ((zuo_probe_counter % zuo_probe_each) == 0) {+ fprintf(stderr, "probe %d:\n", zuo_probe_counter);
+ zuo_stack_trace();
+ }
+ }
+
+ if (e->tag == zuo_symbol_tag) {+ zuo_t *val = env_lookup(Z.o_interp_env, e);
+ if (val == z.o_undefined)
+ zuo_fail1("undefined", e);+ Z.o_interp_v = val;
+ } else if (e->tag == zuo_pair_tag) {+ zuo_t *rator = _zuo_car(e);
+
+ if (rator == z.o_quote_symbol) {+ Z.o_interp_v = _zuo_car(_zuo_cdr(e));
+ } else if (rator == z.o_if_symbol) {+ zuo_t *d = _zuo_cdr(e);
+ Z.o_interp_e = _zuo_car(d);
+ Z.o_interp_k = zuo_cont(zuo_if_cont,
+ _zuo_cdr(d), Z.o_interp_env,
+ Z.o_interp_in_proc,
+ Z.o_interp_k);
+ } else if (rator == z.o_lambda_symbol) {+ Z.o_interp_v = zuo_closure(Z.o_interp_e, Z.o_interp_env);
+ } else if (rator == z.o_let_symbol) {+ zuo_t *d = _zuo_cdr(e);
+ Z.o_interp_e = _zuo_car(_zuo_cdr(_zuo_car(_zuo_car(d))));
+ Z.o_interp_k = zuo_cont(zuo_let_cont,
+ d, Z.o_interp_env,
+ Z.o_interp_in_proc,
+ Z.o_interp_k);
+ } else if (rator == z.o_begin_symbol) {+ zuo_t *d = _zuo_cdr(e);
+ zuo_t *dd = _zuo_cdr(d);
+ Z.o_interp_e = _zuo_car(d);
+ if (dd != z.o_null)
+ Z.o_interp_k = zuo_cont(zuo_begin_cont,
+ dd, Z.o_interp_env,
+ Z.o_interp_in_proc,
+ Z.o_interp_k);
+ } else {+ Z.o_interp_e = rator;
+ Z.o_interp_k = zuo_cont(zuo_apply_cont,
+ zuo_cons(z.o_null, _zuo_cdr(e)), Z.o_interp_env,
+ Z.o_interp_in_proc,
+ Z.o_interp_k);
+ }
+ } else
+ Z.o_interp_v = e;
+}
+
+static void continue_step() {+ zuo_cont_t *k = (zuo_cont_t *)Z.o_interp_k;
+ Z.o_interp_k = k->next;
+ Z.o_interp_in_proc = k->in_proc;
+ switch (k->tag) {+ case zuo_apply_cont:
+ {+ zuo_t *rev_vals = _zuo_car(k->data);
+ zuo_t *exps = _zuo_cdr(k->data);
+ rev_vals = zuo_cons(Z.o_interp_v, rev_vals);
+ if (exps == z.o_null) {+ zuo_t *rator;
+ zuo_t *args = z.o_null;
+ int count = 0;
+ while (_zuo_cdr(rev_vals) != z.o_null) {+ args = zuo_cons(_zuo_car(rev_vals), args);
+ count++;
+ rev_vals = _zuo_cdr(rev_vals);
+ }
+ rator = _zuo_car(rev_vals);
+ while (1) { /* loop in case of `apply` */+ if (rator->tag == zuo_closure_tag) {+ zuo_t *all_args = args;
+ zuo_closure_t *f = (zuo_closure_t *)rator;
+ zuo_t *env = f->env;
+ zuo_t *formals = _zuo_car(_zuo_cdr(f->lambda));
+ zuo_t *body = _zuo_cdr(_zuo_cdr(f->lambda));
+ zuo_t *body_d = _zuo_cdr(body);
+ if (body_d != z.o_null) {+ zuo_t *a = _zuo_car(body);
+ if (a->tag == zuo_string_tag) {+ Z.o_interp_in_proc = a;
+ body = body_d; /* skip over function name */
+ body_d = _zuo_cdr(body);
+ } else
+ Z.o_interp_in_proc = z.o_false;
+ } else
+ Z.o_interp_in_proc = z.o_false;
+ while (formals->tag == zuo_pair_tag) {+ if (args == z.o_null)
+ break;
+ env = env_extend(env, _zuo_car(formals), _zuo_car(args));
+ args = _zuo_cdr(args);
+ formals = _zuo_cdr(formals);
+ }
+ if (formals->tag == zuo_symbol_tag)
+ env = env_extend(env, formals, args);
+ else if (formals != z.o_null || args != z.o_null)
+ zuo_fail_arity(rator, all_args);
+
+ Z.o_interp_e = _zuo_car(body);
+ Z.o_interp_env = env;
+ Z.o_interp_v = z.o_undefined;
+ break;
+ } else if (rator->tag == zuo_primitive_tag) {+ zuo_primitive_t *f = (zuo_primitive_t *)rator;
+ if (f->arity_mask & ((zuo_uint_t)1 << ((count >= ZUO_MAX_PRIM_ARITY) ? ZUO_MAX_PRIM_ARITY : count)))
+ Z.o_interp_v = f->dispatcher(f->proc, args);
+ else
+ zuo_fail_arity(rator, args);
+ break;
+ } else if (rator->tag == zuo_cont_tag) {+ if (count == 1) {+ Z.o_interp_k = rator;
+ Z.o_interp_v = _zuo_car(args);
+ } else
+ zuo_fail_arity(rator, args);
+ break;
+ } else if (rator == z.o_apply) {+ if (count != 2)
+ zuo_fail_arity(z.o_apply, args);
+ rator = _zuo_car(args);
+ args = _zuo_car(_zuo_cdr(args));
+ if (zuo_list_p(args) != z.o_true)
+ zuo_fail_arg("apply", "list", args);+ count = zuo_length_int(args);
+ /* no break => loop to apply again */
+ } else if (rator == z.o_call_cc) {+ if (count != 1)
+ zuo_fail_arity(z.o_call_cc, args);
+ rator = _zuo_car(args);
+ args = zuo_cons(Z.o_interp_k, z.o_null);
+ /* no break => loop to apply again */
+ } else if (rator == z.o_call_prompt) {+ zuo_t *tag;
+ if (count != 2)
+ zuo_fail_arity(z.o_call_prompt, args);
+ rator = _zuo_car(args);
+ tag = _zuo_car(_zuo_cdr(args));
+ if (tag->tag != zuo_symbol_tag)
+ zuo_fail1w("call/prompt", "not a symbol", tag);+ args = z.o_null;
+ Z.o_interp_meta_k = zuo_cons(zuo_cons(Z.o_interp_k, tag),
+ Z.o_interp_meta_k);
+ Z.o_interp_k = z.o_done_k;
+ /* no break => loop to apply again */
+ } else if (rator == z.o_kernel_eval) {+ if (count != 1)
+ zuo_fail_arity(z.o_kernel_eval, args);
+
+ Z.o_interp_e = _zuo_car(args);
+ check_syntax(Z.o_interp_e);
+ Z.o_interp_meta_k = zuo_cons(zuo_cons(Z.o_interp_k, z.o_undefined),
+ Z.o_interp_meta_k);
+
+ Z.o_interp_v = z.o_undefined;
+ Z.o_interp_env = z.o_top_env;
+ Z.o_interp_k = z.o_done_k;
+ break;
+ } else
+ zuo_fail1("not a procedure for application", rator);+ }
+ } else {+ Z.o_interp_e = _zuo_car(exps);
+ Z.o_interp_env = k->env;
+ Z.o_interp_k = zuo_cont(zuo_apply_cont,
+ zuo_cons(rev_vals, _zuo_cdr(exps)), Z.o_interp_env,
+ Z.o_interp_in_proc,
+ Z.o_interp_k);
+ Z.o_interp_v = z.o_undefined;
+ }
+ }
+ break;
+ case zuo_let_cont:
+ Z.o_interp_e = _zuo_car(_zuo_cdr(k->data));
+ Z.o_interp_env = env_extend(k->env, _zuo_car(_zuo_car(_zuo_car(k->data))), Z.o_interp_v);
+ Z.o_interp_v = z.o_undefined;
+ break;
+ case zuo_begin_cont:
+ {+ zuo_t *d = _zuo_cdr(k->data);
+ Z.o_interp_e = _zuo_car(k->data);
+ Z.o_interp_env = k->env;
+ if (d != z.o_null)
+ Z.o_interp_k = zuo_cont(zuo_begin_cont,
+ d, Z.o_interp_env,
+ Z.o_interp_in_proc,
+ Z.o_interp_k);
+ Z.o_interp_v = z.o_undefined;
+ }
+ break;
+ case zuo_if_cont:
+ {+ if (Z.o_interp_v == z.o_false)
+ Z.o_interp_e = _zuo_car(_zuo_cdr(k->data));
+ else
+ Z.o_interp_e = _zuo_car(k->data);
+ Z.o_interp_env = k->env;
+ Z.o_interp_v = z.o_undefined;
+ }
+ break;
+ case zuo_done_cont:
+ break;
+ }
+}
+
+zuo_t *zuo_kernel_eval(zuo_t *e) {+ check_syntax(e);
+
+ Z.o_interp_e = e;
+ Z.o_interp_v = z.o_undefined;
+ Z.o_interp_env = z.o_top_env;
+ Z.o_interp_k = z.o_done_k;
+ Z.o_interp_meta_k = z.o_null;
+
+ while (1) {+ zuo_check_collect();
+ if (Z.o_interp_v == z.o_undefined) {+ interp_step();
+ } else if (Z.o_interp_k == z.o_done_k) {+ if (Z.o_interp_meta_k == z.o_null) {+ zuo_t *v = Z.o_interp_v;
+ Z.o_interp_e = Z.o_interp_v = Z.o_interp_env = z.o_false;
+
+ return v;
+ } else {+ Z.o_interp_k = _zuo_car(_zuo_car(Z.o_interp_meta_k));
+ Z.o_interp_meta_k = zuo_cdr(Z.o_interp_meta_k);
+ }
+ } else {+ continue_step();
+ }
+ }
+}
+
+/*======================================================================*/
+/* environment variables */
+/*======================================================================*/
+
+#if defined(__APPLE__) && defined(__MACH__)
+# include <crt_externs.h>
+#elif defined(ZUO_UNIX)
+extern char **environ;
+#endif
+
+#ifdef ZUO_WINDOWS
+static wchar_t *zuo_to_wide(char *a) {+ wchar_t *wa;
+ int walen, alen = strlen(a);
+
+ walen = MultiByteToWideChar(CP_UTF8, 0, a, alen, NULL, 0);
+ wa = malloc((walen+1) * sizeof(wchar_t));
+ MultiByteToWideChar(CP_UTF8, 0, a, alen, wa, walen);
+ wa[walen] = 0;
+
+ return wa;
+}
+
+static char *zuo_from_wide(const wchar_t *wa) {+ char *a;
+ int alen, walen = wcslen(wa);
+
+ alen = WideCharToMultiByte(CP_UTF8, 0, wa, walen, NULL, 0, NULL, NULL);
+ a = malloc(alen+1);
+ alen = WideCharToMultiByte(CP_UTF8, 0, wa, walen, a, alen, NULL, NULL);
+ a[alen] = 0;
+
+ return a;
+}
+#endif
+
+static zuo_t *zuo_get_envvars()
+{+ zuo_t *first = z.o_null, *last = NULL, *pr;
+
+#ifdef ZUO_UNIX
+ {+ zuo_int_t i, j;
+ char **ea, *p;
+
+# if defined(__APPLE__) && defined(__MACH__)
+ ea = *_NSGetEnviron();
+# else
+ ea = environ;
+# endif
+
+ for (i = 0; ea[i]; i++) {+ p = ea[i];
+ for (j = 0; p[j] && p[j] != '='; j++) {+ }
+ pr = zuo_cons(zuo_cons(zuo_sized_string(p, j), zuo_string(p+j+1)),
+ z.o_null);
+ if (last == NULL) first = pr; else ZUO_CDR(last) = pr;
+ last = pr;
+ }
+ }
+#endif
+#ifdef ZUO_WINDOWS
+ {+ char *p;
+ wchar_t *e;
+ zuo_int_t i, start, j;
+
+ e = GetEnvironmentStringsW();
+ if (!e)
+ zuo_fail("failed to get environment variables");+
+ i = 0;
+ while (e[i]) {+ start = i;
+ while (e[i]) { i++; }+ p = zuo_from_wide(e + start);
+ for (j = 0; p[j] && p[j] != '='; j++) {+ }
+ p[j] = 0;
+ if (p[0] != 0) {+ pr = zuo_cons(zuo_cons(zuo_string(p), zuo_string(p+j+1)),
+ z.o_null);
+ if (last == NULL) first = pr; else ZUO_CDR(last) = pr;
+ last = pr;
+ }
+ free(p);
+ i++;
+ }
+
+ FreeEnvironmentStringsW(e);
+ }
+#endif
+ return first;
+}
+
+static void *zuo_envvars_block(const char *who, zuo_t *envvars)
+{+#ifdef ZUO_UNIX
+ char **r, *s;
+ intptr_t len = 0, slen, c, count = 0;
+ zuo_t *l;
+
+ for (l = envvars; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *a = _zuo_car(l);
+ len += ZUO_STRING_LEN(_zuo_car(a));
+ len += ZUO_STRING_LEN(_zuo_cdr(a));
+ len += 2;
+ count++;
+ }
+
+ r = (char **)malloc((count+1) * sizeof(char*) + len);
+ s = (char *)(r + (count+1));
+ c = 0;
+ for (l = envvars; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *a = _zuo_car(l);
+ r[c++] = s;
+ slen = ZUO_STRING_LEN(_zuo_car(a));
+ memcpy(s, ZUO_STRING_PTR(_zuo_car(a)), slen);
+ s[slen] = '=';
+ s = s + (slen + 1);
+ slen = ZUO_STRING_LEN(_zuo_cdr(a));
+ memcpy(s, ZUO_STRING_PTR(_zuo_cdr(a)), slen);
+ s[slen] = 0;
+ s = s + (slen + 1);
+ }
+ r[c] = NULL;
+
+ return r;
+#endif
+#ifdef ZUO_WINDOWS
+ zuo_t *l;
+ zuo_int_t i;
+ zuo_int_t r_size = 256, r_len = 0, namelen, vallen, slen;
+ wchar_t *r = malloc(r_size * sizeof(wchar_t)), *name, *val;
+
+ for (l = envvars; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *a = _zuo_car(l);
+ name = zuo_to_wide(ZUO_STRING_PTR(_zuo_car(a)));
+ val = zuo_to_wide(ZUO_STRING_PTR(_zuo_cdr(a)));
+ namelen = wcslen(name);
+ vallen = wcslen(val);
+ slen = namelen + vallen + 2;
+
+ if (r_len + slen >= r_size) {+ zuo_int_t new_size = 2 * (r_size + r_len);
+ wchar_t *new_r = malloc(new_size * sizeof(wchar_t));
+ memcpy(new_r, r, r_size * sizeof(wchar_t));
+ free(r);
+ r = new_r;
+ r_size = new_size;
+ }
+
+ memcpy(r + r_len, name, namelen * sizeof(wchar_t));
+ r_len += namelen;
+ r[r_len++] = '=';
+ memcpy(r + r_len, val, vallen * sizeof(wchar_t));
+ r_len += vallen;
+ r[r_len++] = 0;
+
+ free(name);
+ free(val);
+ }
+ r[r_len] = 0;
+
+ return r;
+#endif
+}
+
+
+/*======================================================================*/
+/* paths */
+/*======================================================================*/
+
+#ifdef ZUO_UNIX
+# define ZUO_IS_PATH_SEP(c) ((c) == '/')
+# define ZUO_PATH_SEP '/'
+#endif
+#ifdef ZUO_WINDOWS
+# define ZUO_IS_PATH_SEP(c) (((c) == '/') || ((c) == '\\'))
+# define ZUO_PATH_SEP '\\'
+#endif
+
+static int zuo_is_path_string(zuo_t *obj) {+ zuo_int_t i;
+
+ if ((obj->tag != zuo_string_tag)
+ || ZUO_STRING_LEN(obj) == 0)
+ return 0;
+
+ for (i = ZUO_STRING_LEN(obj); i--; ) {+ if (((zuo_string_t *)obj)->s[i] == 0)
+ return 0;
+ }
+
+ return 1;
+}
+
+static zuo_t *zuo_path_string_p(zuo_t *obj) {+ return zuo_is_path_string(obj) ? z.o_true : z.o_false;
+}
+
+static int zuo_is_module_path(zuo_t *obj, int *_saw_slash) {+ if (obj->tag == zuo_symbol_tag) {+ zuo_string_t *str = (zuo_string_t *)((zuo_symbol_t *)obj)->str;
+ if (str->len == 0)
+ str = NULL;
+ else {+ zuo_int_t i, saw_slash = 0;
+ for (i = 0; i < str->len; i++) {+ if (str->s[i] == '/') {+ if ((i == 0) || (i == str->len-1) || (saw_slash == i))
+ return 0;
+ saw_slash = i+1;
+ }
+ if (!zuo_is_symbol_module_char(str->s[i]))
+ return 0;
+ }
+ *_saw_slash = (saw_slash > 0);
+ }
+ return 1;
+ } else
+ return zuo_is_path_string(obj);
+}
+
+static zuo_t *zuo_module_path_p(zuo_t *obj) {+ int saw_slash;
+ return zuo_is_module_path(obj, &saw_slash) ? z.o_true : z.o_false;
+}
+
+static void check_path_string(const char *who, zuo_t *obj) {+ if (!zuo_is_path_string(obj))
+ zuo_fail_arg(who, "path string", obj);
+}
+
+static void check_module_path(const char *who, zuo_t *obj) {+ int saw_slash = 0;
+ if (!zuo_is_module_path(obj, &saw_slash))
+ zuo_fail_arg(who, "module path", obj);
+}
+
+static int zuo_path_is_absolute(const char *p) {+#ifdef ZUO_UNIX
+ return p[0] == '/';
+#endif
+#ifdef ZUO_WINDOWS
+ return (ZUO_IS_PATH_SEP(p[0])
+ || (isalpha(p[0])
+ && (p[1] == ':')
+ && ZUO_IS_PATH_SEP(p[2])));
+#endif
+}
+
+static zuo_t *zuo_relative_path_p(zuo_t *obj) {+ check_path_string("relative-path?", obj);+ return zuo_path_is_absolute(ZUO_STRING_PTR(obj)) ? z.o_false : z.o_true;
+}
+
+static char *zuo_getcwd() {+ char *dir;
+ char *s;
+ int len = 256;
+
+ s = malloc(len);
+ while (1) {+ int bigger;
+#ifdef ZUO_UNIX
+ dir = getcwd(s, len);
+ bigger = !dir && (errno == ERANGE);
+#endif
+#ifdef ZUO_WINDOWS
+ {+ DWORD have = len / sizeof(wchar_t), want;
+ want = GetCurrentDirectoryW(have, (wchar_t *)s);
+ if (want == 0)
+ dir = NULL;
+ else {+ dir = s;
+ bigger = want > have;
+ }
+ }
+#endif
+ if (dir)
+ break;
+ if (bigger) {+ free(s);
+ len *= 2;
+ s = malloc(len);
+ } else
+ break;
+ }
+ /* dir == s, unless failure */
+
+ if (!dir)
+ zuo_fail("error getting current directory");+
+#ifdef ZUO_WINDOWS
+ dir = zuo_from_wide((wchar_t *)s);
+ free(s);
+#endif
+
+ return dir;
+}
+
+static zuo_t *zuo_current_directory() {+ char *dir = zuo_getcwd();
+ zuo_t *obj;
+
+ obj = zuo_string(dir);
+ free(dir);
+
+ return obj;
+}
+
+static zuo_t *zuo_split_path(zuo_t *p) {+ zuo_int_t i, skip = 0;
+ int non_sep, tail_seps;
+
+ check_path_string("split-path", p);+
+#ifdef ZUO_WINDOWS
+ if (ZUO_IS_PATH_SEP(ZUO_STRING_PTR(p)[0])
+ && ZUO_IS_PATH_SEP(ZUO_STRING_PTR(p)[1])) {+ /* Treat a UNC drive the same as a root "/" */
+# define ZUO_IS_NON_SEP(c) ((c) && !ZUO_IS_PATH_SEP(c))
+ if (ZUO_IS_NON_SEP(ZUO_STRING_PTR(p)[2])) {+ for (i = 3; ZUO_IS_NON_SEP(ZUO_STRING_PTR(p)[i]); i++) { }+ if (ZUO_IS_PATH_SEP(ZUO_STRING_PTR(p)[i])
+ && ZUO_IS_NON_SEP(ZUO_STRING_PTR(p)[i+1])) {+ for (i++; ZUO_IS_NON_SEP(ZUO_STRING_PTR(p)[i]); i++) { }+ if (ZUO_IS_PATH_SEP(ZUO_STRING_PTR(p)[i]))
+ skip = i;
+ }
+ }
+ } else if (isalpha(ZUO_STRING_PTR(p)[0])
+ && (ZUO_STRING_PTR(p)[1] == ':')
+ && ZUO_IS_PATH_SEP(ZUO_STRING_PTR(p)[2])) {+ skip = 2;
+ }
+ /* Some things we are not handling about Windows paths:
+ - When a path has trailing whitespace, it's not supposed to
+ count as part of the last path element
+ - When a path starts `\\?\c:\`, then slashes are not supposed
+ to count as paht separators
+ - When a path starts `\\?\UNC\`, then the next two elements
+ are supposed to be part of the drive */
+#endif
+
+ non_sep = tail_seps = 0;
+ for (i = ZUO_STRING_LEN(p); i-- > skip; ) {+ if (ZUO_IS_PATH_SEP(ZUO_STRING_PTR(p)[i])) {+ if (non_sep) {+ i++;
+ return zuo_cons(zuo_sized_string(ZUO_STRING_PTR(p), i),
+ zuo_sized_string(ZUO_STRING_PTR(p)+i,
+ ZUO_STRING_LEN(p)-i-tail_seps));
+ } else
+ tail_seps++;
+ } else
+ non_sep = 1;
+ }
+
+ if (tail_seps > 0) {+ if (tail_seps == (ZUO_STRING_LEN(p) - skip))
+ tail_seps--;
+ p = zuo_sized_string(ZUO_STRING_PTR(p), ZUO_STRING_LEN(p)-tail_seps);
+ }
+
+ return zuo_cons(z.o_false, p);
+}
+
+static zuo_t *zuo_build_raw_path2(zuo_t *pre, zuo_t *post) {+ zuo_string_t *path;
+ zuo_uint_t len;
+ int add_sep;
+
+ /* add separator beteween `pre` and `post`? */
+ len = ZUO_STRING_LEN(pre);
+ if (ZUO_IS_PATH_SEP(((zuo_string_t *)pre)->s[len-1]))
+ add_sep = 0;
+ else {+ len += 1;
+ add_sep = 1;
+ }
+ len += ZUO_STRING_LEN(post);
+
+ path = (zuo_string_t *)zuo_new(zuo_string_tag, ZUO_STRING_ALLOC_SIZE(len));
+ path->len = len;
+ path->s[len] = 0;
+ len = ZUO_STRING_LEN(pre);
+ memcpy(&path->s, ZUO_STRING_PTR(pre), len);
+ if (add_sep)
+ path->s[len++] = ZUO_PATH_SEP;
+ memcpy(&path->s[len], ZUO_STRING_PTR(post), ZUO_STRING_LEN(post));
+
+ return (zuo_t *)path;
+}
+
+static zuo_t *zuo_build_path2(zuo_t *base, zuo_t *rel) {+ /* Resolves "." and ".." elements of `rel` while adding to `base`,
+ potentially also resolving ".." or "." at the end of `base` as
+ needed to normalize the addition; also, if `base` is just ".",
+ possibly after resolving ".."s, then "." is not added to the
+ start of `rel`.
+ We don't check that `rel` is actually relative at this layer, and
+ internally we allow "adding" an absolute path to "." as `base`.*/
+ zuo_t *exploded = z.o_null;
+ int ups;
+
+ do {+ zuo_t *l;
+ l = zuo_split_path(rel);
+ exploded = zuo_cons(_zuo_cdr(l), exploded);
+ rel = _zuo_car(l);
+ } while (rel != z.o_false);
+
+ /* count extra ".."s to add to front */
+ ups = 0;
+
+ while (exploded != z.o_null) {+ zuo_t *elem = _zuo_car(exploded);
+
+ if (!strcmp(ZUO_STRING_PTR(elem), ".")) {+ /* drop element */
+ exploded = _zuo_cdr(exploded);
+ } else if (!strcmp(ZUO_STRING_PTR(elem), "..")) {+ /* elem is ".." */
+ zuo_t *l = zuo_split_path(base);
+ zuo_t *base_elem = _zuo_cdr(l);
+ if (!strcmp(ZUO_STRING_PTR(base_elem), ".")) {+ base = _zuo_car(l);
+ if (base == z.o_false) {+ ups++;
+ exploded = _zuo_cdr(exploded);
+ }
+ } else if (!strcmp(ZUO_STRING_PTR(base_elem), "..")) {+ /* shift ".." to `exploded` */
+ exploded = zuo_cons(base_elem, exploded);
+ base = _zuo_car(l);
+ } else {+ base = _zuo_car(l);
+ exploded = _zuo_cdr(exploded);
+ }
+ if (base == z.o_false)
+ base = zuo_string(".");+ } else {+ if (!strcmp(ZUO_STRING_PTR(base), "."))
+ base = elem;
+ else
+ base = zuo_build_raw_path2(base, elem);
+ exploded = _zuo_cdr(exploded);
+ }
+ }
+
+ while ((ups--) > 0) {+ if (!strcmp(ZUO_STRING_PTR(base), "."))
+ base = zuo_string("..");+ else
+ base = zuo_build_raw_path2(zuo_string(".."), base);+ }
+
+ return base;
+}
+
+static zuo_t *zuo_build_path_multi(const char *who, zuo_t *paths,
+ zuo_t *(*build_path2)(zuo_t *, zuo_t *)) {+ zuo_t *pre, *post;
+
+ pre = _zuo_car(paths);
+ check_path_string(who, pre);
+
+ paths = _zuo_cdr(paths);
+
+ while (1) {+ if (paths == z.o_null)
+ return pre;
+
+ post = _zuo_car(paths);
+ paths = _zuo_cdr(paths);
+
+ check_path_string(who, post);
+
+ if (zuo_path_is_absolute(ZUO_STRING_PTR(post)))
+ zuo_fail1w(who, "additional path is not relative", post);
+
+ pre = build_path2(pre, post);
+ }
+}
+
+static zuo_t *zuo_build_raw_path(zuo_t *paths) {+ return zuo_build_path_multi("build-raw-path", paths, zuo_build_raw_path2);+}
+
+static zuo_t *zuo_build_path(zuo_t *paths) {+ return zuo_build_path_multi("build-path", paths, zuo_build_path2);+}
+
+static zuo_t *zuo_normalize_input_path(zuo_t *path) {+ /* Using "." is meant to work even if `path` is absolute: */
+ return zuo_build_path2(zuo_string("."), path);+}
+
+static zuo_t *zuo_path_to_complete_path(zuo_t *path) {+ if (zuo_path_is_absolute(ZUO_STRING_PTR(path)))
+ return path;
+ else
+ return zuo_build_path2(zuo_current_directory(), path);
+}
+
+zuo_t *zuo_library_path_to_file_path(zuo_t *path) {+ zuo_t *strobj;
+ int saw_slash = 0;
+
+ if ((path->tag != zuo_symbol_tag)
+ || !zuo_is_module_path(path, &saw_slash))
+ zuo_fail_arg("module-path->path", "module library path", path);+
+ if (Z.o_library_path == z.o_false)
+ zuo_fail1("no library path configured, cannot load module", path);+
+ strobj = zuo_tilde_a(zuo_cons(((zuo_symbol_t *)path)->str,
+ zuo_cons(saw_slash ? zuo_string("") : zuo_string("/main"),+ zuo_cons(zuo_string(".zuo"),+ z.o_null))));
+
+ return zuo_build_path2(Z.o_library_path, strobj);
+}
+
+zuo_t *zuo_parse_relative_module_path(const char *who, zuo_t *rel_mod_path, int *_ups, int strip_ups) {+ zuo_int_t i = 0, len = ZUO_STRING_LEN(rel_mod_path);
+ unsigned char *s = (unsigned char *)ZUO_STRING_PTR(rel_mod_path);
+ int bad = 0, ups = 1, ups_until = 0, saw_non_dot = 0, suffix = 0;
+
+ while (i < len) {+ if (s[i] == '.') {+ if (s[i+1] == '/')
+ i += 2;
+ else if (s[i+1] == '.') {+ if (s[i+2] == '/')
+ i += 3;
+ else
+ bad = 1;
+ if (!saw_non_dot)
+ ups++;
+ } else if ((s[i+1] == 'z')
+ && (s[i+2] == 'u')
+ && (s[i+3] == 'o')
+ && (s[i+4] == 0)) {+ suffix = 4;
+ i += 4;
+ saw_non_dot = 1;
+ } else
+ bad = 1;
+ if (!saw_non_dot)
+ ups_until = i;
+ } else if (zuo_is_symbol_module_char(s[i])) {+ saw_non_dot = 1;
+ if (s[i] == '/')
+ bad = 1;
+ else if (s[i+1] == '/')
+ i += 2;
+ else
+ i++;
+ } else
+ bad = 1;
+ if (bad)
+ zuo_fail_arg(who, "relative module library path", rel_mod_path);
+ }
+
+ if (suffix == 0)
+ zuo_fail1w(who, "relative module library path lacks \".zuo\"", rel_mod_path);
+
+ *_ups = ups;
+
+ if (strip_ups)
+ return zuo_sized_string((char *)s + ups_until, len - ups_until - suffix);
+ else
+ return rel_mod_path;
+}
+
+zuo_t *zuo_build_module_path(zuo_t *base_mod_path, zuo_t *rel_mod_path) {+ const char *who = "build-module-path";
+ int saw_slash = 0, ups = 0, strip_ups;
+ zuo_t *rel_str;
+
+ check_module_path(who, rel_mod_path);
+ if (!zuo_is_module_path(base_mod_path, &saw_slash))
+ zuo_fail_arg(who, "module path", base_mod_path);
+
+ if (rel_mod_path->tag == zuo_symbol_tag)
+ return rel_mod_path;
+
+ /* When an absolute path is given, normalization is the caller's problem: */
+ if (zuo_path_is_absolute(ZUO_STRING_PTR(rel_mod_path)))
+ return rel_mod_path;
+
+ strip_ups = (base_mod_path->tag == zuo_symbol_tag);
+
+ rel_str = zuo_parse_relative_module_path(who, rel_mod_path, &ups, strip_ups);
+
+ if (base_mod_path->tag == zuo_symbol_tag) {+ zuo_t *mod_path = ((zuo_symbol_t *)base_mod_path)->str;
+ if (!saw_slash)
+ mod_path = zuo_tilde_a(zuo_cons(mod_path, zuo_cons(zuo_string("/main"), z.o_null)));+
+ while (ups) {+ zuo_t *l = zuo_split_path(mod_path);
+ mod_path = _zuo_car(l);
+ if (mod_path == z.o_false)
+ zuo_fail1w(who, "too many up elements", rel_mod_path);
+ ups--;
+ }
+
+ mod_path = zuo_tilde_a(zuo_cons(mod_path, zuo_cons(rel_str, z.o_null)));
+ mod_path = zuo_string_to_symbol(mod_path);
+
+ if (!zuo_is_module_path(mod_path, &saw_slash))
+ zuo_fail1w(who, "relative path is not valid in a symbolic module path", rel_mod_path);
+
+ return mod_path;
+ } else {+ base_mod_path = _zuo_car(zuo_split_path(base_mod_path));
+ if (base_mod_path == z.o_false)
+ base_mod_path = zuo_string(".");+ return zuo_build_path2(base_mod_path, rel_str);
+ }
+}
+
+static zuo_t *zuo_runtime_env() {+ return Z.o_runtime_env;
+}
+
+#ifndef ZUO_EMBEDDED
+static zuo_t *zuo_make_runtime_env(zuo_t *exe_path, const char *load_file, int argc, char **argv) {+ zuo_t *ht = z.o_empty_hash;
+
+ ht = zuo_hash_set(ht, zuo_symbol("exe"), exe_path);+
+ {+ zuo_t *l = z.o_null;
+ while (argc-- > 0)
+ l = zuo_cons(zuo_string(argv[argc]), l);
+ ht = zuo_hash_set(ht, zuo_symbol("args"), l);+ }
+
+ ht = zuo_hash_set(ht, zuo_symbol("script"), zuo_string(load_file));+
+ return ht;
+}
+#endif
+
+static zuo_t *zuo_finish_runtime_env(zuo_t *ht) {+ ht = zuo_hash_set(ht, zuo_symbol("version"), zuo_integer(ZUO_VERSION));+
+ ht = zuo_hash_set(ht, zuo_symbol("dir"), zuo_current_directory());+ ht = zuo_hash_set(ht, zuo_symbol("env"), zuo_get_envvars());+
+ {+#ifdef ZUO_UNIX
+ zuo_t *type = zuo_symbol("unix");+ ht = zuo_hash_set(ht, zuo_symbol("can-exec?"), z.o_true);+#endif
+#ifdef ZUO_WINDOWS
+ zuo_t *type = zuo_symbol("windows");+ ht = zuo_hash_set(ht, zuo_symbol("can-exec?"), z.o_true);+#endif
+ ht = zuo_hash_set(ht, zuo_symbol("system-type"), type);+ }
+
+#ifdef ZUO_WINDOWS
+ {+ int size;
+ wchar_t *wa;
+ char *a;
+ size = GetSystemDirectoryW(NULL, 0);
+ wa = (wchar_t *)malloc((size + 1) * sizeof(wchar_t));
+ GetSystemDirectoryW(wa, size + 1);
+ a = zuo_from_wide(wa);
+ ht = zuo_hash_set(ht, zuo_symbol("sys-dir"), zuo_string(a));+ free(a);
+ free(wa);
+ }
+#endif
+
+ return ht;
+}
+
+/*======================================================================*/
+/* optional arguments through a hash table */
+/*======================================================================*/
+
+static zuo_t *zuo_consume_option(zuo_t **_options, const char *name) {+ zuo_t *sym = zuo_symbol(name);
+ zuo_t *opt = zuo_trie_lookup(*_options, sym);
+
+ if (opt != z.o_undefined)
+ *_options = zuo_hash_remove(*_options, sym);
+
+ return opt;
+}
+
+static void check_options_consumed(const char *who, zuo_t *options) {+ if (((zuo_trie_node_t *)options)->count > 0) {+ options = zuo_hash_keys(options);
+ zuo_fail1w(who, "unrecognized or unused option", _zuo_car(options));
+ }
+}
+
+/*======================================================================*/
+/* files/streams */
+/*======================================================================*/
+
+#ifdef ZUO_UNIX
+/* Maybe not necessary, since we use `SA_RESTART`, but just in case: */
+# define EINTR_RETRY(e) do { } while (((e) == -1) && (errno == EINTR))+#endif
+
+static zuo_t *zuo_fd_handle(zuo_raw_handle_t handle, zuo_handle_status_t status) {+ zuo_t *h = zuo_handle(handle, status);
+#ifdef ZUO_UNIX
+ int added = 0;
+ Z.o_fd_table = trie_extend(Z.o_fd_table, handle, h, h, &added);
+#endif
+ return h;
+}
+
+static zuo_t *zuo_drain(zuo_raw_handle_t fd, zuo_int_t amount) {+ /* amount as -1 => read until EOF
+ amount as -2 => non-blocking read on Unix */
+ zuo_t *s;
+ zuo_int_t sz = 256, offset = 0;
+
+ if ((amount >= 0) && (sz > amount))
+ sz = amount;
+
+ s = zuo_uninitialized_string(sz);
+ while ((amount < 0) || (offset < amount)) {+ zuo_int_t got;
+ zuo_int_t amt = sz - offset;
+ if (amt > 4096) amt = 4096;
+#ifdef ZUO_UNIX
+ {+ int nonblock = (amount == -2), old_fl, r;
+
+ if (nonblock) {+ EINTR_RETRY(old_fl = fcntl(fd, F_GETFL, 0));
+ if (old_fl == -1) zuo_fail("failed to access flags of file descriptor");+ EINTR_RETRY(r = fcntl(fd, F_SETFL, old_fl | O_NONBLOCK));
+ if (r == -1) zuo_fail("failed to set file descriptor as nonblocking");+ } else
+ old_fl = 0;
+
+ EINTR_RETRY(got = read(fd, ZUO_STRING_PTR(s) + offset, amt));
+ if ((got < 0) && (errno == EAGAIN)) {+ got = 0;
+ if (offset == 0)
+ amount = 0; /* don't return `eof` */
+ }
+
+ if (nonblock) {+ EINTR_RETRY(r = fcntl(fd, F_SETFL, old_fl));
+ if (r == -1) zuo_fail("failed to restore flags of file descriptor");+ }
+ }
+#endif
+#ifdef ZUO_WINDOWS
+ {+ DWORD dgot;
+ if (!ReadFile(fd, ZUO_STRING_PTR(s) + offset, amt, &dgot, NULL)) {+ if (GetLastError() == ERROR_BROKEN_PIPE)
+ got = 0;
+ else
+ got = -1;
+ } else
+ got = dgot;
+ }
+#endif
+
+ if (got < 0)
+ zuo_fail("error reading stream");+
+ if (got == 0) {+ break;
+ } else {+ offset += got;
+ if (offset == sz) {+ zuo_t *new_s;
+ zuo_int_t new_sz = sz*2;
+ if ((amount >= 0) && (new_sz > amount))
+ new_sz = amount;
+ new_s = zuo_uninitialized_string(new_sz);
+ memcpy(ZUO_STRING_PTR(new_s), ZUO_STRING_PTR(s), sz);
+ sz = new_sz;
+ s = new_s;
+ }
+ }
+ }
+
+ ZUO_STRING_PTR(s)[offset] = 0;
+ ZUO_STRING_LEN(s) = offset;
+
+ if ((offset == 0) && (amount > 0))
+ return z.o_eof;
+
+ return s;
+}
+
+static void zuo_fill(const char *s, zuo_int_t len, zuo_raw_handle_t fd) {+ zuo_int_t done = 0;
+ while (done < len) {+ zuo_int_t did;
+ zuo_int_t amt = len - done;
+ if (amt > 4096) amt = 4096;
+#ifdef ZUO_UNIX
+ EINTR_RETRY(did = write(fd, s + done, amt));
+#endif
+#ifdef ZUO_WINDOWS
+ {+ DWORD ddid;
+ if (!WriteFile(fd, s + done, amt, &ddid, NULL))
+ did = -1;
+ else
+ did = ddid;
+ }
+#endif
+
+ if (did < 0)
+ zuo_fail("error writing to stream");+
+ done += did;
+ }
+}
+
+static void zuo_close_handle(zuo_raw_handle_t handle)
+{+#ifdef ZUO_UNIX
+ EINTR_RETRY(close(handle));
+#endif
+#ifdef ZUO_WINDOWS
+ CloseHandle(handle);
+#endif
+}
+
+static void zuo_close(zuo_raw_handle_t handle)
+{+ zuo_close_handle(handle);
+#ifdef ZUO_UNIX
+ Z.o_fd_table = trie_remove(Z.o_fd_table, handle, 0);
+#endif
+}
+
+static zuo_raw_handle_t zuo_fd_open_input_handle(zuo_t *path, zuo_t *options) {+ const char *who = "fd-open-input";
+ zuo_raw_handle_t fd;
+
+ if (options == z.o_undefined) options = z.o_empty_hash;
+
+ if (zuo_is_path_string(path)) {+ check_hash(who, options);
+ check_options_consumed(who, options);
+ if (zuo_file_logging) {+ FILE *lf = fopen(zuo_file_logging, "ab");
+ zuo_fwrite(lf, path);
+ fprintf(lf, "\n");
+ fclose(lf);
+ }
+#ifdef ZUO_UNIX
+ EINTR_RETRY(fd = open(ZUO_STRING_PTR(path), O_RDONLY));
+ if (fd == -1)
+ zuo_fail1w_errno(who, "file open failed", path);
+#endif
+#ifdef ZUO_WINDOWS
+ wchar_t *wp = zuo_to_wide(ZUO_STRING_PTR(path));
+ fd = CreateFileW(wp,
+ GENERIC_READ,
+ FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
+ NULL,
+ OPEN_EXISTING,
+ 0,
+ NULL);
+ if (fd == INVALID_HANDLE_VALUE)
+ zuo_fail1w(who, "file open failed", path);
+ free(wp);
+#endif
+ return fd;
+ } else if (path == zuo_symbol("stdin")) {+ check_hash(who, options);
+ check_options_consumed(who, options);
+ fd = zuo_get_std_handle(0);
+ return fd;
+ } else {+ if ((path->tag != zuo_integer_tag)
+ || (ZUO_INT_I(path) < 0))
+ zuo_fail_arg(who, "path string, 'stdin, or nonnegative integer", path);
+
+ check_hash(who, options);
+ check_options_consumed(who, options);
+#ifdef ZUO_UNIX
+ fd = (zuo_raw_handle_t)ZUO_INT_I(path);
+ return fd;
+#endif
+#ifdef ZUO_WINDOWS
+ zuo_fail1w(who, "integer file descriptors are not supported on Windows", path);
+ return INVALID_HANDLE_VALUE;
+#endif
+ }
+}
+
+static zuo_t *zuo_fd_open_input(zuo_t *path, zuo_t *options) {+ return zuo_handle(zuo_fd_open_input_handle(path, options), zuo_handle_open_fd_in_status);
+}
+
+static zuo_t *zuo_fd_open_output(zuo_t *path, zuo_t *options) {+ zuo_t *fd_h;
+ const char *who = "fd-open-output";
+ zuo_raw_handle_t fd;
+
+ if (options == z.o_undefined) options = z.o_empty_hash;
+
+ if (zuo_is_path_string(path)) {+ zuo_t *exists;
+
+ check_hash(who, options);
+
+ exists = zuo_consume_option(&options, "exists");
+
+ check_options_consumed(who, options);
+
+#ifdef ZUO_UNIX
+ {+ int mode = O_CREAT | O_EXCL;
+
+ if (exists != z.o_undefined) {+ if (exists != zuo_symbol("error")) {+ if (exists == zuo_symbol("truncate"))+ mode = O_CREAT | O_TRUNC;
+ else if (exists == zuo_symbol("must-truncate"))+ mode = O_TRUNC;
+ else if (exists == zuo_symbol("append"))+ mode = O_CREAT | O_APPEND;
+ else if (exists == zuo_symbol("update"))+ mode = 0;
+ else if (exists == zuo_symbol("can-update"))+ mode = O_CREAT;
+ else
+ zuo_fail1w(who, "invalid exists mode", exists);
+ }
+ }
+
+ EINTR_RETRY(fd = open(ZUO_STRING_PTR(path), O_WRONLY | mode, 0666));
+ if (fd == -1)
+ zuo_fail1w_errno(who, "file open failed", path);
+ }
+#endif
+#ifdef ZUO_WINDOWS
+ {+ wchar_t *wp = zuo_to_wide(ZUO_STRING_PTR(path));
+ DWORD mode = CREATE_NEW;
+ int append = 0;
+
+ if (exists != z.o_undefined) {+ if (exists != zuo_symbol("error")) {+ if (exists == zuo_symbol("truncate"))+ mode = CREATE_ALWAYS;
+ else if (exists == zuo_symbol("must-truncate"))+ mode = TRUNCATE_EXISTING;
+ else if (exists == zuo_symbol("append")) {+ mode = OPEN_ALWAYS;
+ append = 1;
+ } else if (exists == zuo_symbol("update"))+ mode = OPEN_EXISTING;
+ else if (exists == zuo_symbol("can-update"))+ mode = OPEN_ALWAYS;
+ else
+ zuo_fail1w(who, "invalid exists mode", exists);
+ }
+ }
+
+ fd = CreateFileW(wp,
+ GENERIC_WRITE,
+ FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
+ NULL,
+ mode,
+ 0,
+ NULL);
+ if (fd == INVALID_HANDLE_VALUE)
+ zuo_fail1w(who, "file open failed", path);
+ free(wp);
+
+ if (append)
+ SetFilePointer(fd, 0, NULL, FILE_END);
+ }
+#endif
+ fd_h = zuo_fd_handle(fd, zuo_handle_open_fd_out_status);
+
+ return fd_h;
+ } else if (path == zuo_symbol("stdout")) {+ check_hash(who, options);
+ check_options_consumed(who, options);
+ fd = zuo_get_std_handle(1);
+ return zuo_handle(fd, zuo_handle_open_fd_out_status);
+ } else if (path == zuo_symbol("stderr")) {+ check_hash(who, options);
+ check_options_consumed(who, options);
+ fd = zuo_get_std_handle(2);
+ return zuo_handle(fd, zuo_handle_open_fd_out_status);
+ } else {+ if ((path->tag != zuo_integer_tag)
+ || (ZUO_INT_I(path) < 0))
+ zuo_fail_arg(who, "path string, 'stdout, 'stderr, or nonnegative integer", path);
+ check_hash(who, options);
+ check_options_consumed(who, options);
+#ifdef ZUO_UNIX
+ fd = zuo_get_std_handle((zuo_raw_handle_t)ZUO_INT_I(path));
+ return zuo_handle(fd, zuo_handle_open_fd_out_status);
+#endif
+#ifdef ZUO_WINDOWS
+ zuo_fail1w(who, "integer file descriptors are not supported on Windows", path);
+ return z.o_undefined;
+#endif
+ }
+}
+
+static void zuo_check_input_output_fd(const char *who, zuo_t *fd_h) {+ if (fd_h->tag == zuo_handle_tag) {+ zuo_handle_t *h = (zuo_handle_t *)fd_h;
+ if ((h->u.h.status == zuo_handle_open_fd_out_status)
+ || (h->u.h.status == zuo_handle_open_fd_in_status)) {+ return;
+ }
+ }
+
+ zuo_fail_arg(who, "open input or output file descriptor", fd_h);
+}
+
+static zuo_t *zuo_fd_close(zuo_t *fd_h) {+ zuo_check_input_output_fd("fd-close", fd_h);+ {+ zuo_handle_t *h = (zuo_handle_t *)fd_h;
+ zuo_close(h->u.h.u.handle);
+ h->u.h.status = zuo_handle_closed_status;
+ }
+ return z.o_void;
+}
+
+zuo_t *zuo_fd_write(zuo_t *fd_h, zuo_t *str) {+ const char *who = "fd-write";
+
+ if ((fd_h->tag != zuo_handle_tag)
+ || ((zuo_handle_t *)fd_h)->u.h.status != zuo_handle_open_fd_out_status)
+ zuo_fail_arg(who, "open output file descriptor", fd_h);
+
+ check_string(who, str);
+
+ zuo_fill(ZUO_STRING_PTR(str), ZUO_STRING_LEN(str), ZUO_HANDLE_RAW(fd_h));
+
+ return z.o_void;
+}
+
+static zuo_t *zuo_fd_read(zuo_t *fd_h, zuo_t *amount) {+ const char *who = "fd-read";
+ zuo_int_t amt = -1;
+
+ if ((fd_h->tag != zuo_handle_tag)
+ || ((zuo_handle_t *)fd_h)->u.h.status != zuo_handle_open_fd_in_status)
+ zuo_fail_arg(who, "open input file descriptor", fd_h);
+ if (amount != z.o_eof) {+ if ((amount->tag == zuo_symbol_tag)
+ && (amount == zuo_symbol("avail"))) {+#ifdef ZUO_UNIX
+ amt = -2;
+#endif
+#ifdef ZUO_WINDOWS
+ zuo_fail1w(who, "non-blocking reads are not supported for file descriptor", fd_h);
+#endif
+ } else if ((amount->tag == zuo_integer_tag)
+ && (ZUO_INT_I(amount) >= 0))
+ amt = ZUO_INT_I(amount);
+ else
+ zuo_fail_arg(who, "nonnegative integer, eof, or 'avail", amount);
+ }
+
+ return zuo_drain(ZUO_HANDLE_RAW(fd_h), amt);
+}
+
+static zuo_t *zuo_fd_terminal_p(zuo_t *fd_h, zuo_t *ansi) {+ zuo_check_input_output_fd("fd-ansi-terminal?", fd_h);+ if ((ansi != z.o_undefined) && (ansi != z.o_false) && !zuo_ansi_ok)
+ return z.o_false;
+ return zuo_is_terminal(ZUO_HANDLE_RAW(fd_h)) ? z.o_true : z.o_false;
+}
+
+static zuo_t *zuo_fd_valid_p(zuo_t *fd_h) {+ zuo_check_input_output_fd("fd-valid?", fd_h);+
+#ifdef ZUO_UNIX
+ {+ int r;
+ zuo_raw_handle_t fd;
+
+ fd = ZUO_HANDLE_RAW(fd_h);
+ EINTR_RETRY(r = fcntl(fd, F_GETFL, 0));
+
+ return (r == -1) ? z.o_false : z.o_true;
+ }
+#else
+ return z.o_true;
+#endif
+}
+
+static char *zuo_string_to_c(zuo_t *obj) {+ char *s;
+ zuo_int_t len;
+
+ check_string("string->c", obj);+
+ len = ZUO_STRING_LEN(obj);
+ s = malloc(len + 1);
+ memcpy(s, ZUO_STRING_PTR(obj), len);
+ s[len] = 0;
+
+ return s;
+}
+
+static zuo_t *zuo_dump_image_and_exit(zuo_t *fd_obj) {+ zuo_int_t len;
+ char *dump;
+ zuo_raw_handle_t fd;
+
+ if ((fd_obj->tag != zuo_handle_tag)
+ || ((zuo_handle_t *)fd_obj)->u.h.status != zuo_handle_open_fd_out_status)
+ zuo_fail_arg("dump-image-and-exit", "open output file descriptor", fd_obj);+
+ fd = ZUO_HANDLE_RAW(fd_obj);
+
+ /* no runtime state is preserved */
+ {+ zuo_t **p = (zuo_t **)&zuo_roots.runtime;
+ int i, len;
+ len = sizeof(zuo_roots.runtime) / sizeof(zuo_t*);
+ for (i = 0; i < len; i++)
+ p[i] = z.o_undefined;
+ Z.o_interp_k = z.o_done_k; /* in case of a failure that might try to show a stack trace */
+ Z.o_interp_meta_k = z.o_null;
+ }
+
+ dump = zuo_fasl_dump(&len);
+ zuo_fill(dump, len, fd);
+
+ exit(0);
+}
+
+static zuo_t *zuo_handle_p(zuo_t *var) {+ return (var->tag == zuo_handle_tag) ? z.o_true : z.o_false;
+}
+
+/*======================================================================*/
+/* modules */
+/*======================================================================*/
+
+static zuo_t *zuo_declare_kernel_module() {+ /* We implement the `read-and-eval` or `zuo/kernel` and
+ `module->hash` here as hand-built closures. We can't make them
+ primitives, becase they need to use the `kernel-eval`
+ `apply` intrinsics. */
+ zuo_t *arg_id, *module_to_hash;
+
+ arg_id = zuo_symbol("arg");+
+ {+ zuo_t *read_and_eval_sym, *read_and_eval, *call, *mod;
+
+ /* read-and-eval = (lambda arg "read-and-eval"
+ . (kernel-eval (kernel-read-from-string arg))) */
+ read_and_eval_sym = zuo_symbol("read-and-eval");+ call = zuo_cons(z.o_kernel_eval,
+ zuo_cons(zuo_cons(z.o_kernel_read_string,
+ zuo_cons(arg_id, z.o_null)),
+ z.o_null));
+ read_and_eval = zuo_closure(zuo_cons(z.o_lambda_symbol,
+ zuo_cons(arg_id,
+ zuo_cons(((zuo_symbol_t *)read_and_eval_sym)->str,
+ zuo_cons(call, z.o_null)))),
+ z.o_empty_hash);
+
+ mod = zuo_trie_extend(z.o_empty_hash, read_and_eval_sym, read_and_eval);
+
+ z.o_modules = zuo_cons(zuo_cons(zuo_symbol("zuo/kernel"), mod), z.o_modules);+ }
+
+ {+ zuo_t *mod_ids, *args, *car_arg, *cdr_arg, *hash_p_arg, *module_to_hash_star_arg, *recur;
+ zuo_t *call, *apply, *reg_mod, *bind, *if_form, *body;
+ /* module->hash = (lambda (mod) "module->hash"
+ . (let ([arg (module->hash* mod)])
+ . (if (hash? arg)
+ . arg
+ . (register-module
+ . mod
+ . (apply (get-read-and-eval (car arg) (module->hash (car arg))) (cdr arg))))) */
+ mod_ids = zuo_cons(zuo_symbol("mod"), z.o_null);+ args = zuo_cons(arg_id, z.o_null);
+ car_arg = zuo_cons(zuo_trie_lookup(z.o_top_env, zuo_symbol("car")), args);+ cdr_arg = zuo_cons(zuo_trie_lookup(z.o_top_env, zuo_symbol("cdr")), args);+ hash_p_arg = zuo_cons(zuo_trie_lookup(z.o_top_env, zuo_symbol("hash?")), args);+ module_to_hash_star_arg = zuo_cons(z.o_module_to_hash_star, mod_ids);
+ recur = zuo_cons(z.o_false, zuo_cons(car_arg, z.o_null));
+ call = zuo_cons(z.o_get_read_and_eval, zuo_cons(car_arg, zuo_cons(recur, z.o_null)));
+ apply = zuo_cons(z.o_apply, zuo_cons(call, zuo_cons(cdr_arg, z.o_null)));
+ reg_mod = zuo_cons(z.o_register_module, zuo_cons(_zuo_car(mod_ids), zuo_cons(apply, z.o_null)));
+ if_form = zuo_cons(z.o_if_symbol, zuo_cons(hash_p_arg, zuo_cons(arg_id, zuo_cons(reg_mod, z.o_null))));
+ bind = zuo_cons(zuo_cons(arg_id, zuo_cons(module_to_hash_star_arg, z.o_null)), z.o_null);
+ body = zuo_cons(z.o_let_symbol, zuo_cons(bind, zuo_cons(if_form, z.o_null)));
+ module_to_hash = zuo_closure(zuo_cons(z.o_lambda_symbol,
+ zuo_cons(mod_ids,
+ zuo_cons(zuo_string("module->hash"),+ zuo_cons(body, z.o_null)))),
+ z.o_empty_hash);
+ ((zuo_pair_t *)recur)->car = module_to_hash; /* tie loop for recursive call */
+ }
+
+ return module_to_hash;
+}
+
+static zuo_t *zuo_kernel_read_string(zuo_t *args) {+ /* This primitive primitive claims to be `read-and-eval` in errors,
+ but it's actually just the reading part */
+ const char *who = "read-and-eval";
+ zuo_t *str, *start_i, *mod_path;
+ zuo_int_t start;
+ zuo_t *es;
+
+ /* Check arguments in case someone calls `read-and-eval` directly,
+ instead of through `#lang` */
+
+ if (zuo_length_int(args) != 3)
+ zuo_arity_error(zuo_string("read-and-eval"), args);+
+ str = _zuo_car(args);
+ start_i = _zuo_car(_zuo_cdr(args));
+ mod_path = _zuo_car(_zuo_cdr(_zuo_cdr(args)));
+
+ check_string(who, str);
+ check_integer(who, start_i);
+ check_module_path(who, mod_path);
+
+ start = ZUO_INT_I(start_i);
+ if ((start < 0) || (start > ZUO_STRING_LEN(str)))
+ zuo_fail1w(who, "starting index is out of bounds", start_i);
+
+ es = zuo_string_read(str, start_i, mod_path);
+
+ if (es == z.o_null)
+ zuo_fail("zuo/kernel: no S-expression in input");+ if (_zuo_cdr(es) != z.o_null)
+ zuo_fail("zuo/kernel: more than one S-expression in input");+
+ return _zuo_car(es);
+}
+
+static int zuo_module_path_equal(zuo_t *a, zuo_t *b) {+ if (a->tag == zuo_symbol_tag)
+ return (a == b);
+ else if (b->tag == zuo_symbol_tag)
+ return 0;
+ else
+ return zuo_string_eql(a, b) == z.o_true;
+}
+
+static void zuo_log_module_start(zuo_t *module_path) {+ if (zuo_logging) {+ int i;
+ if (zuo_logging > 1) fprintf(stderr, "\n");
+ for (i = 1; i < zuo_logging; i++) fprintf(stderr, " ");
+ fprintf(stderr, "["); zuo_fdisplay(stderr, module_path);
+ fflush(stderr);
+ zuo_logging++;
+ }
+}
+
+static zuo_t *zuo_module_to_hash_star(zuo_t *module_path) {+ /* This primitive primitive implements the easy case of
+ `module->hash` when a module is declared. Otherwise, it bounces
+ back information needed to find the `#lang` module and eventually
+ call its `read- and-eval`.*/
+ zuo_t *file_path, *l;
+
+ check_module_path("module->hash", module_path);+
+ /* check for already-loaded module */
+ for (l = z.o_modules; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *a = _zuo_car(l);
+ if (zuo_module_path_equal(module_path, _zuo_car(a)))
+ return _zuo_cdr(a);
+ }
+
+ /* check for cycles module */
+ for (l = Z.o_pending_modules; l != z.o_null; l = _zuo_cdr(l)) {+ if (zuo_module_path_equal(module_path, _zuo_car(l)))
+ zuo_fail1("cycle in module loading", module_path);+ }
+
+ /* not already loaded */
+
+ Z.o_pending_modules = zuo_cons(module_path, Z.o_pending_modules);
+
+ if (module_path->tag == zuo_symbol_tag)
+ file_path = zuo_library_path_to_file_path(module_path);
+ else
+ file_path = module_path;
+
+ zuo_log_module_start(module_path);
+
+ {+ zuo_raw_handle_t in;
+ zuo_t *str, *lang;
+ zuo_int_t post;
+
+ in = zuo_fd_open_input_handle(file_path, z.o_empty_hash);
+ str = zuo_drain(in, -1);
+ zuo_close_handle(in);
+
+ lang = zuo_read_language(ZUO_STRING_PTR(str), &post, module_path);
+
+ /* `car` is sent to `module->hash` recursively, and rest
+ are args to extracted `read-and-eval` */
+ return zuo_cons(lang, zuo_cons(str, zuo_cons(zuo_integer(post), zuo_cons(module_path, z.o_null))));
+ }
+}
+
+static zuo_t *zuo_register_module(zuo_t *module_path, zuo_t *mod) {+ /* Bookends the complicated case of `module->hash`, registering a
+ newly evaluated module. */
+ if (mod->tag != zuo_trie_node_tag)
+ zuo_fail1("module did not produce a hash table", module_path);+
+ if ((Z.o_pending_modules == z.o_null)
+ || (module_path != _zuo_car(Z.o_pending_modules)))
+ zuo_fail1("attempting to register unexpected module", module_path);+
+ z.o_modules = zuo_cons(zuo_cons(module_path, mod), z.o_modules);
+ Z.o_pending_modules = _zuo_cdr(Z.o_pending_modules);
+
+ if (zuo_logging) {+ zuo_logging--;
+ fprintf(stderr, "]");
+ if (zuo_logging == 1)
+ fprintf(stderr, "]\n");
+ fflush(stderr);
+ }
+
+ return mod;
+}
+
+static zuo_t *zuo_get_read_and_eval(zuo_t *lang, zuo_t *mod) {+ /* The middle part of `module->hash`: makes sure the `#lang` module
+ really is a language module and returns its `read-and-eval` to be
+ applied. */
+ zuo_t *proc;
+ proc = zuo_trie_lookup(mod, zuo_symbol("read-and-eval"));+ if (proc->tag != zuo_closure_tag)
+ zuo_fail1("not a language module path", lang);+ return proc;
+}
+
+static zuo_t *zuo_module_to_hash(zuo_t *module_path) {+ /* This is a convenience function to be used only to start evaluation */
+ return zuo_kernel_eval(zuo_cons(zuo_trie_lookup(z.o_top_env, zuo_symbol("module->hash")),+ zuo_cons(zuo_cons(z.o_quote_symbol,
+ zuo_cons(module_path,
+ z.o_null)),
+ z.o_null)));
+}
+
+static zuo_t *zuo_eval_module(zuo_t *module_path, zuo_t *input_str) {+ /* This is a convenience function to be used only to start evaluation */
+ zuo_t *lang, *read_and_eval, *mod;
+ zuo_int_t post;
+
+ zuo_log_module_start(module_path);
+
+ Z.o_pending_modules = zuo_cons(module_path, Z.o_pending_modules);
+ Z.o_stash = zuo_cons(module_path, Z.o_stash);
+ Z.o_stash = zuo_cons(input_str, Z.o_stash);
+
+ lang = zuo_read_language(ZUO_STRING_PTR(input_str), &post, module_path);
+ Z.o_stash = zuo_cons(lang, Z.o_stash);
+
+ mod = zuo_module_to_hash(lang);
+
+ lang = _zuo_car(Z.o_stash);
+ Z.o_stash = _zuo_cdr(Z.o_stash);
+
+ read_and_eval = zuo_get_read_and_eval(lang, mod);
+
+ input_str = _zuo_car(Z.o_stash);
+ Z.o_stash = _zuo_cdr(Z.o_stash);
+ module_path = _zuo_car(Z.o_stash);
+
+ mod = zuo_kernel_eval(zuo_cons(read_and_eval,
+ zuo_cons(input_str,
+ zuo_cons(zuo_integer(post),
+ zuo_cons(module_path,
+ z.o_null)))));
+
+ module_path = _zuo_car(Z.o_stash);
+ Z.o_stash = _zuo_cdr(Z.o_stash);
+
+ return zuo_register_module(module_path, mod);
+}
+
+/*======================================================================*/
+/* filesystem and time */
+/*======================================================================*/
+
+#if defined(__APPLE__) && defined(__MACH__)
+# define zuo_st_atim st_atimespec
+# define zuo_st_mtim st_mtimespec
+# define zuo_st_ctim st_ctimespec
+#elif defined(ZUO_WINDOWS)
+# define zuo_st_atim st_atime
+# define zuo_st_mtim st_mtime
+# define zuo_st_ctim st_ctime
+#else
+# define zuo_st_atim st_atim
+# define zuo_st_mtim st_mtim
+# define zuo_st_ctim st_ctim
+#endif
+
+#ifdef ZUO_WINDOWS
+static zuo_t *zuo_filetime_pair(FILETIME *ft){+ zuo_int_t t;
+ t = (((zuo_int_t)ft->dwHighDateTime) << 32) | ft->dwLowDateTime;
+ /* measurement interval is 100 nanoseconds = 1/10 microseconds, and
+ adjust by number of seconds between Windows (1601) and Unix (1970) epochs */
+ return zuo_cons(zuo_integer(t / 10000000 - 11644473600L),
+ zuo_integer((t % 10000000) * 100));
+}
+# define TO_INT64(a, b) (((zuo_int_t)(a) << 32) | (((zuo_int_t)b) & (zuo_int_t)0xFFFFFFFF))
+#endif
+
+static zuo_t *zuo_stat(zuo_t *path, zuo_t *follow_links) {+ const char *who = "stat";
+ zuo_t *result = z.o_empty_hash;
+
+ if (follow_links == z.o_undefined) follow_links = z.o_true;
+
+ check_path_string(who, path);
+
+#ifdef ZUO_UNIX
+ {+ struct stat stat_buf;
+ int stat_result;
+
+ if (follow_links == z.o_false)
+ stat_result = lstat(ZUO_STRING_PTR(path), &stat_buf);
+ else
+ stat_result = stat(ZUO_STRING_PTR(path), &stat_buf);
+
+ if (stat_result != 0) {+ if (errno != ENOENT)
+ zuo_fail1w_errno(who, "failed", path);
+ return z.o_false;
+ }
+
+ if (S_ISDIR(stat_buf.st_mode))
+ result = zuo_hash_set(result, zuo_symbol("type"), zuo_symbol("dir"));+ else if (S_ISLNK(stat_buf.st_mode))
+ result = zuo_hash_set(result, zuo_symbol("type"), zuo_symbol("link"));+ else
+ result = zuo_hash_set(result, zuo_symbol("type"), zuo_symbol("file"));+ result = zuo_hash_set(result, zuo_symbol("mode"), zuo_integer(stat_buf.st_mode));+ result = zuo_hash_set(result, zuo_symbol("device-id"), zuo_integer(stat_buf.st_dev));+ result = zuo_hash_set(result, zuo_symbol("inode"), zuo_integer(stat_buf.st_ino));+ result = zuo_hash_set(result, zuo_symbol("hardlink-count"), zuo_integer(stat_buf.st_nlink));+ result = zuo_hash_set(result, zuo_symbol("user-id"), zuo_integer(stat_buf.st_uid));+ result = zuo_hash_set(result, zuo_symbol("group-id"), zuo_integer(stat_buf.st_gid));+ result = zuo_hash_set(result, zuo_symbol("device-id-for-special-file"), zuo_integer(stat_buf.st_rdev));+ result = zuo_hash_set(result, zuo_symbol("size"), zuo_integer(stat_buf.st_size));+ result = zuo_hash_set(result, zuo_symbol("block-size"), zuo_integer(stat_buf.st_blksize));+ result = zuo_hash_set(result, zuo_symbol("block-count"), zuo_integer(stat_buf.st_blocks));+ result = zuo_hash_set(result, zuo_symbol("access-time-seconds"), zuo_integer(stat_buf.zuo_st_atim.tv_sec));+ result = zuo_hash_set(result, zuo_symbol("access-time-nanoseconds"), zuo_integer(stat_buf.zuo_st_atim.tv_nsec));+ result = zuo_hash_set(result, zuo_symbol("modify-time-seconds"), zuo_integer(stat_buf.zuo_st_mtim.tv_sec));+ result = zuo_hash_set(result, zuo_symbol("modify-time-nanoseconds"), zuo_integer(stat_buf.zuo_st_mtim.tv_nsec));+ result = zuo_hash_set(result, zuo_symbol("creation-time-seconds"), zuo_integer(stat_buf.zuo_st_ctim.tv_sec));+ result = zuo_hash_set(result, zuo_symbol("creation-time-nanoseconds"), zuo_integer(stat_buf.zuo_st_ctim.tv_nsec));+ }
+#endif
+#ifdef ZUO_WINDOWS
+ {+ wchar_t *wp = zuo_to_wide(ZUO_STRING_PTR(path));
+ HANDLE fdh;
+ BY_HANDLE_FILE_INFORMATION info;
+ zuo_t *p;
+
+ fdh = CreateFileW(wp,
+ 0, /* not even read access => just get info */
+ FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
+ NULL,
+ OPEN_EXISTING,
+ FILE_FLAG_BACKUP_SEMANTICS,
+ NULL);
+
+ if (fdh == INVALID_HANDLE_VALUE) {+ DWORD err = GetLastError();
+ if ((err != ERROR_FILE_NOT_FOUND) && (err != ERROR_PATH_NOT_FOUND))
+ zuo_fail1w(who, "failed", path);
+ return z.o_false;
+ }
+
+ if (!GetFileInformationByHandle(fdh, &info))
+ zuo_fail1w(who, "failed", path);
+
+ CloseHandle(fdh);
+
+ if (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
+ result = zuo_hash_set(result, zuo_symbol("type"), zuo_symbol("dir"));+ else
+ result = zuo_hash_set(result, zuo_symbol("type"), zuo_symbol("file"));+ if (info.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
+ result = zuo_hash_set(result, zuo_symbol("mode"), zuo_integer(0444));+ else
+ result = zuo_hash_set(result, zuo_symbol("mode"), zuo_integer(0666));+ result = zuo_hash_set(result, zuo_symbol("device-id"), zuo_integer(info.dwVolumeSerialNumber));+ result = zuo_hash_set(result, zuo_symbol("inode"), zuo_integer(TO_INT64(info.nFileIndexHigh, info.nFileIndexLow)));+ result = zuo_hash_set(result, zuo_symbol("size"), zuo_integer(TO_INT64(info.nFileSizeHigh, info.nFileSizeLow)));+ result = zuo_hash_set(result, zuo_symbol("hardlink-count"), zuo_integer(info.nNumberOfLinks));+ p = zuo_filetime_pair(&info.ftCreationTime);
+ result = zuo_hash_set(result, zuo_symbol("creation-time-seconds"), _zuo_car(p));+ result = zuo_hash_set(result, zuo_symbol("creation-time-nanoseconds"), _zuo_cdr(p));+ p = zuo_filetime_pair(&info.ftLastWriteTime);
+ result = zuo_hash_set(result, zuo_symbol("modify-time-seconds"), _zuo_car(p));+ result = zuo_hash_set(result, zuo_symbol("modify-time-nanoseconds"), _zuo_cdr(p));+ p = zuo_filetime_pair(&info.ftLastAccessTime);
+ result = zuo_hash_set(result, zuo_symbol("access-time-seconds"), _zuo_car(p));+ result = zuo_hash_set(result, zuo_symbol("access-time-nanoseconds"), _zuo_cdr(p));+ }
+#endif
+
+ return result;
+}
+
+static zuo_t *zuo_rm(zuo_t *file_path) {+ const char *who = "rm";
+ check_path_string(who, file_path);
+#ifdef ZUO_UNIX
+ if (unlink(ZUO_STRING_PTR(file_path)) == 0)
+ return z.o_void;
+#endif
+#ifdef ZUO_WINDOWS
+ {+ wchar_t *wp = zuo_to_wide(ZUO_STRING_PTR(file_path));
+ if (_wunlink(wp) == 0) {+ free(wp);
+ return z.o_void;
+ }
+ }
+#endif
+ zuo_fail1w_errno(who, "failed", file_path);
+ return z.o_undefined;
+}
+
+static zuo_t *zuo_mv(zuo_t *from_path, zuo_t *to_path) {+ const char *who = "mv";
+ check_path_string(who, from_path);
+ check_path_string(who, to_path);
+#ifdef ZUO_UNIX
+ if (rename(ZUO_STRING_PTR(from_path), ZUO_STRING_PTR(to_path)) == 0)
+ return z.o_void;
+#endif
+#ifdef ZUO_WINDOWS
+ {+ wchar_t *from_wp = zuo_to_wide(ZUO_STRING_PTR(from_path));
+ wchar_t *to_wp = zuo_to_wide(ZUO_STRING_PTR(to_path));
+ (void)_wunlink(to_wp);
+ if (_wrename(from_wp, to_wp) == 0) {+ free(from_wp);
+ free(to_wp);
+ return z.o_void;
+ }
+ }
+#endif
+ zuo_fail1w_errno(who, "failed", zuo_cons(from_path, zuo_cons(to_path, z.o_null)));
+ return z.o_undefined;
+}
+
+static zuo_t *zuo_mkdir(zuo_t *dir_path) {+ const char *who = "mkdir";
+ check_path_string(who, dir_path);
+#ifdef ZUO_UNIX
+ if (mkdir(ZUO_STRING_PTR(dir_path), 0777) == 0)
+ return z.o_void;
+#endif
+#ifdef ZUO_WINDOWS
+ {+ wchar_t *wp = zuo_to_wide(ZUO_STRING_PTR(dir_path));
+ if (_wmkdir(wp) == 0) {+ free(wp);
+ return z.o_void;
+ }
+ }
+#endif
+ zuo_fail1w_errno(who, "failed", dir_path);
+ return z.o_undefined;
+}
+
+static zuo_t *zuo_rmdir(zuo_t *dir_path) {+ const char *who = "rmdir";
+ check_path_string(who, dir_path);
+#ifdef ZUO_UNIX
+ if (rmdir(ZUO_STRING_PTR(dir_path)) == 0)
+ return z.o_void;
+#endif
+#ifdef ZUO_WINDOWS
+ {+ wchar_t *wp = zuo_to_wide(ZUO_STRING_PTR(dir_path));
+ if (_wrmdir(wp) == 0) {+ free(wp);
+ return z.o_void;
+ }
+ }
+#endif
+ zuo_fail1w_errno(who, "failed", dir_path);
+ return z.o_undefined;
+}
+
+static zuo_t *zuo_ls(zuo_t *dir_path) {+ const char *who = "ls";
+ check_path_string(who, dir_path);
+#ifdef ZUO_UNIX
+ {+ DIR *dir;
+ struct dirent *e;
+ zuo_t *first = z.o_null, *last = NULL, *pr;
+
+ dir = opendir(ZUO_STRING_PTR(dir_path));
+ if (!dir)
+ zuo_fail1w_errno(who, "failed", dir_path);
+
+ while ((e = readdir(dir))) {+ if ((e->d_name[0] == '.')
+ && ((e->d_name[1] == 0)
+ || ((e->d_name[1] == '.')
+ && (e->d_name[2] == 0)))) {+ /* skip */
+ } else {+ pr = zuo_cons(zuo_string(e->d_name), z.o_null);
+ if (last == NULL) first = pr; else ZUO_CDR(last) = pr;
+ last = pr;
+ }
+ }
+
+ closedir(dir);
+
+ return first;
+ }
+#endif
+#ifdef ZUO_WINDOWS
+ {+ wchar_t *wwildpath;
+ HANDLE handle;
+ WIN32_FIND_DATAW fileinfo;
+ char *s;
+ zuo_t *first = z.o_null, *last = NULL, *pr;
+
+ wwildpath = zuo_to_wide(ZUO_STRING_PTR(zuo_build_path2(dir_path, zuo_string("*"))));+
+ handle = FindFirstFileW(wwildpath, &fileinfo);
+
+ if (handle == INVALID_HANDLE_VALUE)
+ zuo_fail1w_errno(who, "failed", dir_path);
+
+ do {+ if ((fileinfo.cFileName[0] == '.')
+ && ((fileinfo.cFileName[1] == 0)
+ || ((fileinfo.cFileName[1] == '.')
+ && (fileinfo.cFileName[2] == 0)))) {+ /* skip */
+ } else {+ s = zuo_from_wide(fileinfo.cFileName);
+ pr = zuo_cons(zuo_string(s), z.o_null);
+ free(s);
+ if (last == NULL) first = pr; else ZUO_CDR(last) = pr;
+ last = pr;
+ }
+ } while (FindNextFileW(handle, &fileinfo));
+ FindClose(handle);
+
+ return first;
+ }
+#endif
+}
+
+static zuo_t *zuo_readlink(zuo_t *link_path) {+ const char *who = "readlink";
+ check_path_string(who, link_path);
+#ifdef ZUO_UNIX
+ {+ int len, buf_len = 256;
+ char *buffer = malloc(buf_len);
+ zuo_t *str;
+
+ while (1) {+ len = readlink(ZUO_STRING_PTR(link_path), buffer, buf_len);
+ if (len == -1) {+ zuo_fail1w_errno(who, "failed", link_path);
+ } else if (len == buf_len) {+ /* maybe too small */
+ free(buffer);
+ buf_len *= 2;
+ buffer = malloc(buf_len);
+ } else
+ break;
+ }
+ str = zuo_sized_string(buffer, len);
+ free(buffer);
+ return str;
+ }
+#endif
+#ifdef ZUO_WINDOWS
+ zuo_fail("readlink: not supported on Windows");+#endif
+ return z.o_undefined;
+}
+
+static zuo_t *zuo_ln(zuo_t *target_path, zuo_t *link_path) {+ const char *who = "symlink";
+ check_path_string(who, target_path);
+ check_path_string(who, link_path);
+#ifdef ZUO_UNIX
+ if (symlink(ZUO_STRING_PTR(target_path), ZUO_STRING_PTR(link_path)) == 0)
+ return z.o_void;
+#endif
+#ifdef ZUO_WINDOWS
+ zuo_fail("symlink: not supported on Windows");+#endif
+ zuo_fail1w_errno(who, "failed", zuo_cons(target_path, zuo_cons(link_path, z.o_null)));
+ return z.o_undefined;
+}
+
+static zuo_t *zuo_cp(zuo_t *src_path, zuo_t *dest_path) {+ const char *who = "cp";
+ check_path_string(who, src_path);
+ check_path_string(who, dest_path);
+#ifdef ZUO_UNIX
+ int src_fd, dest_fd;
+ struct stat st_buf;
+ zuo_int_t len, amt;
+ char *buf;
+
+ EINTR_RETRY(src_fd = open(ZUO_STRING_PTR(src_path), O_RDONLY));
+ if (src_fd == -1)
+ zuo_fail1w_errno(who, "source open failed", src_path);
+
+ if (fstat(src_fd, &st_buf) != 0)
+ zuo_fail1w_errno(who, "source stat failed", src_path);
+
+ /* Permissions may be reduced by umask, but the intent here is to
+ make sure the file doesn't have more permissions than it will end
+ up with: */
+ EINTR_RETRY(dest_fd = open(ZUO_STRING_PTR(dest_path), O_WRONLY | O_CREAT | O_TRUNC, st_buf.st_mode));
+
+ if (dest_fd == -1)
+ zuo_fail1w_errno(who, "destination open failed", dest_path);
+
+ buf = malloc(4096);
+
+ while (1) {+ EINTR_RETRY(amt = read(src_fd, buf, 4096));
+ if (amt == 0)
+ break;
+ if (amt < 0)
+ zuo_fail1w_errno(who, "source read failed", src_path);
+ while (amt > 0) {+ EINTR_RETRY(len = write(dest_fd, buf, amt));
+ if (len < 0)
+ zuo_fail1w_errno(who, "destination write failed", dest_path);
+ amt -= len;
+ }
+ }
+
+ EINTR_RETRY(close(src_fd));
+
+ if (fchmod(dest_fd, st_buf.st_mode) != 0)
+ zuo_fail1w_errno(who, "destination permissions update failed", dest_path);
+
+ EINTR_RETRY(close(dest_fd));
+#endif
+#ifdef ZUO_WINDOWS
+ {+ wchar_t *src_w = zuo_to_wide(ZUO_STRING_PTR(src_path));
+ wchar_t *dest_w = zuo_to_wide(ZUO_STRING_PTR(dest_path));
+ if (!CopyFileW(src_w, dest_w, 0))
+ zuo_fail1w(who, "copy failed to destination", dest_path);
+ free(src_w);
+ free(dest_w);
+ }
+#endif
+ return z.o_void;
+}
+
+zuo_t *zuo_current_time() {+#ifdef ZUO_UNIX
+ /* clock_gettime() provides more precision but ay require linking
+ to an extra library */
+# ifdef USE_CLOCK_REALTIME
+ struct timespec t;
+ if (clock_gettime(CLOCK_REALTIME, &t) != 0)
+ zuo_fail("error getting time");+ return zuo_cons(zuo_integer(t.tv_sec),
+ zuo_integer(t.tv_nsec));
+# else
+ struct timeval t;
+ if (gettimeofday(&t, NULL))
+ zuo_fail("error getting time");+ return zuo_cons(zuo_integer(t.tv_sec),
+ zuo_integer(t.tv_usec * 1000));
+# endif
+#endif
+#ifdef ZUO_WINDOWS
+ FILETIME ft;
+
+ GetSystemTimeAsFileTime(&ft);
+ return zuo_filetime_pair(&ft);
+#endif
+}
+
+/*======================================================================*/
+/* signal handling and cleanables */
+/*======================================================================*/
+
+static int zuo_signal_suspended = 0;
+#ifdef ZUO_WINDOWS
+static LONG zuo_handler_suspended;
+static BOOL WINAPI zuo_signal_received(DWORD op);
+#endif
+
+static zuo_t *zuo_suspend_signal() {+ if (zuo_signal_suspended++ == 0) {+#ifdef ZUO_UNIX
+ sigset_t set;
+ sigemptyset(&set);
+ sigaddset(&set, SIGINT);
+ sigaddset(&set, SIGTERM);
+ sigaddset(&set, SIGHUP);
+ sigprocmask(SIG_BLOCK, &set, NULL);
+#endif
+#ifdef ZUO_WINDOWS
+ LONG old = InterlockedExchange(&zuo_handler_suspended, 1);
+ if (old == -1) {+ /* signal-handling thread is trying to terminate the process,
+ so just wait */
+ Sleep(INFINITE);
+ }
+#endif
+ }
+ return z.o_void;
+}
+
+static zuo_t *zuo_resume_signal() {+ if (zuo_signal_suspended == 0)
+ return z.o_void;
+
+ if (--zuo_signal_suspended == 0) {+#ifdef ZUO_UNIX
+ sigset_t set;
+ sigemptyset(&set);
+ sigaddset(&set, SIGINT);
+ sigaddset(&set, SIGTERM);
+ sigaddset(&set, SIGHUP);
+ sigprocmask(SIG_UNBLOCK, &set, NULL);
+#endif
+#ifdef ZUO_WINDOWS
+ LONG old = InterlockedExchange(&zuo_handler_suspended, 0);
+ if (old == -1) {+ zuo_signal_received(0);
+ }
+#endif
+ }
+ return z.o_void;
+}
+
+static void zuo_clean_all() {+ zuo_t *keys, *l;
+
+ if (Z.o_cleanable_table == z.o_undefined)
+ return; /* must be an error during startup */
+
+ zuo_suspend_signal();
+
+ keys = zuo_trie_keys(Z.o_cleanable_table, z.o_null);
+
+ /* wait for all processes */
+ for (l = keys; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *k = _zuo_car(l);
+ zuo_t *v = trie_lookup(Z.o_cleanable_table, ((zuo_handle_t *)k)->id);
+ if (v->tag == zuo_handle_tag) {+#ifdef ZUO_UNIX
+ int stat_loc;
+ EINTR_RETRY(waitpid(ZUO_HANDLE_RAW(v), &stat_loc, 0));
+#endif
+#ifdef ZUO_WINDOWS
+ WaitForSingleObject(ZUO_HANDLE_RAW(v), INFINITE);
+#endif
+ }
+ }
+
+ /* delete all cleanable files */
+ for (l = keys; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *k = _zuo_car(l);
+ zuo_t *v = trie_lookup(Z.o_cleanable_table, ((zuo_handle_t *)k)->id);
+ if (v->tag == zuo_string_tag) {+#ifdef ZUO_UNIX
+ (void)unlink(ZUO_STRING_PTR(v));
+#endif
+#ifdef ZUO_WINDOWS
+ wchar_t *wp = zuo_to_wide(ZUO_STRING_PTR(v));
+ _wunlink(wp);
+#endif
+ }
+ }
+
+ Z.o_cleanable_table = z.o_empty_hash;
+
+ zuo_resume_signal();
+}
+
+#ifdef ZUO_UNIX
+static void zuo_signal_received() {+ zuo_clean_all();
+ _exit(1);
+}
+#endif
+#ifdef ZUO_WINDOWS
+static BOOL WINAPI zuo_signal_received(DWORD op) {+ if (InterlockedExchange(&zuo_handler_suspended, -1) == 0) {+ zuo_clean_all();
+ _exit(1);
+ }
+ return TRUE;
+}
+#endif
+
+static void zuo_init_signal_handler() {+#ifdef ZUO_UNIX
+ struct sigaction sa;
+ sigemptyset(&sa.sa_mask);
+ sa.sa_flags = SA_RESTART;
+ sa.sa_handler = zuo_signal_received;
+ sigaction(SIGINT, &sa, NULL);
+#endif
+#ifdef ZUO_WINDOWS
+ SetConsoleCtrlHandler(zuo_signal_received, TRUE);
+#endif
+}
+
+/* signal must be suspended */
+static void zuo_register_cleanable(zuo_t *p, zuo_t *v) {+ int added = 0;
+ Z.o_cleanable_table = trie_extend(Z.o_cleanable_table, ((zuo_handle_t *)p)->id, p, v, &added);
+}
+
+/* signal must be suspended */
+static void zuo_unregister_cleanable(zuo_t *p) {+ Z.o_cleanable_table = trie_remove(Z.o_cleanable_table, ((zuo_handle_t *)p)->id, 0);
+}
+
+static zuo_t *zuo_cleanable_file(zuo_t *path) {+ zuo_t *p;
+ check_path_string("cleanable-file", path);+
+ p = zuo_handle(0, zuo_handle_cleanable_status);
+
+ zuo_suspend_signal();
+ zuo_register_cleanable(p, path);
+ zuo_resume_signal();
+
+ return p;
+}
+
+static zuo_t *zuo_cleanable_cancel(zuo_t *p) {+ if ((p->tag != zuo_handle_tag)
+ || (((zuo_handle_t *)p)->u.h.status != zuo_handle_cleanable_status))
+ zuo_fail_arg("cleanable-cancel", "cleanable handle", p);+
+ zuo_suspend_signal();
+ zuo_unregister_cleanable(p);
+ zuo_resume_signal();
+
+ return z.o_void;
+}
+
+/*======================================================================*/
+/* shell command-line parsing */
+/*======================================================================*/
+
+#ifdef ZUO_UNIX
+static char *zuo_string_to_shell_c(const char *s) {+ zuo_intptr_t sz = 32, i = 0;
+ int quoting = 0;
+ unsigned char *p = malloc(sz);
+
+ if (*s == 0) {+ p[i++] = '"';
+ quoting = 1;
+ }
+
+ while (*s) {+ int c = *(unsigned char *)s;
+ s++;
+
+ if (i + 6 >= sz) {+ unsigned char *p2 = malloc(sz * 2);
+ memcpy(p2, p, i);
+ free(p);
+ p = p2;
+ sz *= 2;
+ }
+
+ /* We can afford to be conservative about the characters that a shell
+ may find special */
+ if ((c == '"') || (c == '$') || (c == '`') || (c == '\\') || (c == '!')
+ || (c == '*') || (c == '@') || (c == '^')) {+ if (quoting) {+ p[i++] = '"';
+ quoting = 0;
+ }
+ p[i++] = '\'';
+ p[i++] = c;
+ p[i++] = '\'';
+ } else if (isspace(c) || (c == '\'') || (c == '|') || (c == '&') || (c == ';')
+ || (c == '(') || (c == ')') || (c == '<') || (c == '>')+ || (c == '[') || (c == ']') || (c == '?')
+ || !isprint(c)) {+ if (!quoting) {+ p[i++] = '"';
+ quoting = 1;
+ }
+ p[i++] = c;
+ } else {+ if (quoting) {+ p[i++] = '"';
+ quoting = 0;
+ }
+ p[i++] = c;
+ }
+ }
+ if (quoting)
+ p[i++] = '"';
+
+ p[i] = 0;
+
+ return (char *)p;
+}
+
+static char **zuo_shell_to_strings_c(char *buf, int skip_exe, zuo_intptr_t *_len) {+ zuo_intptr_t i = 0, j = 0, arg_start = 0, cmd = 0;
+ int in_quote = 0, in_squote = 0, did_create = 0;
+ int maxargs = 32;
+ char **command = (char **)malloc((maxargs + 1) * sizeof(char *));
+
+ while (1) {+ int c = ((unsigned char *)buf)[i];
+ if (c == 0)
+ in_quote = in_squote = 0;
+ if (in_quote) {+ if (c == '"') {+ in_quote = 0; i++;
+ } else if (c == '\\') {+ /* a backslash only escapes when before certain characters: */
+ int next_c = ((unsigned char *)buf)[i+1];
+ if ((next_c == '$') || (next_c == '`') || (next_c == '\\') || (next_c == '\n')) {+ buf[j++] = buf[i+1];
+ i += 2;
+ } else {+ buf[j++] = buf[i++];
+ }
+ } else {+ buf[j++] = buf[i++];
+ }
+ } else if (in_squote) {+ if (c == '\'') {+ in_squote = 0; i++;
+ } else {+ buf[j++] = buf[i++];
+ }
+ } else if (c == '"') {+ in_quote = 1; i++;
+ did_create = 1;
+ } else if (c == '\'') {+ in_squote = 1; i++;
+ did_create = 1;
+ } else if (c == '\\') {+ int next_c = ((unsigned char *)buf)[i+1];
+ if (next_c != '\n')
+ buf[j++] = c;
+ i += 2;
+ } else if (isspace(c) || (c == 0)) {+ if ((j > arg_start) || did_create) {+ buf[j++] = 0;
+ if (cmd == maxargs) {+ char **new_command = (char **)malloc((2*maxargs + 1) * sizeof(char *));
+ memcpy(new_command, command, cmd * sizeof(char *));
+ free(command);
+ command = new_command;
+ maxargs *= 2;
+ }
+ command[cmd++] = buf+arg_start;
+ }
+ i++;
+ arg_start = j;
+ did_create = 0;
+ if (c == 0)
+ break;
+ } else
+ buf[j++] = buf[i++];
+ }
+
+ command[cmd] = NULL;
+ *_len = cmd;
+
+ return command;
+}
+#endif
+
+#ifdef ZUO_WINDOWS
+static char *zuo_string_to_shell_c(const char *s) {+ char *naya;
+ int ds;
+ int has_space = 0, has_quote = 0, was_slash = 0;
+
+ if (!*s) return _strdup("\"\""); /* quote an empty argument */+
+ for (ds = 0; s[ds]; ds++) {+ if (isspace(s[ds]) || (s[ds] == '\'')) {+ has_space = 1;
+ was_slash = 0;
+ } else if (s[ds] == '"') {+ has_quote += 1 + (2 * was_slash);
+ was_slash = 0;
+ } else if (s[ds] == '\\') {+ was_slash++;
+ } else
+ was_slash = 0;
+ }
+
+ if (has_space || has_quote) {+ char *p;
+ int wrote_slash = 0;
+
+ naya = malloc(strlen(s) + 3 + 3*has_quote + was_slash);
+ naya[0] = '"';
+ for (p = naya + 1; *s; s++) {+ if (*s == '"') {+ while (wrote_slash--) {+ *(p++) = '\\';
+ }
+ *(p++) = '"'; /* endquote */
+ *(p++) = '\\';
+ *(p++) = '"'; /* protected */
+ *(p++) = '"'; /* start quote again */
+ wrote_slash = 0;
+ } else if (*s == '\\') {+ *(p++) = '\\';
+ wrote_slash++;
+ } else {+ *(p++) = *s;
+ wrote_slash = 0;
+ }
+ }
+ while (wrote_slash--) {+ *(p++) = '\\';
+ }
+ *(p++) = '"';
+ *p = 0;
+
+ return naya;
+ }
+
+ return _strdup(s);
+}
+
+/* This command-line parser is meant to be consistent with the MSVC
+ library for MSVC 2008 and later. The parser was is based on
+ Microsoft documentation plus the missing parsing rule reported at
+ http://daviddeley.com/autohotkey/parameters/parameters.htm#WINCRULES
+ The `skip_exe` flag is needed because an executble name is
+ is parsed differently(!). */
+
+static char **zuo_shell_to_strings_c(char *buf, int starts_exe, zuo_intptr_t *_len) {+ int pos = 0;
+ int maxargs = 32;
+ char **command = (char **)malloc((maxargs + 1) * sizeof(char *));
+ unsigned char *parse, *created, *write;
+ int findquote = 0; /* i.e., inside a quoted block? */
+
+ parse = created = write = (unsigned char *)buf;
+ while (*parse) {+ int did_create = 0;
+ while (*parse && isspace(*parse)) parse++;
+ while (*parse && (!isspace(*parse) || findquote)) {+ if (*parse== '"') {+ if (!starts_exe && findquote && (parse[1] == '"')) {+ parse++;
+ *(write++) = '"';
+ } else {+ findquote = !findquote;
+ did_create = 1;
+ }
+ } else if (!starts_exe && *parse== '\\') {+ unsigned char *next;
+ for (next = parse; *next == '\\'; next++) { }+ if (*next == '"') {+ /* Special handling: */
+ int count = (next - parse), i;
+ for (i = 1; i < count; i += 2) {+ *(write++) = '\\';
+ }
+ parse += (count - 1);
+ if (count & 0x1) {+ *(write++) = '\"';
+ parse++;
+ }
+ } else
+ *(write++) = *parse;
+ } else
+ *(write++) = *parse;
+ parse++;
+ }
+ if (*parse)
+ parse++;
+ *(write++) = 0;
+
+ if (*created || did_create) {+ if (starts_exe > 0)
+ --starts_exe;
+ command[pos++] = (char *)created;
+ if (pos == maxargs) {+ char **c2;
+ c2 = (char **)malloc(((2 * maxargs) + 1) * sizeof(char *));
+ memcpy(c2, command, maxargs * sizeof(char *));
+ maxargs *= 2;
+ }
+ }
+ created = write;
+ }
+
+ command[pos] = NULL;
+ *_len = pos;
+
+ return command;
+}
+#endif
+
+static zuo_t *zuo_string_to_shell(zuo_t *str) {+ char *s;
+
+ check_string("string->shell", str);+
+ s = zuo_string_to_shell_c(ZUO_STRING_PTR(str));
+ str = zuo_string(s);
+ free(s);
+
+ return str;
+}
+
+static zuo_t *zuo_shell_to_strings(zuo_t *str, zuo_t *starts_exe) {+ char *s, **argv;
+ zuo_t *lst;
+ zuo_intptr_t len;
+
+ check_string("shell->strings", str);+ if (starts_exe == z.o_undefined) starts_exe = z.o_false;
+
+ s = zuo_string_to_c(str);
+ argv = zuo_shell_to_strings_c(s, starts_exe != z.o_false, &len);
+
+ for (lst = z.o_null; len--; )
+ lst = zuo_cons(zuo_string(argv[len]), lst);
+
+ free(argv);
+ free(s);
+
+ return lst;
+}
+
+/*======================================================================*/
+/* processes */
+/*======================================================================*/
+
+static void zuo_pipe(zuo_raw_handle_t *_r, zuo_raw_handle_t *_w)
+{+#ifdef ZUO_UNIX
+ {+ int fd[2], r;
+ EINTR_RETRY(r = pipe(fd));
+ if (r != 0)
+ zuo_fail("pipe creation failed");+ *_r = fd[0];
+ *_w = fd[1];
+ }
+#endif
+#ifdef ZUO_WINDOWS
+ {+ HANDLE rh, wh;
+
+ if (!CreatePipe(_r, _w, NULL, 0))
+ zuo_fail("pipe creation failed");+ }
+#endif
+}
+
+zuo_t *zuo_process(zuo_t *command_and_args)
+{+ const char *who = "process";
+ zuo_t *command = _zuo_car(command_and_args);
+ zuo_t *args = _zuo_cdr(command_and_args), *rev_args = z.o_null;
+ zuo_t *options = z.o_empty_hash, *opt;
+ zuo_t *dir, *l, *p_handle, *result;
+ int redirect_in, redirect_out, redirect_err, no_wait;
+ zuo_raw_handle_t pid, in, in_r, out, out_w, err, err_w;
+ int argc = 1, i, ok, can_options = 1;
+ char **argv;
+ void *env;
+ int as_child, exact_cmdline;
+
+ check_path_string(who, command);
+ for (l = args; l->tag == zuo_pair_tag; l = _zuo_cdr(l)) {+ zuo_t *a = _zuo_car(l);
+ if (a == z.o_null) {+ /* skip */
+ } else if ((_zuo_car(l)->tag == zuo_pair_tag)
+ && (zuo_list_p(a) == z.o_true)) {+ /* splice list */
+ if (_zuo_cdr(l) == z.o_null)
+ can_options = 0;
+ l = zuo_cons(a, zuo_append(zuo_cons(a, zuo_cons(_zuo_cdr(l), z.o_null))));
+ } else if (a->tag != zuo_string_tag) {+ if (can_options && _zuo_cdr(l) == z.o_null) {+ options = a;
+ if (options->tag != zuo_trie_node_tag)
+ zuo_fail_arg(who, "string, list, or hash table", options);
+ } else {+ zuo_fail_arg(who, "string or list", a);
+ }
+ } else {+ rev_args = zuo_cons(a, rev_args);
+ argc++;
+ }
+ }
+
+ argv = malloc(sizeof(char*) * (argc + 1));
+
+#ifdef ZUO_UNIX
+ if (!zuo_path_is_absolute(ZUO_STRING_PTR(command))
+ && (_zuo_car(zuo_split_path(command)) == z.o_false))
+ command = zuo_build_raw_path2(zuo_string("."), command);+#endif
+
+ argv[0] = zuo_string_to_c(command);
+ for (i = argc; i-- > 1; ) {+ argv[i] = zuo_string_to_c(_zuo_car(rev_args));
+ rev_args = _zuo_cdr(rev_args);
+ }
+ argv[argc] = NULL;
+
+ redirect_in = redirect_out = redirect_err = 0;
+ in_r = in = zuo_get_std_handle(0);
+ out = out_w = zuo_get_std_handle(1);
+ err = err_w = zuo_get_std_handle(2);
+
+ opt = zuo_consume_option(&options, "stdin");
+ if (opt != z.o_undefined) {+ if (opt == zuo_symbol("pipe")) {+ redirect_in = 1;
+ zuo_pipe(&in_r, &in);
+ } else if ((opt->tag == zuo_handle_tag)
+ && (((zuo_handle_t *)opt)->u.h.status == zuo_handle_open_fd_in_status)) {+ in_r = ZUO_HANDLE_RAW(opt);
+ } else
+ zuo_fail1w(who, "not 'pipe or an open input file descriptor", opt);
+ }
+
+ opt = zuo_consume_option(&options, "stdout");
+ if (opt != z.o_undefined) {+ if (opt == zuo_symbol("pipe")) {+ redirect_out = 1;
+ zuo_pipe(&out, &out_w);
+ } else if ((opt->tag == zuo_handle_tag)
+ && (((zuo_handle_t *)opt)->u.h.status == zuo_handle_open_fd_out_status)) {+ out_w = ZUO_HANDLE_RAW(opt);
+ } else
+ zuo_fail1w(who, "not 'pipe or an open output file descriptor", opt);
+ }
+
+ opt = zuo_consume_option(&options, "stderr");
+ if (opt != z.o_undefined) {+ if (opt == zuo_symbol("pipe")) {+ redirect_err = 1;
+ zuo_pipe(&err, &err_w);
+ } else if ((opt->tag == zuo_handle_tag)
+ && (((zuo_handle_t *)opt)->u.h.status == zuo_handle_open_fd_out_status)) {+ err_w = ZUO_HANDLE_RAW(opt);
+ } else
+ zuo_fail1w(who, "not 'pipe or an open output file descriptor", opt);
+ }
+
+ dir = zuo_consume_option(&options, "dir");
+ if (dir != z.o_undefined)
+ check_path_string(who, dir);
+
+ opt = zuo_consume_option(&options, "env");
+ if (opt != z.o_undefined) {+ zuo_t *l;
+ for (l = opt; l->tag == zuo_pair_tag; l = _zuo_cdr(l)) {+ zuo_t *a = _zuo_car(l), *name, *val;
+ zuo_int_t i;
+
+ if (a->tag != zuo_pair_tag) break;
+ name = _zuo_car(a);
+ if (name->tag != zuo_string_tag) break;
+ for (i = ZUO_STRING_LEN(name); i--; ) {+ int c = ZUO_STRING_PTR(name)[i];
+ if ((c == '=') || (c == 0)) break;
+ }
+ if (i >= 0) break;
+
+ val = _zuo_cdr(a);
+ if (val->tag != zuo_string_tag) break;
+ }
+ if (l != z.o_null)
+ zuo_fail_arg(who, "valid environment variables list", opt);
+ env = zuo_envvars_block(who, opt);
+ } else
+ env = NULL;
+
+ opt = zuo_consume_option(&options, "cleanable?");
+ if (opt == z.o_false)
+ no_wait = 1;
+ else
+ no_wait = 0;
+
+ opt = zuo_consume_option(&options, "exec?");
+ as_child = ((opt == z.o_false) || (opt == z.o_undefined));
+#ifdef ZUO_WINDOWS
+ if (!as_child)
+ zuo_fail1w(who, "'exec? mode not supported", opt);
+#endif
+
+ opt = zuo_consume_option(&options, "exact?");
+ if ((opt == z.o_false) || (opt == z.o_undefined))
+ exact_cmdline = 0;
+ else {+ exact_cmdline = 1;
+ if (argc != 2)
+ zuo_fail1w(who, "too many arguments for 'exact? mode", opt);
+ }
+#ifdef ZUO_UNIX
+ if (exact_cmdline)
+ zuo_fail1w(who, "'exact? mode not suported", opt);
+#endif
+
+ check_options_consumed(who, options);
+
+#ifdef ZUO_UNIX
+ {+ zuo_t *open_fds = zuo_trie_keys(Z.o_fd_table, z.o_null);
+
+ zuo_suspend_signal();
+
+ if (as_child)
+ pid = fork();
+ else {+ zuo_clean_all();
+ pid = 0;
+ }
+
+ if (pid > 0) {+ /* This is the original process, which needs to manage the
+ newly created child process. */
+ ok = 1;
+ } else if (pid == 0) {+ /* This is the new child process */
+ char *msg;
+
+ zuo_resume_signal();
+
+ if (in_r != 0) {+ EINTR_RETRY(dup2(in_r, 0));
+ if (redirect_in)
+ EINTR_RETRY(close(in));
+ }
+ if (out_w != 1) {+ EINTR_RETRY(dup2(out_w, 1));
+ if (redirect_out)
+ EINTR_RETRY(close(out));
+ }
+ if (err_w != 2) {+ EINTR_RETRY(dup2(err_w, 2));
+ if (redirect_err)
+ EINTR_RETRY(close(err));
+ }
+
+ while (open_fds != z.o_null) {+ EINTR_RETRY(close(ZUO_HANDLE_RAW(_zuo_car(open_fds))));
+ open_fds = _zuo_cdr(open_fds);
+ }
+
+ if ((dir == z.o_undefined)
+ || (chdir(ZUO_STRING_PTR(dir)) == 0)) {+ if (env == NULL)
+ execv(argv[0], argv);
+ else
+ execve(argv[0], argv, env);
+ msg = "exec failed\n";
+ } else
+ msg = "chdir failed\n";
+
+ EINTR_RETRY(write(2, msg, strlen(msg)));
+
+ _exit(1);
+ } else {+ ok = 0;
+ }
+ }
+#endif
+#ifdef ZUO_WINDOWS
+ {+ wchar_t *command_w, *cmdline_w, *wd_w;
+ STARTUPINFOW startup;
+ PROCESS_INFORMATION info;
+ DWORD cr_flag;
+
+ if ((dir != z.o_undefined) && !zuo_path_is_absolute(ZUO_STRING_PTR(command)))
+ command = zuo_build_path2(dir, command);
+ command_w = zuo_to_wide(ZUO_STRING_PTR(command));
+
+ if (exact_cmdline)
+ cmdline_w = zuo_to_wide(argv[1]);
+ else {+ char *cmdline;
+ int len = 9;
+
+ for (i = 0; i < argc; i++) {+ char *s = argv[i];
+ argv[i] = zuo_string_to_shell_c(s);
+ free(s);
+ len += strlen(argv[i]) + 1;
+ }
+
+ cmdline = malloc(len);
+
+ len = 0;
+ for (i = 0; i < argc; i++) {+ int alen = strlen(argv[i]);
+ memcpy(cmdline + len, argv[i], alen);
+ cmdline[len + alen] = ' ';
+ len += alen + 1;
+ }
+ cmdline[len-1] = 0;
+
+ cmdline_w = zuo_to_wide(cmdline);
+ free(cmdline);
+ }
+
+ memset(&startup, 0, sizeof(startup));
+ startup.cb = sizeof(startup);
+ startup.dwFlags = STARTF_USESTDHANDLES;
+ startup.hStdInput = in_r;
+ startup.hStdOutput = out_w;
+ startup.hStdError = err_w;
+
+ /* dup handles to make them inheritable */
+ if (!DuplicateHandle(GetCurrentProcess(), startup.hStdInput,
+ GetCurrentProcess(), &startup.hStdInput,
+ 0, 1 /* inherit */,
+ DUPLICATE_SAME_ACCESS))
+ zuo_fail1w(who, "input handle dup failed", command);
+ if (!DuplicateHandle(GetCurrentProcess(), startup.hStdOutput,
+ GetCurrentProcess(), &startup.hStdOutput,
+ 0, 1 /* inherit */,
+ DUPLICATE_SAME_ACCESS))
+ zuo_fail1w(who, "input handle dup failed", command);
+ if (!DuplicateHandle(GetCurrentProcess(), startup.hStdError,
+ GetCurrentProcess(), &startup.hStdError,
+ 0, 1 /* inherit */,
+ DUPLICATE_SAME_ACCESS))
+ zuo_fail1w(who, "input handle dup failed", command);
+
+ /* If none of the stdio handles are consoles, specifically
+ create the subprocess without a console: */
+ if (!zuo_is_terminal(startup.hStdInput)
+ && !zuo_is_terminal(startup.hStdOutput)
+ && !zuo_is_terminal(startup.hStdError))
+ cr_flag = CREATE_NO_WINDOW;
+ else
+ cr_flag = 0;
+ cr_flag |= CREATE_UNICODE_ENVIRONMENT;
+
+ if (dir != z.o_undefined)
+ wd_w = zuo_to_wide(ZUO_STRING_PTR(dir));
+ else
+ wd_w = NULL;
+
+ zuo_suspend_signal();
+
+ ok = CreateProcessW(command_w, cmdline_w,
+ NULL, NULL, 1 /*inherit*/,
+ cr_flag, env, wd_w,
+ &startup, &info);
+
+ free(command_w);
+ free(cmdline_w);
+ if (wd_w != NULL)
+ free(wd_w);
+
+ /* close inheritable dups */
+ CloseHandle(startup.hStdInput);
+ CloseHandle(startup.hStdOutput);
+ CloseHandle(startup.hStdError);
+
+ pid = info.hProcess;
+ }
+#endif
+
+ if (ok) {+ p_handle = zuo_handle(pid, zuo_handle_process_running_status);
+#ifdef ZUO_UNIX
+ {+ int added = 0;
+ Z.o_pid_table = trie_extend(Z.o_pid_table, pid, p_handle, p_handle, &added);
+ }
+#endif
+ if (!no_wait)
+ zuo_register_cleanable(p_handle, p_handle);
+ }
+
+ zuo_resume_signal();
+
+ if (!ok)
+ zuo_fail("exec failed");+
+ if (env != NULL)
+ free(env);
+
+ if (redirect_in)
+ zuo_close(in_r);
+ if (redirect_out)
+ zuo_close(out_w);
+ if (redirect_err)
+ zuo_close(err_w);
+
+ for (i = 0; i < argc; i++)
+ free(argv[i]);
+ free(argv);
+
+ result = z.o_empty_hash;
+ result = zuo_hash_set(result, zuo_symbol("process"), p_handle);+ if (redirect_in)
+ result = zuo_hash_set(result, zuo_symbol("stdin"), zuo_fd_handle(in, zuo_handle_open_fd_out_status));+ if (redirect_out)
+ result = zuo_hash_set(result, zuo_symbol("stdout"), zuo_fd_handle(out, zuo_handle_open_fd_in_status));+ if (redirect_err)
+ result = zuo_hash_set(result, zuo_symbol("stderr"), zuo_fd_handle(err, zuo_handle_open_fd_in_status));+
+ return result;
+}
+
+static int is_process_handle(zuo_t *p) {+ return ((p->tag == zuo_handle_tag)
+ && ((((zuo_handle_t *)p)->u.h.status != zuo_handle_process_done_status)
+ || (((zuo_handle_t *)p)->u.h.status != zuo_handle_process_running_status)));
+}
+
+zuo_t *zuo_process_status(zuo_t *p) {+ if (!is_process_handle(p))
+ zuo_fail_arg("process-status", "process handle", p);+
+ if (((zuo_handle_t *)p)->u.h.status == zuo_handle_process_running_status)
+ return zuo_symbol("running");+ else
+ return zuo_integer(((zuo_handle_t *)p)->u.h.u.result);
+}
+
+zuo_t *zuo_process_wait(zuo_t *pids_i) {+ zuo_t *l;
+
+ for (l = pids_i; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *p = _zuo_car(l);
+ if (!is_process_handle(p))
+ zuo_fail_arg("process-wait", "process handle", p);+ }
+
+#ifdef ZUO_UNIX
+ /* loop until on of the handles is marked as done */
+ while (1) {+ pid_t pid;
+ int stat_loc;
+
+ for (l = pids_i; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *p = _zuo_car(l);
+ if (((zuo_handle_t *)p)->u.h.status == zuo_handle_process_done_status)
+ return p;
+ }
+
+ /* wait for any process to exit, and update the corresponding handle */
+ EINTR_RETRY(pid = wait(&stat_loc));
+
+ /* there's a race here between having completed a wait() and a SIGINT
+ before we update the cleanables table, but it should be harmless,
+ because we won't start any new children in between, and the OS will
+ error for us on a double wait */
+
+ if (pid >= 0) {+ zuo_t *p = trie_lookup(Z.o_pid_table, pid);
+ if (p->tag == zuo_handle_tag) {+ ((zuo_handle_t *)p)->u.h.status = zuo_handle_process_done_status;
+ if (WIFEXITED(stat_loc))
+ ((zuo_handle_t *)p)->u.h.u.result = WEXITSTATUS(stat_loc);
+ else {+ int r = WTERMSIG(stat_loc);
+ if (r == 0) r = 256;
+ ((zuo_handle_t *)p)->u.h.u.result = r;
+ }
+ Z.o_pid_table = trie_remove(Z.o_pid_table, pid, 0);
+ zuo_suspend_signal();
+ zuo_unregister_cleanable(p);
+ zuo_resume_signal();
+ }
+ } else
+ zuo_fail("process wait failed");+ }
+#endif
+#ifdef ZUO_WINDOWS
+ /* loop until on of the handles is marked as done */
+ while (1) {+ HANDLE *a = malloc(sizeof(HANDLE) * zuo_length_int(pids_i));
+ zuo_int_t i = 0;
+
+ for (l = pids_i; l != z.o_null; l = _zuo_cdr(l)) {+ zuo_t *p = _zuo_car(l);
+ if (((zuo_handle_t *)p)->u.h.status == zuo_handle_process_done_status) {+ free(a);
+ return p;
+ } else {+ HANDLE sci = ZUO_HANDLE_RAW(p);
+ DWORD w;
+ if (GetExitCodeProcess(sci, &w)) {+ if (w != STILL_ACTIVE) {+ zuo_suspend_signal();
+ CloseHandle(sci);
+ ((zuo_handle_t *)p)->u.h.status = zuo_handle_process_done_status;
+ ((zuo_handle_t *)p)->u.h.u.result = w;
+ zuo_unregister_cleanable(p);
+ zuo_resume_signal();
+ free(a);
+ return p;
+ }
+ } else
+ zuo_fail1w("process-wait", "status query failed", p);+ a[i++] = sci;
+ }
+ }
+
+ (void)WaitForMultipleObjects(i, a, FALSE, INFINITE);
+ free(a);
+ }
+#endif
+}
+
+/*======================================================================*/
+/* SHA-1 */
+/*======================================================================*/
+
+/* Based on
+ SHA-1 in C
+ By Steve Reid <sreid@sea-to-sky.net>
+ including changes by Saul Kravitz <Saul.Kravitz@celera.com>
+ and Ralph Giles <giles@ghostscript.com> */
+
+static int zuo_little_endian;
+
+static void zuo_init_sha1() {+ zuo_little_endian = ((zuo_magic() & 0xF) == 0);
+}
+
+typedef unsigned char zuo_uint8_t;
+
+typedef struct zuo_sha1_ctx_t {+ unsigned int state[5];
+ unsigned int count[2];
+ unsigned char buffer[64];
+} zuo_sha1_ctx_t;
+
+#define ZUO_SHA1_DIGEST_SIZE 20
+
+#define rol(value, bits) (((value) << (bits)) | ((value) >> (32 - (bits))))
+
+/* blk0() and blk() perform the initial expand; assumes input has been converted to bigendian */
+#define blk0(i) block->l[i]
+#define blk(i) (block->l[i&15] = rol(block->l[(i+13)&15]^block->l[(i+8)&15] \
+ ^block->l[(i+2)&15]^block->l[i&15],1))
+
+/* (R0+R1), R2, R3, R4 are the different operations used in SHA1 */
+#define R0(v,w,x,y,z,i) z+=((w&(x^y))^y)+blk0(i)+0x5A827999+rol(v,5);w=rol(w,30);
+#define R1(v,w,x,y,z,i) z+=((w&(x^y))^y)+blk(i)+0x5A827999+rol(v,5);w=rol(w,30);
+#define R2(v,w,x,y,z,i) z+=(w^x^y)+blk(i)+0x6ED9EBA1+rol(v,5);w=rol(w,30);
+#define R3(v,w,x,y,z,i) z+=(((w|x)&y)|(w&x))+blk(i)+0x8F1BBCDC+rol(v,5);w=rol(w,30);
+#define R4(v,w,x,y,z,i) z+=(w^x^y)+blk(i)+0xCA62C1D6+rol(v,5);w=rol(w,30);
+
+/* Hash a single 512-bit block. This is the core of the algorithm. */
+static void zuo_sha1_transform(zuo_uint32_t state[5], const zuo_uint8_t buffer[64]) {+ zuo_uint32_t a, b, c, d, e;
+ typedef union {+ zuo_uint8_t c[64];
+ zuo_uint32_t l[16];
+ } CHAR64LONG16;
+ CHAR64LONG16 *block;
+
+ block = (CHAR64LONG16 *) buffer;
+
+ if (zuo_little_endian) {+ int i;
+ for (i = 0; i < 16; i++)
+ block->l[i] = (rol(block->l[i], 24) & 0xFF00FF00) | (rol(block->l[i], 8) & 0x00FF00FF);
+ }
+
+ /* Copy context->state[] to working vars */
+ a = state[0];
+ b = state[1];
+ c = state[2];
+ d = state[3];
+ e = state[4];
+
+ /* 4 rounds of 20 operations each. Loop unrolled. */
+ R0(a,b,c,d,e, 0); R0(e,a,b,c,d, 1); R0(d,e,a,b,c, 2); R0(c,d,e,a,b, 3);
+ R0(b,c,d,e,a, 4); R0(a,b,c,d,e, 5); R0(e,a,b,c,d, 6); R0(d,e,a,b,c, 7);
+ R0(c,d,e,a,b, 8); R0(b,c,d,e,a, 9); R0(a,b,c,d,e,10); R0(e,a,b,c,d,11);
+ R0(d,e,a,b,c,12); R0(c,d,e,a,b,13); R0(b,c,d,e,a,14); R0(a,b,c,d,e,15);
+ R1(e,a,b,c,d,16); R1(d,e,a,b,c,17); R1(c,d,e,a,b,18); R1(b,c,d,e,a,19);
+ R2(a,b,c,d,e,20); R2(e,a,b,c,d,21); R2(d,e,a,b,c,22); R2(c,d,e,a,b,23);
+ R2(b,c,d,e,a,24); R2(a,b,c,d,e,25); R2(e,a,b,c,d,26); R2(d,e,a,b,c,27);
+ R2(c,d,e,a,b,28); R2(b,c,d,e,a,29); R2(a,b,c,d,e,30); R2(e,a,b,c,d,31);
+ R2(d,e,a,b,c,32); R2(c,d,e,a,b,33); R2(b,c,d,e,a,34); R2(a,b,c,d,e,35);
+ R2(e,a,b,c,d,36); R2(d,e,a,b,c,37); R2(c,d,e,a,b,38); R2(b,c,d,e,a,39);
+ R3(a,b,c,d,e,40); R3(e,a,b,c,d,41); R3(d,e,a,b,c,42); R3(c,d,e,a,b,43);
+ R3(b,c,d,e,a,44); R3(a,b,c,d,e,45); R3(e,a,b,c,d,46); R3(d,e,a,b,c,47);
+ R3(c,d,e,a,b,48); R3(b,c,d,e,a,49); R3(a,b,c,d,e,50); R3(e,a,b,c,d,51);
+ R3(d,e,a,b,c,52); R3(c,d,e,a,b,53); R3(b,c,d,e,a,54); R3(a,b,c,d,e,55);
+ R3(e,a,b,c,d,56); R3(d,e,a,b,c,57); R3(c,d,e,a,b,58); R3(b,c,d,e,a,59);
+ R4(a,b,c,d,e,60); R4(e,a,b,c,d,61); R4(d,e,a,b,c,62); R4(c,d,e,a,b,63);
+ R4(b,c,d,e,a,64); R4(a,b,c,d,e,65); R4(e,a,b,c,d,66); R4(d,e,a,b,c,67);
+ R4(c,d,e,a,b,68); R4(b,c,d,e,a,69); R4(a,b,c,d,e,70); R4(e,a,b,c,d,71);
+ R4(d,e,a,b,c,72); R4(c,d,e,a,b,73); R4(b,c,d,e,a,74); R4(a,b,c,d,e,75);
+ R4(e,a,b,c,d,76); R4(d,e,a,b,c,77); R4(c,d,e,a,b,78); R4(b,c,d,e,a,79);
+
+ /* Add the working vars back into context.state[] */
+ state[0] += a;
+ state[1] += b;
+ state[2] += c;
+ state[3] += d;
+ state[4] += e;
+}
+
+static void zuo_sha1_init(zuo_sha1_ctx_t *context) {+ /* SHA1 initialization constants */
+ context->state[0] = 0x67452301;
+ context->state[1] = 0xEFCDAB89;
+ context->state[2] = 0x98BADCFE;
+ context->state[3] = 0x10325476;
+ context->state[4] = 0xC3D2E1F0;
+ context->count[0] = context->count[1] = 0;
+}
+
+/* Run your data through this. */
+static void zuo_sha1_update(zuo_sha1_ctx_t *context, const zuo_uint8_t *data, const zuo_intptr_t len) {+ zuo_intptr_t i, j;
+
+ j = (context->count[0] >> 3) & 63;
+ if ((context->count[0] += len << 3) < (len << 3))
+ context->count[1]++;
+ context->count[1] += (len >> 29);
+ if ((j + len) > 63) {+ memcpy(&context->buffer[j], data, (i = 64 - j));
+ zuo_sha1_transform(context->state, context->buffer);
+ for (; i + 63 < len; i += 64)
+ zuo_sha1_transform(context->state, data + i);
+ j = 0;
+ } else
+ i = 0;
+ memcpy(&context->buffer[j], &data[i], len - i);
+}
+
+static int hex_char(int c) {+ return (c < 10) ? (c + '0') : (c + 'a'-10);
+}
+
+/* Add padding and return the message digest. */
+static void zuo_sha1_final(zuo_sha1_ctx_t *context, zuo_uint8_t digest[ZUO_SHA1_DIGEST_SIZE]) {+ zuo_uint32_t i;
+ zuo_uint8_t finalcount[8];
+
+ for (i = 0; i < 8; i++)
+ finalcount[i] = (unsigned char)((context->count[(i >= 4 ? 0 : 1)] >> ((3 - (i & 3)) * 8)) & 255);
+ zuo_sha1_update(context, (zuo_uint8_t *)"\200", 1);
+ while ((context->count[0] & 504) != 448)
+ zuo_sha1_update(context, (zuo_uint8_t *)"\0", 1);
+ zuo_sha1_update(context, finalcount, 8);
+ for (i = 0; i < ZUO_SHA1_DIGEST_SIZE; i++)
+ digest[i] = (zuo_uint8_t)((context->state[i >> 2] >> ((3 - (i & 3)) * 8)) & 255);
+}
+
+static zuo_t *zuo_string_sha1(zuo_t *str) {+ zuo_sha1_ctx_t context;
+ zuo_uint8_t digest[ZUO_SHA1_DIGEST_SIZE];
+ char digest_hex[2 * ZUO_SHA1_DIGEST_SIZE];
+ int i;
+
+ zuo_sha1_init(&context);
+ zuo_sha1_update(&context, (zuo_uint8_t *)ZUO_STRING_PTR(str), ZUO_STRING_LEN(str));
+ zuo_sha1_final(&context, digest);
+
+ for (i = 0; i < ZUO_SHA1_DIGEST_SIZE; i++) {+ digest_hex[2*i] = hex_char(digest[i] >> 4);
+ digest_hex[2*i+1] = hex_char(digest[i] & 0xF);
+ }
+
+ return zuo_sized_string(digest_hex, 2 * ZUO_SHA1_DIGEST_SIZE);
+}
+
+/*======================================================================*/
+/* executable self path */
+/*======================================================================*/
+
+#if defined(__linux__)
+
+# include <errno.h>
+# include <unistd.h>
+
+static char *zuo_self_path_c(const char *exec_file)
+{+ ssize_t len, blen = 256;
+ char *s = malloc(blen);
+
+ while (1) {+ len = readlink("/proc/self/exe", s, blen-1);+ if (len == (blen-1)) {+ free(s);
+ blen *= 2;
+ s = malloc(blen);
+ } else if (len < 0) {+ zuo_fail("failed to get self");+ } else
+ break;
+ }
+ s[len] = 0;
+
+ return s;
+}
+
+#elif defined(__FreeBSD__) || defined(__NetBSD__)
+
+# include <sys/sysctl.h>
+# include <errno.h>
+
+static char *zuo_self_path_c(const char *exec_file)
+{+ int mib[4];
+ char *s;
+ size_t len;
+ int r;
+
+ mib[0] = CTL_KERN;
+#if defined(__NetBSD__)
+ mib[1] = KERN_PROC_ARGS;
+ mib[2] = getpid();
+ mib[3] = KERN_PROC_PATHNAME;
+#else
+ mib[1] = KERN_PROC;
+ mib[2] = KERN_PROC_PATHNAME;
+ mib[3] = -1;
+#endif
+
+ r = sysctl(mib, 4, NULL, &len, NULL, 0);
+ if (r < 0)
+ zuo_fail("failed to get self");+ s = malloc(len);
+ r = sysctl(mib, 4, s, &len, NULL, 0);
+ if (r < 0)
+ zuo_fail("failed to get self");+
+ return s;
+}
+
+#elif defined(__APPLE__) && defined(__MACH__)
+
+# include <mach-o/getsect.h>
+# include <mach-o/dyld.h>
+
+static char *zuo_self_path_c(const char *exec_file)
+{+ uint32_t size = 1024;
+ char *s = malloc(size);
+ int r;
+
+ r = _NSGetExecutablePath(s, &size);
+ if (!r)
+ return s;
+ else {+ free(s);
+ s = malloc(size);
+ r = _NSGetExecutablePath(s, &size);
+ if (!r)
+ return s;
+ zuo_fail("failed to get self");+ return NULL;
+ }
+}
+
+#elif defined(ZUO_WINDOWS)
+
+/* used outside this file: */
+static char *zuo_self_path_c(const char *exec_file)
+{+ wchar_t *path;
+ DWORD r, sz = 1024;
+
+ while (1) {+ path = (wchar_t *)malloc(sz * sizeof(wchar_t));
+ r = GetModuleFileNameW(NULL, path, sz);
+ if ((r == sz)
+ && (GetLastError() == ERROR_INSUFFICIENT_BUFFER)) {+ free(path);
+ sz = 2 * sz;
+ } else
+ break;
+ }
+
+ return zuo_from_wide(path);
+}
+
+#else
+
+/* Generic Unix: get executable path via argv[0] and the `PATH` environment variable */
+
+static int has_slash(const char *s) {+ while (*s) {+ if (s[0] == '/')
+ return 1;
+ s++;
+ }
+ return 0;
+}
+
+static char *zuo_self_path_c(const char *exec_file)
+{+ if (zuo_path_is_absolute(exec_file)) {+ /* Absolute path */
+ return strdup(exec_file);
+ } else if (has_slash(exec_file)) {+ /* Relative path with a directory: */
+ return zuo_string_to_c(zuo_path_to_complete_path(zuo_string(exec_file)));
+ } else {+ /* We have to find the executable by searching PATH: */
+ char *path = strdup(getenv("PATH")), *p;+ zuo_t *m;
+ int more;
+
+ if (!path) {+ path = "";
+ }
+
+ while (1) {+ /* Try each element of path: */
+ for (p = path; *p && (*p != ':'); p++) { }+ if (*p) {+ *p = 0;
+ more = 1;
+ } else
+ more = 0;
+
+ if (!*path)
+ break;
+
+ m = zuo_build_path2(zuo_string(path), zuo_string(exec_file));
+
+ if (access(ZUO_STRING_PTR(m), X_OK) == 0)
+ return zuo_string_to_c(zuo_path_to_complete_path(m));
+
+ if (more)
+ path = p + 1;
+ else
+ break;
+ }
+
+ return strdup(exec_file);
+ }
+}
+
+#endif
+
+static zuo_t *zuo_self_path(const char *exec_file) {+ char *s = zuo_self_path_c(exec_file);
+ zuo_t *str = zuo_string(s);
+ free(s);
+ return str;
+}
+
+/*======================================================================*/
+/* initialization */
+/*======================================================================*/
+
+#define TRIE_SET_TOP_ENV(name, make_prim) \
+ do { \+ if (!will_load_image) { \+ zuo_t *sym = zuo_symbol(name); \
+ zuo_trie_set(z.o_top_env, sym, make_prim); \
+ } else { \+ zuo_t *sym = z.o_undefined; \
+ (void)make_prim; \
+ } \
+ } while (0)
+
+#define ZUO_TOP_ENV_SET_PRIMITIVE0(name, proc) \
+ TRIE_SET_TOP_ENV(name, zuo_primitive0(proc, sym))
+#define ZUO_TOP_ENV_SET_PRIMITIVE1(name, proc) \
+ TRIE_SET_TOP_ENV(name, zuo_primitive1(proc, sym))
+#define ZUO_TOP_ENV_SET_PRIMITIVE2(name, proc) \
+ TRIE_SET_TOP_ENV(name, zuo_primitive2(proc, sym))
+#define ZUO_TOP_ENV_SET_PRIMITIVE3(name, proc) \
+ TRIE_SET_TOP_ENV(name, zuo_primitive3(proc, sym))
+#define ZUO_TOP_ENV_SET_PRIMITIVEa(name, proc) \
+ TRIE_SET_TOP_ENV(name, zuo_primitivea(proc, sym))
+#define ZUO_TOP_ENV_SET_PRIMITIVEb(name, proc) \
+ TRIE_SET_TOP_ENV(name, zuo_primitiveb(proc, sym))
+#define ZUO_TOP_ENV_SET_PRIMITIVEc(name, proc) \
+ TRIE_SET_TOP_ENV(name, zuo_primitivec(proc, sym))
+#define ZUO_TOP_ENV_SET_PRIMITIVEC(name, proc) \
+ TRIE_SET_TOP_ENV(name, zuo_primitiveC(proc, sym))
+#define ZUO_TOP_ENV_SET_PRIMITIVEN(name, proc, mask) \
+ TRIE_SET_TOP_ENV(name, zuo_primitiveN(proc, mask, sym))
+#define ZUO_TOP_ENV_SET_VALUE(name, val) \
+ zuo_trie_set(z.o_top_env, zuo_symbol(name), val)
+
+static void zuo_primitive_init(int will_load_image) {+ zuo_check_sanity();
+
+ zuo_configure();
+ zuo_init_terminal();
+ zuo_init_signal_handler();
+ zuo_init_sha1();
+
+ /* these initial constants and tables might get replaced by loading
+ an image, but we need them to register primitives: */
+ z.o_undefined = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+ z.o_null = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+ z.o_void = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+ z.o_done_k = zuo_cont(zuo_done_cont, z.o_undefined, z.o_undefined, z.o_undefined, z.o_undefined);
+ z.o_intern_table = zuo_trie_node();
+ z.o_top_env = zuo_trie_node();
+
+ zuo_sync_in_case_of_fail();
+
+# if EMBEDDED_IMAGE
+ will_load_image = 1;
+# endif
+
+ ZUO_TOP_ENV_SET_PRIMITIVE1("pair?", zuo_pair_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("null?", zuo_null_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("integer?", zuo_integer_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("string?", zuo_string_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("symbol?", zuo_symbol_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("hash?", zuo_hash_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("list?", zuo_list_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("procedure?", zuo_procedure_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("path-string?", zuo_path_string_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("variable?", zuo_variable_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("handle?", zuo_handle_p);+ ZUO_TOP_ENV_SET_PRIMITIVEN("void", zuo_make_void, -1);+
+ ZUO_TOP_ENV_SET_PRIMITIVE2("cons", zuo_cons);+ ZUO_TOP_ENV_SET_PRIMITIVE1("car", zuo_car);+ ZUO_TOP_ENV_SET_PRIMITIVE1("cdr", zuo_cdr);+ ZUO_TOP_ENV_SET_PRIMITIVE2("list-ref", zuo_list_ref);+ ZUO_TOP_ENV_SET_PRIMITIVE3("list-set", zuo_list_set);+ ZUO_TOP_ENV_SET_PRIMITIVEN("list", zuo_list, -1);+ ZUO_TOP_ENV_SET_PRIMITIVEN("append", zuo_append, -1);+ ZUO_TOP_ENV_SET_PRIMITIVE1("reverse", zuo_reverse);+ ZUO_TOP_ENV_SET_PRIMITIVE1("length", zuo_length);+
+ ZUO_TOP_ENV_SET_PRIMITIVE1("not", zuo_not);+ ZUO_TOP_ENV_SET_PRIMITIVE2("eq?", zuo_eq);+
+ ZUO_TOP_ENV_SET_PRIMITIVEN("+", zuo_add, -1);+ ZUO_TOP_ENV_SET_PRIMITIVEN("-", zuo_subtract, -2);+ ZUO_TOP_ENV_SET_PRIMITIVEN("*", zuo_multiply, -1);+ ZUO_TOP_ENV_SET_PRIMITIVE2("quotient", zuo_quotient);+ ZUO_TOP_ENV_SET_PRIMITIVE2("modulo", zuo_modulo);+ ZUO_TOP_ENV_SET_PRIMITIVE2("<", zuo_lt);+ ZUO_TOP_ENV_SET_PRIMITIVE2("<=", zuo_le);+ ZUO_TOP_ENV_SET_PRIMITIVE2("=", zuo_eql);+ ZUO_TOP_ENV_SET_PRIMITIVE2(">=", zuo_ge);+ ZUO_TOP_ENV_SET_PRIMITIVE2(">", zuo_gt);+ ZUO_TOP_ENV_SET_PRIMITIVE2("bitwise-and", zuo_bitwise_and);+ ZUO_TOP_ENV_SET_PRIMITIVE2("bitwise-ior", zuo_bitwise_ior);+ ZUO_TOP_ENV_SET_PRIMITIVE2("bitwise-xor", zuo_bitwise_xor);+ ZUO_TOP_ENV_SET_PRIMITIVE1("bitwise-not", zuo_bitwise_not);+
+ ZUO_TOP_ENV_SET_PRIMITIVEN("string", zuo_build_string, -1);+ ZUO_TOP_ENV_SET_PRIMITIVE1("string-length", zuo_string_length);+ ZUO_TOP_ENV_SET_PRIMITIVE2("string-ref", zuo_string_ref);+ ZUO_TOP_ENV_SET_PRIMITIVE2("string-u32-ref", zuo_string_u32_ref);+ ZUO_TOP_ENV_SET_PRIMITIVEc("substring", zuo_substring);+ ZUO_TOP_ENV_SET_PRIMITIVE2("string=?", zuo_string_eql);+ ZUO_TOP_ENV_SET_PRIMITIVE2("string-ci=?", zuo_string_ci_eql);+ ZUO_TOP_ENV_SET_PRIMITIVEb("string-split", zuo_string_split);+ ZUO_TOP_ENV_SET_PRIMITIVE1("string->symbol", zuo_string_to_symbol);+ ZUO_TOP_ENV_SET_PRIMITIVE1("string->uninterned-symbol", zuo_string_to_uninterned_symbol);+ ZUO_TOP_ENV_SET_PRIMITIVE1("symbol->string", zuo_symbol_to_string);+ ZUO_TOP_ENV_SET_PRIMITIVEC("string-read", zuo_string_read);+
+ ZUO_TOP_ENV_SET_PRIMITIVEN("hash", zuo_hash, -1);+ ZUO_TOP_ENV_SET_PRIMITIVEc("hash-ref", zuo_hash_ref);+ ZUO_TOP_ENV_SET_PRIMITIVE3("hash-set", zuo_hash_set);+ ZUO_TOP_ENV_SET_PRIMITIVE2("hash-remove", zuo_hash_remove);+ ZUO_TOP_ENV_SET_PRIMITIVE1("hash-keys", zuo_hash_keys);+ ZUO_TOP_ENV_SET_PRIMITIVE1("hash-count", zuo_hash_count);+ ZUO_TOP_ENV_SET_PRIMITIVE2("hash-keys-subset?", zuo_hash_keys_subset_p);+
+ ZUO_TOP_ENV_SET_PRIMITIVE2("opaque", zuo_opaque);+ ZUO_TOP_ENV_SET_PRIMITIVE3("opaque-ref", zuo_opaque_ref);+
+ ZUO_TOP_ENV_SET_PRIMITIVEN("build-path", zuo_build_path, -2);+ ZUO_TOP_ENV_SET_PRIMITIVEN("build-raw-path", zuo_build_raw_path, -2);+ ZUO_TOP_ENV_SET_PRIMITIVE1("split-path", zuo_split_path);+ ZUO_TOP_ENV_SET_PRIMITIVE1("relative-path?", zuo_relative_path_p);+ ZUO_TOP_ENV_SET_PRIMITIVE2("build-module-path", zuo_build_module_path);+
+ ZUO_TOP_ENV_SET_PRIMITIVE1("variable", zuo_make_variable);+ ZUO_TOP_ENV_SET_PRIMITIVE1("variable-ref", zuo_variable_ref);+ ZUO_TOP_ENV_SET_PRIMITIVE2("variable-set!", zuo_variable_set);+
+ ZUO_TOP_ENV_SET_PRIMITIVE1("continuation-prompt-available?", zuo_prompt_avail_p);+
+ ZUO_TOP_ENV_SET_PRIMITIVEb("fd-open-input", zuo_fd_open_input);+ ZUO_TOP_ENV_SET_PRIMITIVEb("fd-open-output", zuo_fd_open_output);+ ZUO_TOP_ENV_SET_PRIMITIVE1("fd-close", zuo_fd_close);+ ZUO_TOP_ENV_SET_PRIMITIVE2("fd-read", zuo_fd_read);+ ZUO_TOP_ENV_SET_PRIMITIVE2("fd-write", zuo_fd_write);+ ZUO_TOP_ENV_SET_PRIMITIVEb("fd-terminal?", zuo_fd_terminal_p);+ ZUO_TOP_ENV_SET_PRIMITIVE1("fd-valid?", zuo_fd_valid_p);+
+ ZUO_TOP_ENV_SET_PRIMITIVEb("stat", zuo_stat);+ ZUO_TOP_ENV_SET_PRIMITIVE1("rm", zuo_rm);+ ZUO_TOP_ENV_SET_PRIMITIVE2("mv", zuo_mv);+ ZUO_TOP_ENV_SET_PRIMITIVE1("mkdir", zuo_mkdir);+ ZUO_TOP_ENV_SET_PRIMITIVE1("rmdir", zuo_rmdir);+ ZUO_TOP_ENV_SET_PRIMITIVE1("ls", zuo_ls);+ ZUO_TOP_ENV_SET_PRIMITIVE2("symlink", zuo_ln);+ ZUO_TOP_ENV_SET_PRIMITIVE1("readlink", zuo_readlink);+ ZUO_TOP_ENV_SET_PRIMITIVE2("cp", zuo_cp);+ ZUO_TOP_ENV_SET_PRIMITIVE0("current-time", zuo_current_time);+
+ ZUO_TOP_ENV_SET_PRIMITIVEN("process", zuo_process, -2);+ ZUO_TOP_ENV_SET_PRIMITIVE1("process-status", zuo_process_status);+ ZUO_TOP_ENV_SET_PRIMITIVEN("process-wait", zuo_process_wait, -2);+ ZUO_TOP_ENV_SET_PRIMITIVE0("suspend-signal", zuo_suspend_signal);+ ZUO_TOP_ENV_SET_PRIMITIVE0("resume-signal", zuo_resume_signal);+ ZUO_TOP_ENV_SET_PRIMITIVE1("string->shell", zuo_string_to_shell);+ ZUO_TOP_ENV_SET_PRIMITIVEb("shell->strings", zuo_shell_to_strings);+ ZUO_TOP_ENV_SET_PRIMITIVE1("string-sha1", zuo_string_sha1);+
+ ZUO_TOP_ENV_SET_PRIMITIVE1("cleanable-file", zuo_cleanable_file);+ ZUO_TOP_ENV_SET_PRIMITIVE1("cleanable-cancel", zuo_cleanable_cancel);+
+ ZUO_TOP_ENV_SET_PRIMITIVEN("error", zuo_error, -1);+ ZUO_TOP_ENV_SET_PRIMITIVEN("alert", zuo_alert, -1);+ ZUO_TOP_ENV_SET_PRIMITIVEN("~v", zuo_tilde_v, -1);+ ZUO_TOP_ENV_SET_PRIMITIVEN("~a", zuo_tilde_a, -1);+ ZUO_TOP_ENV_SET_PRIMITIVEN("~s", zuo_tilde_s, -1);+ ZUO_TOP_ENV_SET_PRIMITIVE3("arg-error", zuo_arg_error);+ ZUO_TOP_ENV_SET_PRIMITIVE2("arity-error", zuo_arity_error);+ ZUO_TOP_ENV_SET_PRIMITIVEa("exit", zuo_exit);+
+ ZUO_TOP_ENV_SET_PRIMITIVE1("module-path?", zuo_module_path_p);+ ZUO_TOP_ENV_SET_PRIMITIVE0("kernel-env", zuo_kernel_env);+
+ ZUO_TOP_ENV_SET_PRIMITIVE0("runtime-env", zuo_runtime_env);+
+ ZUO_TOP_ENV_SET_PRIMITIVE1("dump-image-and-exit", zuo_dump_image_and_exit);+
+ z.o_kernel_read_string = zuo_primitive1(zuo_kernel_read_string, z.o_void);
+ z.o_module_to_hash_star = zuo_primitive1(zuo_module_to_hash_star, z.o_void);
+ z.o_get_read_and_eval = zuo_primitive2(zuo_get_read_and_eval, z.o_void);
+ z.o_register_module = zuo_primitive2(zuo_register_module, z.o_void);
+}
+
+static void zuo_image_init(char *boot_image) {+# if EMBEDDED_IMAGE
+ if (!boot_image) {+ zuo_fasl_restore((char *)emedded_boot_image, emedded_boot_image_len * sizeof(zuo_int32_t));
+ zuo_sync_in_case_of_fail();
+ } else {+# endif
+ if (boot_image) {+ /* The image supplies constants and tables */
+ zuo_raw_handle_t in = zuo_fd_open_input_handle(zuo_string(boot_image), z.o_empty_hash);
+ zuo_t *dump = zuo_drain(in, -1);
+ zuo_close_handle(in);
+ zuo_fasl_restore(ZUO_STRING_PTR(dump), ZUO_STRING_LEN(dump));
+ zuo_sync_in_case_of_fail();
+ } else {+ /* Create remaining constants and tables */
+ z.o_true = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+ z.o_false = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+ z.o_eof = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+ z.o_empty_hash = zuo_trie_node();
+
+ z.o_apply = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+ z.o_call_cc = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+ z.o_call_prompt = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+ z.o_kernel_eval = zuo_new(zuo_singleton_tag, sizeof(zuo_forwarded_t));
+
+ z.o_quote_symbol = zuo_symbol("quote");+ z.o_lambda_symbol = zuo_symbol("lambda");+ z.o_let_symbol = zuo_symbol("let");+ z.o_begin_symbol = zuo_symbol("begin");+ z.o_if_symbol = zuo_symbol("if");+
+ z.o_modules = z.o_null;
+
+ ZUO_TOP_ENV_SET_VALUE("apply", z.o_apply);+ ZUO_TOP_ENV_SET_VALUE("call/cc", z.o_call_cc);+ ZUO_TOP_ENV_SET_VALUE("call/prompt", z.o_call_prompt);+ ZUO_TOP_ENV_SET_VALUE("kernel-eval", z.o_kernel_eval);+ ZUO_TOP_ENV_SET_VALUE("eof", z.o_eof);+
+ {+ zuo_t *module_to_hash = zuo_declare_kernel_module();
+ ZUO_TOP_ENV_SET_VALUE("module->hash", module_to_hash);+ }
+ }
+# if EMBEDDED_IMAGE
+ }
+# endif
+}
+
+static void zuo_runtime_init(zuo_t *lib_path, zuo_t *runtime_env) {+ Z.o_interp_e = Z.o_interp_env = Z.o_interp_v = Z.o_interp_in_proc = z.o_false;
+ Z.o_interp_k = z.o_done_k;
+ Z.o_interp_meta_k = z.o_null;
+ Z.o_pending_modules = z.o_null;
+ Z.o_stash = z.o_false;
+
+#ifdef ZUO_UNIX
+ Z.o_pid_table = z.o_empty_hash;
+ Z.o_fd_table = z.o_empty_hash;
+#endif
+ Z.o_cleanable_table = z.o_empty_hash;
+
+ Z.o_library_path = lib_path; /* should be absolute or #f */
+
+ Z.o_runtime_env = zuo_finish_runtime_env(runtime_env);
+}
+
+/*======================================================================*/
+/* main */
+/*======================================================================*/
+
+#ifndef ZUO_EMBEDDED
+
+int zuo_main(int argc, char **argv) {+ char *load_file = NULL, *library_path = NULL, *boot_image = NULL;
+ char *argv0 = argv[0];
+ zuo_t *exe_path, *load_path, *lib_path;
+
+ argc--;
+ argv++;
+
+ while (argc > 0) {+ if (!strcmp(argv[0], "-h") || !strcmp(argv[0], "--help")) {+ fprintf(stdout, ("\n"+ "usage: %s [<option> ...] [<file-or-dir> <argument> ...]\n"
+ "\n"
+ "If <file-or-dir> is a file, it is used as a module path to load.\n"
+ "If <file-or-dir> is a directory, \"main.zuo\" is loded.\n"
+ "If <file-or-dir> is \"\", a module is read from stdin.\n"
+ "The <argument>s are made available via the `system-env` procedure.\n"
+ "\n"
+ "Supported <option>s:\n"
+ "\n"
+ " -B <file>, --boot <file>\n"
+ " Load dump from <file> as the initial image\n"
+ " -X <dir>, --collects <dir>\n"
+ " Use <dir> as the library-collection root, overriding `ZUO_LIB`;\n"
+ " the default is \"%s\" relative to the executable\n"
+ " -M <file>\n"
+ " Log the path of each opened file to <file>\n"
+ " --\n"
+ " No argument following this switch is used as a switch\n"
+ " -h, --help\n"
+ " Show this information and exit, ignoring other options\n"
+ "\n"
+ "If an <option> switch is provided multiple times, the last\n"
+ "instance takes precedence.\n"
+ "\n"),
+ argv0,
+ ((ZUO_LIB_PATH == NULL) ? "[disabled]" : ZUO_LIB_PATH));
+ exit(0);
+ } else if (!strcmp(argv[0], "-B") || !strcmp(argv[0], "--boot")) {+ if (argc > 1) {+ boot_image = argv[1];
+ argc -= 2;
+ argv += 2;
+ } else {+ zuo_error_color();
+ fprintf(stderr, "%s: expected a path after -B", argv0);
+ zuo_fail("");+ }
+ } else if (!strcmp(argv[0], "-X") || !strcmp(argv[0], "--collects")) {+ if (argc > 1) {+ if (argv[1][0] == 0)
+ zuo_lib_path = NULL;
+ else
+ library_path = argv[1];
+ argc -= 2;
+ argv += 2;
+ } else {+ zuo_error_color();
+ fprintf(stderr, "%s: expected a path after -X", argv0);
+ zuo_fail("");+ }
+ } else if (!strcmp(argv[0], "-M")) {+ if (argc > 1) {+ zuo_file_logging = argv[1];
+ argc -= 2;
+ argv += 2;
+ } else {+ zuo_error_color();
+ fprintf(stderr, "%s: expected a path after -M", argv0);
+ zuo_fail("");+ }
+ } else if (!strcmp(argv[0], "--")) {+ argc--;
+ argv++;
+ break;
+ } else if (argv[0][0] == '-') {+ zuo_error_color();
+ fprintf(stderr, "%s: unrecognized flag: %s", argv0, argv[0]);
+ zuo_fail("");+ } else
+ break;
+ }
+
+ if (argc > 0) {+ load_file = argv[0];
+ argc--;
+ argv++;
+ }
+
+ /* Primitives must be registered before restoring an image */
+ zuo_primitive_init(boot_image != NULL);
+ zuo_image_init(boot_image);
+
+ exe_path = zuo_self_path(argv0);
+
+ if (library_path) {+ lib_path = zuo_path_to_complete_path(zuo_string(library_path));
+ } else if (zuo_lib_path != NULL) {+ lib_path = zuo_string(zuo_lib_path);
+ if (zuo_relative_path_p(lib_path) == z.o_true)
+ lib_path = zuo_build_path2(_zuo_car(zuo_split_path(exe_path)),
+ lib_path);
+ } else
+ lib_path = z.o_false;
+
+ if (load_file == NULL) {+ load_file = "main.zuo";
+ load_path = zuo_string(load_file);
+ if (zuo_stat(load_path, z.o_true) == z.o_false) {+ zuo_error_color();
+ fprintf(stderr, "%s: no file specified, and no \"main.zuo\" found", argv0);
+ zuo_fail("");+ }
+ } else if (load_file[0] != 0) {+ zuo_t *st;
+ load_path = zuo_string(load_file);
+ load_path = zuo_normalize_input_path(load_path);
+ st = zuo_stat(load_path, z.o_true);
+ if ((st != z.o_false)
+ && (zuo_trie_lookup(st, zuo_symbol("type")) == zuo_symbol("dir"))) {+ if (!strcmp(load_file, "."))
+ load_path = zuo_string("main.zuo");+ else
+ load_path = zuo_build_path2(load_path, zuo_string("main.zuo"));+ }
+ } else
+ load_path = zuo_string("stdin");+
+ /* Finish initialization */
+ zuo_runtime_init(lib_path, zuo_make_runtime_env(exe_path, load_file, argc, argv));
+
+ /* Run script */
+ {+ zuo_t *mod_ht, *submods, *main_proc;
+
+ if (load_file[0] == 0) {+ zuo_raw_handle_t in = zuo_fd_open_input_handle(zuo_symbol("stdin"), z.o_empty_hash);+ zuo_t *input = zuo_drain(in, -1);
+ mod_ht = zuo_eval_module(load_path, input);
+ } else
+ mod_ht = zuo_module_to_hash(load_path);
+
+ submods = zuo_trie_lookup(mod_ht, zuo_symbol("submodules"));+ if (submods->tag == zuo_trie_node_tag) {+ main_proc = zuo_trie_lookup(submods, zuo_symbol("main"));+ if (main_proc != z.o_undefined) {+ if (zuo_procedure_p(main_proc) != z.o_true)
+ zuo_fail1("main is not a procedure", main_proc);+ (void)zuo_kernel_eval(zuo_cons(main_proc, z.o_null));
+ }
+ }
+ }
+
+ zuo_exit_int(0);
+ return 0;
+}
+
+# ifdef ZUO_UNIX
+int main(int argc, char **argv) {+ return zuo_main(argc, argv);
+}
+# endif
+# ifdef ZUO_WINDOWS
+# if defined(__MINGW32__)
+int APIENTRY WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance,
+ LPSTR m_lpCmdLine, int nCmdShow) {+ zuo_intptr_t argc;
+ char **argv;
+ argv = zuo_shell_to_strings_c(zuo_from_wide(GetCommandLineW()), 1, &argc);
+ return zuo_main((int)argc, argv);
+}
+# else
+int wmain(int argc, wchar_t **w_argv) {+ char **argv = (char **)malloc(argc * sizeof(char *));
+ int i;
+ for (i = 0; i < argc; i++)
+ argv[i] = zuo_from_wide(w_argv[i]);
+ return zuo_main(argc, argv);
+}
+# endif
+# endif
+
+#endif
+
+/*======================================================================*/
+/* embedded API */
+/*======================================================================*/
+
+#ifdef ZUO_EMBEDDED
+
+void zuo_ext_primitive_init() { zuo_primitive_init(0); }+void zuo_ext_add_primitive(zuo_ext_primitive_t proc, int arity_mask, const char *name) {+ int will_load_image = 0;
+ ZUO_TOP_ENV_SET_PRIMITIVEN(name, proc, arity_mask);
+}
+
+void zuo_ext_image_init(char *boot_image) { zuo_image_init(boot_image); }+
+zuo_ext_t *zuo_ext_false() { return z.o_false; }+zuo_ext_t *zuo_ext_true() { return z.o_true; }+zuo_ext_t *zuo_ext_null() { return z.o_null; }+zuo_ext_t *zuo_ext_void() { return z.o_void; }+zuo_ext_t *zuo_ext_eof() { return z.o_eof; }+zuo_ext_t *zuo_ext_empty_hash() { return z.o_empty_hash; }+zuo_ext_t *zuo_ext_integer(long long i) { return zuo_integer((zuo_int_t)i); }+long long zuo_ext_integer_value(zuo_ext_t *v) { return (long long)ZUO_INT_I(v); }+zuo_ext_t *zuo_ext_cons(zuo_ext_t *car, zuo_ext_t *cdr) { return zuo_cons(car, cdr); }+zuo_ext_t *zuo_ext_car(zuo_ext_t *obj) { return _zuo_car(obj); }+zuo_ext_t *zuo_ext_cdr(zuo_ext_t *obj) { return _zuo_cdr(obj); }+zuo_ext_t *zuo_ext_string(const char *str, long long len) { return zuo_sized_string(str, (zuo_intptr_t)len); }+long long zuo_ext_string_length(zuo_ext_t *str) { return (long long)ZUO_STRING_LEN(str); }+char *zuo_ext_string_ptr(zuo_ext_t *str) { return ZUO_STRING_PTR(str); }+zuo_ext_t *zuo_ext_symbol(const char *str) { return zuo_symbol(str); }+zuo_ext_t *zuo_ext_hash_ref(zuo_ext_t *ht, zuo_ext_t *key, zuo_ext_t *fail) { return zuo_hash_ref(ht, key, fail); }+zuo_ext_t *zuo_ext_hash_set(zuo_ext_t *ht, zuo_ext_t *key, zuo_ext_t *val) { return zuo_hash_set(ht, key, val); }+
+zuo_ext_t *zuo_ext_kernel_env() { return z.o_top_env; }+zuo_ext_t *zuo_ext_apply(zuo_ext_t *proc, zuo_ext_t *args) {+ /* special-case primtives, so this cna be used to perform primitive
+ operations without triggering a GC */
+ if (proc->tag == zuo_primitive_tag) {+ zuo_primitive_t *f = (zuo_primitive_t *)proc;
+ return f->dispatcher(f->proc, args);
+ } else
+ return zuo_kernel_eval(zuo_cons(proc, args));
+}
+
+void zuo_ext_runtime_init(zuo_ext_t *lib_path, zuo_ext_t *runtime_env) { zuo_runtime_init(lib_path, runtime_env); }+
+zuo_ext_t *zuo_ext_eval_module(zuo_ext_t *as_module_path, const char *content, long long len) {+ return zuo_eval_module(as_module_path, zuo_sized_string(content, len));
+}
+
+void zuo_ext_stash_push(zuo_ext_t *v) { Z.o_stash = zuo_cons(v, Z.o_stash); }+zuo_ext_t *zuo_ext_stash_pop() { zuo_t *v = _zuo_car(Z.o_stash); Z.o_stash = _zuo_cdr(Z.o_stash); return v; }+
+#endif
--- /dev/null
+++ b/zuo.h
@@ -1,0 +1,150 @@
+/* This header is used only when embedding Zuo in a larger
+ application, and this file defines the embedding interface.
+
+ To use an embedded Zuo, it must be initialized through the three
+ startup steps below. The space between those steps offer two
+ interposition opportunities: adding primitives before an image
+ (that might rely on the primitives) is loaded, and configuring
+ runtime information that is reported by `runtime-env`. */
+
+#ifndef ZUO_EMBEDDED_H
+#define ZUO_EMBEDDED_H
+
+#ifndef ZUO_EXPORT
+# define ZUO_EXPORT extern
+#endif
+
+/* The type `zuo_ext_t*` represents a Zuo value. All values are
+ subject to garbage collection or relocation during
+ `zuo_eval_module` or a `zuo_ext_apply` of a non-primitive to a
+ primitive that evaluates (`kernel-eval` or `module->hash`). Use
+ `zuo_ext_stash_push` and `zuo_ext_stash_pop` to save something
+ across a potential collection. */
+typedef struct zuo_t zuo_ext_t;
+
+/* ======================================================================== */
+/*
+ Startup step 1: initialize primitives, and maybe add your own.
+
+ Any added primitives will appear in `kernel-env`, as well as being
+ propagated as `zuo/kernel`, `zuo`, etc., initial imports. To ensure
+ that images will work, primitives must be added in the same order,
+ always, and imagines will only work in an environment with the same
+ set of primitives.
+ */
+ZUO_EXPORT void zuo_ext_primitive_init();
+
+/* Add more primitives only after calling `zuo_ext_primitive_init`: */
+typedef zuo_ext_t *(*zuo_ext_primitive_t)(zuo_ext_t *args_list);
+ZUO_EXPORT void zuo_ext_add_primitive(zuo_ext_primitive_t proc, int arity_mask, const char *name);
+
+/* ======================================================================== */
+/*
+ Startup step 2: load a boot image, or initialize with the default
+ or embedded image if `boot_image_file` is NULL.
+*/
+ZUO_EXPORT void zuo_ext_image_init(char *boot_image_file);
+
+/* After calling `zuo_ext_image_init`, the following functions are available: */
+
+/* Functions that get a constant: */
+ZUO_EXPORT zuo_ext_t *zuo_ext_false();
+ZUO_EXPORT zuo_ext_t *zuo_ext_true();
+ZUO_EXPORT zuo_ext_t *zuo_ext_null();
+ZUO_EXPORT zuo_ext_t *zuo_ext_void();
+ZUO_EXPORT zuo_ext_t *zuo_ext_eof();
+ZUO_EXPORT zuo_ext_t *zuo_ext_empty_hash();
+
+/* Other data constructors and accessors: */
+ZUO_EXPORT zuo_ext_t *zuo_ext_integer(long long i);
+ZUO_EXPORT long long zuo_ext_integer_value(zuo_ext_t *v);
+ZUO_EXPORT zuo_ext_t *zuo_ext_cons(zuo_ext_t *car, zuo_ext_t *cdr);
+ZUO_EXPORT zuo_ext_t *zuo_ext_car(zuo_ext_t *obj);
+ZUO_EXPORT zuo_ext_t *zuo_ext_cdr(zuo_ext_t *obj);
+ZUO_EXPORT zuo_ext_t *zuo_ext_string(const char *str, long long len);
+ZUO_EXPORT long long zuo_ext_string_length(zuo_ext_t *str);
+ZUO_EXPORT char *zuo_ext_string_ptr(zuo_ext_t *str);
+ZUO_EXPORT zuo_ext_t *zuo_ext_symbol(const char *str);
+ZUO_EXPORT zuo_ext_t *zuo_ext_hash_ref(zuo_ext_t *ht, zuo_ext_t *key, zuo_ext_t *fail);
+ZUO_EXPORT zuo_ext_t *zuo_ext_hash_set(zuo_ext_t *ht, zuo_ext_t *key, zuo_ext_t *val);
+
+/* To get more functions, use a symbol key to look them up in the
+ kernel environment via `zuo_ext_hash_ref` --- but don't try to
+ load, evaluate, or use any modules, yet: */
+ZUO_EXPORT zuo_ext_t *zuo_ext_kernel_env();
+
+/* At this stage, use `zuo_ext_apply` to apply primitives that don't
+ evaluate. After `zuo_ext_runtime_init`, use this to apply and
+ procedure. Arguments are in a list created with `zuo_ext_cons` and
+ `zuo_ext_null`: */
+ZUO_EXPORT zuo_ext_t *zuo_ext_apply(zuo_ext_t *proc, zuo_ext_t *args);
+
+/* ======================================================================== */
+/*
+ Startup step 3: finalize `runtime-env` and the full path for
+ finding library modules. The `lib_path` argument can be `#f` to
+ disable library loading. The `runtime_env` hash table is used as
+ the starting point for a `runtime-env` result; include 'exe, 'args,
+ and 'script as appropriate; other keys like 'dir are added
+ automatically, while non-standard keys are allowed and preserved.
+*/
+ZUO_EXPORT void zuo_ext_runtime_init(zuo_ext_t *lib_path, zuo_ext_t *runtime_env);
+
+/* After `zuo_ext_runtime_init`, all functionality is available. You
+ can load a module from a file by extracting `module->hash` from the
+ kernel env. Or you can declare and run a module directly from
+ source text, giveing it a module path that is eiter a symbolic
+ library path or a file path. */
+
+ZUO_EXPORT zuo_ext_t *zuo_ext_eval_module(zuo_ext_t *as_module_path, const char *content, long long len);
+
+/* For saving and retriving a value across an evaluation, which is
+ when a GC might happen: */
+ZUO_EXPORT void zuo_ext_stash_push(zuo_ext_t *v);
+ZUO_EXPORT zuo_ext_t *zuo_ext_stash_pop();
+
+#endif
+
+/* Here's a simple example embedding application: */
+#if 0
+
+#include <stdio.h>
+#include <string.h>
+#include "zuo.h"
+
+static zuo_ext_t *random_five(zuo_ext_t *args) {+ return zuo_ext_integer(5);
+}
+
+int main() {+ const char *prog = "#lang zuo/kernel (hash 'number (random-five))";
+ zuo_ext_t *ht, *v;
+
+ /* Step 1 */
+ zuo_ext_primitive_init();
+ zuo_ext_add_primitive(random_five, 1, "random-five");
+
+ /* Step 2 */
+ zuo_ext_image_init(NULL);
+
+ /* Step 3 */
+ zuo_ext_runtime_init(zuo_ext_false(), zuo_ext_empty_hash());
+
+ /* Run `prog`: */
+ ht = zuo_ext_eval_module(zuo_ext_symbol("five-app"), prog, strlen(prog));+
+ /* Inspect the result: */
+ v = zuo_ext_hash_ref(ht, zuo_ext_symbol("number"), zuo_ext_false());+ if (zuo_ext_apply(zuo_ext_hash_ref(zuo_ext_kernel_env(),
+ zuo_ext_symbol("integer?"),+ zuo_ext_false()),
+ zuo_ext_cons(v, zuo_ext_null()))
+ == zuo_ext_true())
+ printf("The answer was %d\n", (int)zuo_ext_integer_value(v));+ else
+ printf("Something went wrong!\n");+
+ return 0;
+}
+
+#endif