├── tests ├── fib.zuo ├── example.zuo ├── example-hygienic.zuo ├── harness.zuo ├── form.zuo ├── harness-hygienic.zuo ├── form-hygienic.zuo ├── fib-hygienic.zuo ├── fib-common.zuo ├── shell.zuo ├── c.zuo ├── macro.zuo ├── opaque.zuo ├── cycle.zuo ├── variable.zuo ├── symbol.zuo ├── main.zuo ├── macro-hygienic.zuo ├── image.zuo ├── syntax-hygienic.zuo ├── syntax.zuo ├── equal.zuo ├── procedure.zuo ├── hash.zuo ├── cleanable.zuo ├── glob.zuo ├── read+print.zuo ├── module-path.zuo ├── macro-common.zuo ├── kernel.zuo ├── string.zuo ├── harness-common.zuo ├── pair.zuo ├── file-handle.zuo ├── integer.zuo ├── filesystem.zuo ├── process.zuo └── path.zuo ├── lib └── zuo │ ├── private │ ├── base │ │ ├── let.zuo │ │ ├── and-or.zuo │ │ ├── define.zuo │ │ ├── struct.zuo │ │ ├── check-dups.zuo │ │ ├── opt-lambda.zuo │ │ ├── quasiquote.zuo │ │ ├── define-help.zuo │ │ ├── more-syntax.zuo │ │ ├── syntax-error.zuo │ │ ├── main.zuo │ │ └── s-exp.zuo │ ├── base-hygienic │ │ ├── let.zuo │ │ ├── and-or.zuo │ │ ├── define.zuo │ │ ├── struct.zuo │ │ ├── check-dups.zuo │ │ ├── define-help.zuo │ │ ├── more-syntax.zuo │ │ ├── opt-lambda.zuo │ │ ├── quasiquote.zuo │ │ ├── syntax-error.zuo │ │ └── main.zuo │ ├── main-hygienic.zuo │ ├── base-common │ │ ├── define.zuo │ │ ├── check-dups.zuo │ │ ├── free-id-eq.zuo │ │ ├── syntax-error.zuo │ │ ├── main.zuo │ │ ├── more-syntax.zuo │ │ ├── lib.zuo │ │ ├── define-help.zuo │ │ ├── parse-lib.zuo │ │ ├── entry.zuo │ │ ├── let.zuo │ │ ├── state.zuo │ │ ├── quasiquote.zuo │ │ ├── and-or.zuo │ │ ├── bind.zuo │ │ ├── struct.zuo │ │ ├── opt-lambda.zuo │ │ └── bind-struct.zuo │ ├── main.zuo │ ├── base.zuo │ ├── base-hygienic.zuo │ ├── pair.zuo │ ├── list.zuo │ ├── looper.zuo │ └── cmdline-run.zuo │ ├── main.zuo │ ├── base.zuo │ ├── hygienic.zuo │ ├── datum.zuo │ ├── shell.zuo │ ├── config.zuo │ ├── c.zuo │ └── thread.zuo ├── local ├── hello.zuo ├── repl.zuo ├── compile.zuo ├── tree.zuo ├── main.zuo └── image.zuo ├── zuo-doc ├── info.rkt ├── fake-kernel.rkt ├── fake-zuo-hygienic.rkt ├── lang-zuo-datum.scrbl ├── zuo.scrbl ├── real-racket.rkt ├── lang-zuo-hygienic.scrbl ├── fake-zuo.rkt └── lang-zuo-kernel.scrbl ├── .gitignore ├── Makefile.in ├── LICENSE.txt ├── main.zuo ├── configure ├── README.md └── zuo.h /tests/fib.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (include "fib-common.zuo") 4 | -------------------------------------------------------------------------------- /tests/example.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (include "example-common.zuo") 4 | -------------------------------------------------------------------------------- /tests/example-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (include "example-common.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/let.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/let.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/and-or.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/and-or.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/define.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/define.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/struct.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/struct.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/check-dups.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/check-dups.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/opt-lambda.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/opt-lambda.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/quasiquote.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/quasiquote.zuo") 4 | -------------------------------------------------------------------------------- /tests/harness.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (define language-name 'zuo/base) 4 | 5 | (include "harness-common.zuo") 6 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/let.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/let.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/define-help.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/define-help.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/more-syntax.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/more-syntax.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base/syntax-error.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (include "../base-common/syntax-error.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/and-or.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/and-or.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/define.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/define.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/struct.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/struct.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/check-dups.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/check-dups.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/define-help.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/define-help.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/more-syntax.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/more-syntax.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/opt-lambda.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/opt-lambda.zuo") 4 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/quasiquote.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/quasiquote.zuo") 4 | -------------------------------------------------------------------------------- /tests/form.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "syntactic forms") 6 | 7 | (include "form-common.zuo") 8 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/syntax-error.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (include "../base-common/syntax-error.zuo") 4 | -------------------------------------------------------------------------------- /tests/harness-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (define language-name 'zuo/hygienic) 4 | 5 | (include "harness-common.zuo") 6 | -------------------------------------------------------------------------------- /lib/zuo/private/base/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | (provide (all-from-out zuo/private/base)) 4 | 5 | (include "../base-common/main.zuo") 6 | -------------------------------------------------------------------------------- /lib/zuo/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/kernel 2 | 3 | (let ([maker (hash-ref (module->hash 'zuo/private/base) 'make-language #f)]) 4 | (maker 'zuo/private/main)) 5 | -------------------------------------------------------------------------------- /lib/zuo/base.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/kernel 2 | 3 | (let ([maker (hash-ref (module->hash 'zuo/private/base) 'make-language #f)]) 4 | (maker 'zuo/private/base/main)) 5 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base-hygienic 2 | 3 | (provide (all-from-out zuo/private/base-hygienic)) 4 | 5 | (include "../base-common/main.zuo") 6 | -------------------------------------------------------------------------------- /tests/form-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (require "harness-hygienic.zuo") 4 | 5 | (alert "syntactic forms, hygienic expander") 6 | 7 | (include "form-common.zuo") 8 | -------------------------------------------------------------------------------- /lib/zuo/private/main-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic/base 2 | 3 | (require zuo/hygienic/cmdline) 4 | 5 | (provide (all-from-out zuo/private/base-hygienic/main 6 | zuo/hygienic/cmdline)) 7 | -------------------------------------------------------------------------------- /local/hello.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | "Hello, world!" 4 | 5 | ;; If you don't want the quotes: 6 | ;; (alert "Hello, world!") 7 | 8 | ;; If you don't want it in blue: 9 | ;; (displayln "Hello, world!") 10 | -------------------------------------------------------------------------------- /tests/fib-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | ;; Performance should be the same as the non-hygienic parsing, but we 4 | ;; may want to check on the startup overhead of `zuo/hygienic` 5 | 6 | (include "fib-common.zuo") 7 | -------------------------------------------------------------------------------- /zuo-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define deps '("base" 4 | "scribble-lib" 5 | "at-exp-lib" 6 | "racket-doc")) 7 | 8 | (define scribblings '(("zuo.scrbl" (multi-page) (language)))) 9 | -------------------------------------------------------------------------------- /lib/zuo/hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/kernel 2 | 3 | (let ([maker (hash-ref (module->hash 'zuo/private/base-hygienic) 'make-language #f)]) 4 | ;; `zuo/hygenic` is analogous to `zuo/base`, not `zuo` 5 | (maker 'zuo/private/base-hygienic/main)) 6 | -------------------------------------------------------------------------------- /zuo-doc/fake-kernel.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define-syntax-rule (define-fake id ...) 4 | (begin 5 | (provide id ...) 6 | (define id 'id) ...)) 7 | 8 | (define-syntax-rule (intro-define-fake) 9 | (define-fake 10 | lambda 11 | let 12 | quote 13 | if 14 | define 15 | begin)) 16 | 17 | (intro-define-fake) 18 | 19 | -------------------------------------------------------------------------------- /zuo-doc/fake-zuo-hygienic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define-syntax-rule (define-fake id ...) 4 | (begin 5 | (provide id ...) 6 | (define id 'id) ...)) 7 | 8 | (define-syntax-rule (intro-define-fake) 9 | (define-fake 10 | identifier? 11 | syntax-e 12 | syntax->datum 13 | datum->syntax 14 | bound-identifier=?)) 15 | 16 | (intro-define-fake) 17 | -------------------------------------------------------------------------------- /lib/zuo/datum.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/kernel 2 | 3 | ;; `#lang zuo/datum` creates a module that just exports S-expressions, 4 | ;; which can useful with `include` for building `zuo` and `zuo/hygienic` 5 | ;; from a shared source 6 | 7 | (hash 'read-and-eval 8 | (lambda (str start mod-path) 9 | (let ([es (string-read str start mod-path)]) 10 | (hash 'datums es)))) 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /zuo 2 | /zuo.dSYM 3 | /zuo.exe 4 | /zuo.obj 5 | /zuo.o 6 | 7 | /build 8 | 9 | compiled/ 10 | 11 | # common backups, autosaves, lock files, OS meta-files 12 | *~ 13 | \#* 14 | .#* 15 | .DS_Store 16 | *.bak 17 | TAGS 18 | *.swn 19 | *.swo 20 | *.swp 21 | .gdb_history 22 | /.vscode/ 23 | 24 | # generated by patch 25 | *.orig 26 | *.rej 27 | 28 | # coredumps 29 | *.core 30 | -------------------------------------------------------------------------------- /Makefile.in: -------------------------------------------------------------------------------- 1 | # `configure` adds lines before to record configuration 2 | 3 | .PHONY: zuos-to-run-and-install 4 | zuos-to-run-and-install: zuo 5 | ./zuo . zuos-to-run-and-install 6 | 7 | zuo: $(srcdir)/zuo.c 8 | $(CC) $(CPPFLAGS) $(CFLAGS) -DZUO_LIB_PATH='"'"$(srcdir)/lib"'"' -o zuo $(srcdir)/zuo.c $(LDFLAGS) $(LIBS) 9 | 10 | .PHONY: install 11 | install: zuo 12 | ./zuo . install 13 | -------------------------------------------------------------------------------- /tests/fib-common.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; The classic toy benchmark 4 | (provide fib) 5 | 6 | (define input 7 | (let ([args (hash-ref (runtime-env) 'args)]) 8 | (if (null? args) 9 | 30 10 | (string->integer (car args))))) 11 | 12 | (define (fib n) 13 | (cond 14 | [(= n 0) 1] 15 | [(= n 1) 1] 16 | [else (+ (fib (- n 1)) (fib (- n 2)))])) 17 | 18 | (fib input) 19 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/define.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "define-help.zuo" 4 | "opt-lambda.zuo") 5 | 6 | (provide (rename-out [define-var-or-proc define] 7 | [define-syntax-var-or-proc define-syntax])) 8 | 9 | (define-syntax define-var-or-proc 10 | (make-define (quote-syntax define) (quote-syntax lambda))) 11 | 12 | (define-syntax define-syntax-var-or-proc 13 | (make-define (quote-syntax define-syntax) (quote-syntax lambda))) 14 | -------------------------------------------------------------------------------- /zuo-doc/lang-zuo-datum.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title{Zuo Data as Module} 4 | 5 | @defmodulelang[zuo/datum] 6 | 7 | A module in the @racketmodname[zuo/datum] language ``exports'' its 8 | content as a list of S-expressions. The export is not a 9 | @racket[provide] in the sense of the @racketmodname[zuo] language. 10 | Instead, the module's representation (see @secref["module-protocol"]) 11 | is just a hash table mapping @racket['datums] to the list of 12 | S-expressions. 13 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | This component of Racket is distributed under the under the Apache 2.0 2 | and MIT licenses. The user can choose the license under which they 3 | will be using the software. There may be other licenses within the 4 | distribution with which the user must also comply. 5 | 6 | See the files 7 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 8 | and 9 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 10 | for the full text of the licenses. 11 | -------------------------------------------------------------------------------- /tests/shell.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "shell") 6 | 7 | (define unix? (eq? (hash-ref (runtime-env) 'system-type) 'unix)) 8 | 9 | (when unix? 10 | (let ([p (shell "echo hi" (hash 'stdout 'pipe))]) 11 | (check (fd-read (hash-ref p 'stdout) eof) "hi\n") 12 | (fd-close (hash-ref p 'stdout)) 13 | (process-wait (hash-ref p 'process)) 14 | (check (process-status (hash-ref p 'process)) 0))) 15 | 16 | (check (build-shell "x" "" "y" "" "" "z" "") "x y z") 17 | -------------------------------------------------------------------------------- /lib/zuo/private/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | 3 | (require zuo/cmdline 4 | zuo/config 5 | zuo/thread 6 | zuo/build 7 | zuo/shell 8 | zuo/c 9 | zuo/glob) 10 | 11 | (provide (all-from-out zuo/private/base/main 12 | zuo/cmdline 13 | zuo/config 14 | zuo/thread 15 | zuo/build 16 | zuo/shell 17 | zuo/c 18 | zuo/glob)) 19 | -------------------------------------------------------------------------------- /tests/c.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "c") 6 | 7 | (check (config-merge (hash 'CFLAGS "-O2") 'CFLAGS "-g") 8 | (hash 'CFLAGS "-O2 -g")) 9 | 10 | (check (config-define (hash 'CFLAGS "-O2") "ZUO") 11 | (hash 'CFLAGS "-O2" 'CPPFLAGS "-DZUO")) 12 | 13 | (check (config-define (hash 'CPPFLAGS "-DSLOW") "ZUO") 14 | (hash 'CPPFLAGS "-DSLOW -DZUO")) 15 | 16 | (check (config-include (hash 'CPPFLAGS "-DSLOW") "zuo/private") 17 | (hash 'CPPFLAGS "-DSLOW -Izuo/private")) 18 | -------------------------------------------------------------------------------- /tests/macro.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "macros") 6 | 7 | (define lang-name 'zuo) 8 | 9 | (include "macro-common.zuo") 10 | 11 | (let ([five 5]) 12 | (define-syntax (let-five stx) 13 | (list (quote-syntax let) 14 | (list (list (cadr stx) 'five)) ; can get captured 15 | (cadr (cdr stx)))) 16 | (check (let-five x (list x x)) '(5 5)) 17 | (check (let-five x (let ([five 10]) (list x x))) '(5 5)) 18 | (check (let ([five 10]) (let-five x (list x x))) '(10 10))) 19 | 20 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/check-dups.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "and-or.zuo" 4 | "syntax-error.zuo" 5 | "../list.zuo") 6 | 7 | (provide check-duplicates) 8 | 9 | (define check-duplicates 10 | (lambda (args) 11 | (foldl (lambda (id seen) 12 | (when (ormap (lambda (seen-id) 13 | (bound-identifier=? id seen-id)) 14 | seen) 15 | (duplicate-identifier id)) 16 | (cons id seen)) 17 | '() 18 | args))) 19 | -------------------------------------------------------------------------------- /lib/zuo/private/base.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/stitcher 2 | 3 | ;; Instantiates the expander for non-hygenic-by-default macros 4 | 5 | (define macro-protocol 'defmacro) 6 | (define merge-bindings-export-key 'defmacro-bindings) 7 | (define language-mod-path 'zuo/private/base) 8 | 9 | (include "base-common/lib.zuo") 10 | (include "base-common/bind-struct.zuo") 11 | (include "base-common/state.zuo") 12 | 13 | (include "base/s-exp.zuo") 14 | 15 | (include "base-common/bind.zuo") 16 | (include "base-common/parse.zuo") 17 | (include "base-common/entry.zuo") 18 | -------------------------------------------------------------------------------- /lib/zuo/private/base-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/stitcher 2 | 3 | ;; Instantiates the expander for hygienic, set-of-scopes macros 4 | 5 | (define macro-protocol 'scope-sets) 6 | (define merge-bindings-export-key 'scope-sets-bindings) 7 | (define language-mod-path 'zuo/private/base-hygienic) 8 | 9 | (include "base-common/lib.zuo") 10 | (include "base-common/bind-struct.zuo") 11 | (include "base-common/state.zuo") 12 | 13 | (include "base-hygienic/syntax.zuo") 14 | 15 | (include "base-common/bind.zuo") 16 | (include "base-common/parse.zuo") 17 | (include "base-common/entry.zuo") 18 | -------------------------------------------------------------------------------- /tests/opaque.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "opaque records") 6 | 7 | (check (not (pair? (opaque 'hello "hi")))) 8 | 9 | (check (opaque-ref 'hello (opaque 'hello "hi") #f) "hi") 10 | (check (opaque-ref 'not-hello (opaque 'hello "hi") #f) #f) 11 | (check (opaque-ref (string->uninterned-symbol "hello") (opaque 'hello "hi") #f) #f) 12 | (check (opaque-ref 'hello (opaque (string->uninterned-symbol "hello") "hi") #f) #f) 13 | (check (opaque-ref (opaque 'hello "hi") 'hello #f) #f) 14 | (check (opaque-ref 10 10 #f) #f) 15 | (check (opaque-ref 10 10 'no) 'no) 16 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/free-id-eq.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (define free-id=? 4 | (lambda (binds id1 id2) 5 | (let* ([bind1 (resolve* binds id1 #f)] 6 | [bind2 (resolve* binds id2 #f)]) 7 | (or (specific=? bind1 bind2) 8 | (and (not bind1) 9 | (not bind2) 10 | (eq? (syntax-e id1) (syntax-e id2))))))) 11 | 12 | (define (apply-macro* proc s name free-id=?) 13 | (let ([c-proc (context-consumer-procedure proc)]) 14 | (if c-proc 15 | (c-proc s free-id=? (and name (symbol->string (syntax-e name)))) 16 | (proc s)))) 17 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/syntax-error.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (provide syntax-error 4 | bad-syntax 5 | misplaced-syntax 6 | duplicate-identifier) 7 | 8 | (define syntax-error 9 | (lambda (msg stx) 10 | (error (~a msg ": " (~s (syntax->datum stx)))))) 11 | 12 | (define bad-syntax 13 | (lambda (stx) 14 | (syntax-error "bad syntax" stx))) 15 | 16 | (define misplaced-syntax 17 | (lambda (stx) 18 | (syntax-error "misplaced syntax" stx))) 19 | 20 | (define duplicate-identifier 21 | (lambda (stx) 22 | (syntax-error "duplicate identifier" stx))) 23 | -------------------------------------------------------------------------------- /zuo-doc/zuo.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title{Zuo: A Tiny Racket for Scripting} 4 | 5 | You should use Racket to write scripts. But for the case where you 6 | need something much smaller than Racket for some reason, or the case 7 | you're trying to script the build of Racket itself, Zuo is a tiny 8 | Racket with primitives for dealing with files and running processes. 9 | 10 | @table-of-contents[] 11 | 12 | @include-section["overview.scrbl"] 13 | @include-section["lang-zuo.scrbl"] 14 | @include-section["zuo-lib.scrbl"] 15 | @include-section["lang-zuo-hygienic.scrbl"] 16 | @include-section["lang-zuo-datum.scrbl"] 17 | @include-section["lang-zuo-kernel.scrbl"] 18 | -------------------------------------------------------------------------------- /tests/cycle.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "cycle") 6 | 7 | (define cycle-file (build-path tmp-dir "cycle.zuo")) 8 | 9 | (define out (fd-open-output cycle-file :truncate)) 10 | (fd-write out (~a "#lang zuo\n" 11 | "(require \"cycle.zuo\")\n")) 12 | (fd-close out) 13 | 14 | (check (run-zuo `(require ,(if (relative-path? cycle-file) 15 | (build-path (hash-ref (runtime-env) 'dir) cycle-file) 16 | cycle-file)) 17 | (lambda (status out err) 18 | (and (not (= status 0)) 19 | (equal? out "") 20 | (contains? err "cycle in module loading"))))) 21 | 22 | -------------------------------------------------------------------------------- /tests/variable.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "variables") 6 | 7 | (check (variable? (variable 'alice))) 8 | (check (not (variable? 'alice))) 9 | 10 | (check-fail (variable-ref (variable 'alice)) "undefined: alice") 11 | (check-fail (variable-ref 'alice) "not a variable") 12 | 13 | (check (let ([a (variable 'alice)]) 14 | (variable-set! a 'home) 15 | (list (variable-ref a) (variable-ref a))) 16 | '(home home)) 17 | (check-fail (let ([a (variable 'alice)]) 18 | (variable-set! a 'home) 19 | (variable-set! a 'home)) 20 | "variable already has a value") 21 | (check-fail (variable-set! 'alice 'home) "not a variable") 22 | 23 | (check-arg-fail (variable 10) "not a symbol") 24 | -------------------------------------------------------------------------------- /tests/symbol.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "symbols") 6 | 7 | (check (symbol? 'apple)) 8 | (check (symbol? (string->uninterned-symbol "apple"))) 9 | (check (not (symbol? "apple"))) 10 | (check (not (symbol? 10))) 11 | 12 | (check (symbol->string 'apple) "apple") 13 | (check-arg-fail (symbol->string "apple") "not a symbol") 14 | 15 | (check (eq? 'apple (string->symbol "apple"))) 16 | (check (not (eq? 'apple (string->uninterned-symbol "apple")))) 17 | (check (not (eq? (string->uninterned-symbol "apple") 18 | (string->uninterned-symbol "apple")))) 19 | (check (not (equal? 'apple (string->uninterned-symbol "apple")))) 20 | (check-arg-fail (string->symbol 'apple) not-string) 21 | (check-arg-fail (string->uninterned-symbol 'apple) not-string) 22 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "and-or.zuo" 4 | "syntax-error.zuo" 5 | "../pair.zuo" 6 | "../list.zuo" 7 | "let.zuo" 8 | "define.zuo" 9 | "opt-lambda.zuo" 10 | "quasiquote.zuo" 11 | "more-syntax.zuo" 12 | "../more.zuo" 13 | "struct.zuo") 14 | 15 | (provide (all-from-out "and-or.zuo" 16 | "syntax-error.zuo" 17 | "../pair.zuo" 18 | "../list.zuo" 19 | "let.zuo" 20 | "define.zuo" 21 | "opt-lambda.zuo" 22 | "quasiquote.zuo" 23 | "more-syntax.zuo" 24 | "../more.zuo" 25 | "struct.zuo")) 26 | -------------------------------------------------------------------------------- /tests/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "equal.zuo") 4 | (require "integer.zuo") 5 | (require "pair.zuo") 6 | (require "string.zuo") 7 | (require "symbol.zuo") 8 | (require "hash.zuo") 9 | (require "procedure.zuo") 10 | (require "path.zuo") 11 | (require "opaque.zuo") 12 | (require "variable.zuo") 13 | (require "module-path.zuo") 14 | (require "kernel.zuo") 15 | (require "read+print.zuo") 16 | (require "syntax.zuo") 17 | (require "syntax-hygienic.zuo") 18 | (require "file-handle.zuo") 19 | (require "process.zuo") 20 | (require "filesystem.zuo") 21 | (require "cleanable.zuo") 22 | (require "image.zuo") 23 | (require "shell.zuo") 24 | (require "c.zuo") 25 | (require "cycle.zuo") 26 | (require "form.zuo") 27 | (require "form-hygienic.zuo") 28 | (require "macro.zuo") 29 | (require "macro-hygienic.zuo") 30 | 31 | (alert "... tests passed!") 32 | -------------------------------------------------------------------------------- /zuo-doc/real-racket.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | (require scribble/manual 3 | (for-syntax racket/base) 4 | (for-label racket/base 5 | racket/contract/base 6 | racket/cmdline)) 7 | 8 | (provide realracket 9 | realracket* 10 | (for-label any/c 11 | listof 12 | ->)) 13 | 14 | (define-syntax (realracket stx) 15 | (syntax-case stx () 16 | [(_ id) @#`racket[#,(datum->syntax #'here (syntax-e #'id))]])) 17 | 18 | (define-syntax (realracket* stx) 19 | (syntax-case stx () 20 | [(_ id) @#'realracket[id]] 21 | [(_ id1 id2) @#'elem{@realracket[id1] and @realracket[id2]}] 22 | [(_ id1 id2 id3) @#'elem{@realracket[id1], @realracket[id2], and @realracket[id3]}] 23 | [(_ id0 id ...) @#'elem{@realracket[id0], @realracket*[id ...]}])) 24 | 25 | 26 | -------------------------------------------------------------------------------- /main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (for-each 4 | alert 5 | (append 6 | (list "" 7 | "Welcome to Zuo!" 8 | "" 9 | "This message is from \"main.zuo\"." 10 | "" 11 | "Probably, you're seeing this message because you ran Zuo with no arguments," 12 | "in which case \"main.zuo\" in the current directory is loaded by default." 13 | "" 14 | "If you want to run your own program, supply the program's path as an argument." 15 | "A program file will start with `#lang`, and most likely it starts `#lang zuo`." 16 | "Additional arguments are made available to the target program through the" 17 | "`command-line-arguments` procedure (in languages like `#lang zuo`, at least)." 18 | "" 19 | "If you want to type in a program directly, supply the empty string \"\" in" 20 | "place of a file path. You'll still need to start the program with something" 21 | "like `#lang zuo`." 22 | ""))) 23 | -------------------------------------------------------------------------------- /tests/macro-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (require "harness-hygienic.zuo") 4 | 5 | (alert "macros, hygienic expander") 6 | 7 | (define lang-name 'zuo/hygienic) 8 | 9 | (include "macro-common.zuo") 10 | 11 | (define module-five 5) 12 | (define-syntax (let-module-five stx) 13 | (list (quote-syntax let) 14 | (list (list (cadr stx) 'module-five)) ; coerced to defining context 15 | (cadr (cdr stx)))) 16 | (check (let-module-five x (list x x)) '(5 5)) 17 | (check (let-module-five x (let ([module-five 10]) (list x x))) '(5 5)) 18 | (check (let ([module-five 10]) (let-module-five x (list x x))) '(5 5)) 19 | 20 | (let ([five 5]) 21 | (define-syntax (let-five stx) 22 | (list (quote-syntax let) 23 | (list (list (cadr stx) (datum->syntax (car stx) 'five))) ; non-hygienic 24 | (cadr (cdr stx)))) 25 | (check (let-five x (list x x)) '(5 5)) 26 | (check (let-five x (let ([five 10]) (list x x))) '(5 5)) 27 | (check (let ([five 10]) (let-five x (list x x))) '(10 10))) 28 | 29 | -------------------------------------------------------------------------------- /tests/image.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "image") 6 | 7 | (define dump.zuo (build-path tmp-dir "dump.zuo")) 8 | (define image-file (build-path tmp-dir "image.boot")) 9 | 10 | (define (try-dump lang) 11 | (define out (fd-open-output dump.zuo :truncate)) 12 | (fd-write out (~a "#lang " lang "\n" 13 | "(dump-image-and-exit (fd-open-output (car (hash-ref (runtime-env) 'args)) :truncate))\n")) 14 | (fd-close out) 15 | 16 | (check (run-zuo* (list dump.zuo image-file) 17 | "" 18 | (lambda (status out err) 19 | (= status 0)))) 20 | (run-zuo* (list "-X" "" "-B" image-file "") 21 | (~a "#lang " lang " 10") 22 | (lambda (status out err) 23 | (check (and (= status 0) lang) lang) 24 | (check out "10\n") 25 | (check err "")))) 26 | 27 | (try-dump "zuo") 28 | (try-dump "zuo/hygienic") 29 | 30 | (check-arg-fail (dump-image-and-exit "oops") "open output file") 31 | -------------------------------------------------------------------------------- /local/repl.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | ;; Zuo is really not for interctive evaluation, but `kernel-eval` does 4 | ;; exist... 5 | 6 | (alert "REPL for single-line kernel expressions:") 7 | (define in (fd-open-input 'stdin)) 8 | (define out (fd-open-output 'stdout (hash))) 9 | (fd-write out "> ") 10 | (let loop ([pending ""]) 11 | (define line-end (let loop ([i 0]) 12 | (cond 13 | [(= i (string-length pending)) #f] 14 | [(= (string-ref pending i) (char "\n")) (+ i 1)] 15 | [else (loop (+ i 1))]))) 16 | (define (read-and-eval s) 17 | (for-each (lambda (e) 18 | (alert (~v (kernel-eval e)))) 19 | (string-read s))) 20 | (cond 21 | [line-end 22 | (read-and-eval (substring pending 0 line-end)) 23 | (fd-write out "> ") 24 | (loop (substring pending line-end (string-length pending)))] 25 | [else 26 | (define input (fd-read in 1)) 27 | (if (eq? input eof) 28 | (read-and-eval pending) 29 | (loop (~a pending input)))])) 30 | -------------------------------------------------------------------------------- /local/compile.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (provide compile-c) 4 | 5 | (define (compile-c exe-file c-file c-flags config compile-wait) 6 | (define (lookup key) (hash-ref config key "")) 7 | (define exe-h (cleanable-file exe-file)) 8 | (define command (string-join 9 | (filter 10 | (lambda (s) (not (equal? s ""))) 11 | (list (lookup 'CC) 12 | (string-join (map string->shell c-flags)) 13 | (lookup 'CPPFLAGS) 14 | (lookup 'CFLAGS) 15 | (if (eq? 'windows (hash-ref (runtime-env) 'system-type)) "/Fe:" "-o") 16 | (string->shell exe-file) 17 | (string->shell c-file) 18 | (lookup 'LDFLAGS) 19 | (lookup 'LIBS))))) 20 | (displayln command) 21 | (define p (shell command)) 22 | (compile-wait (hash-ref p 'process)) 23 | (unless (= 0 (process-status (hash-ref p 'process))) 24 | (error "error from C compiler")) 25 | (cleanable-cancel exe-h)) 26 | 27 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/more-syntax.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "and-or.zuo" 4 | "../pair.zuo" 5 | "../list.zuo" 6 | "define.zuo" 7 | "syntax-error.zuo") 8 | 9 | (provide char 10 | at-source) 11 | 12 | (define-syntax (char stx) 13 | (if (and (list? stx) 14 | (= 2 (length stx)) 15 | (string? (cadr stx)) 16 | (= 1 (string-length (cadr stx)))) 17 | (string-ref (cadr stx) 0) 18 | (bad-syntax stx))) 19 | 20 | (define (combine-path base) 21 | (lambda paths 22 | (for-each (lambda (path) 23 | (unless (and (path-string? path) 24 | (relative-path? path)) 25 | (arg-error 'at-source "relative path string" path))) 26 | paths) 27 | (apply build-path (cons (or (car (split-path base)) ".") paths)))) 28 | 29 | (define-syntax (at-source stx) 30 | (if (list? stx) 31 | (cons (quote-syntax (combine-path (quote-module-path))) 32 | (cdr stx)) 33 | (if (identifier? stx) 34 | (quote-syntax (combine-path (quote-module-path))) 35 | (bad-syntax stx)))) 36 | 37 | -------------------------------------------------------------------------------- /lib/zuo/private/pair.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/private/base 2 | 3 | ;; This module could be implemented in either `base` or 4 | ;; `base-hygienic`, but use use `base` to keep it faster 5 | ;; (at least for `base`-only programs) 6 | 7 | (provide caar 8 | cadr 9 | cdar 10 | cddr) 11 | 12 | (define bad 13 | (lambda (who v) 14 | (error (~a who ": not a valid argument") v))) 15 | 16 | (define caar 17 | (lambda (v) 18 | (if (pair? v) 19 | (let ([a (car v)]) 20 | (if (pair? a) 21 | (car a) 22 | (bad 'caar v))) 23 | (bad 'caar v)))) 24 | 25 | (define cadr 26 | (lambda (v) 27 | (if (pair? v) 28 | (let ([d (cdr v)]) 29 | (if (pair? d) 30 | (car d) 31 | (bad 'cadr v))) 32 | (bad 'cadr v)))) 33 | 34 | (define cdar 35 | (lambda (v) 36 | (if (pair? v) 37 | (let ([a (car v)]) 38 | (if (pair? a) 39 | (cdr a) 40 | (bad 'cdar v))) 41 | (bad 'cdar v)))) 42 | 43 | (define cddr 44 | (lambda (v) 45 | (if (pair? v) 46 | (let ([d (cdr v)]) 47 | (if (pair? d) 48 | (cdr d) 49 | (bad 'cddr v))) 50 | (bad 'cddr v)))) 51 | -------------------------------------------------------------------------------- /tests/syntax-hygienic.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/hygienic 2 | 3 | (require "harness-hygienic.zuo") 4 | 5 | (alert "hygienic syntax") 6 | 7 | (check (identifier? (quote-syntax x))) 8 | (check (not (identifier? 'x))) 9 | (check (not (identifier? #f))) 10 | (check (not (identifier? (quote-syntax (x y))))) 11 | (check (not (identifier? '(x y)))) 12 | (check (andmap identifier? (quote-syntax (x y)))) 13 | 14 | (check (syntax-e (quote-syntax x)) 'x) 15 | (check-fail (syntax-e 'x) "not a syntax object") 16 | 17 | (check (syntax->datum 'x) 'x) 18 | (check (syntax->datum (quote-syntax x)) 'x) 19 | (check (syntax->datum (quote-syntax (x y))) '(x y)) 20 | (check (syntax->datum '(1 #f)) '(1 #f)) 21 | 22 | (check (not (symbol? (datum->syntax (quote-syntax x) 'y)))) 23 | (check (syntax-e (datum->syntax (quote-syntax x) 'y)) 'y) 24 | (check-fail (datum->syntax 'x 'y) "not a syntax object") 25 | 26 | (check (bound-identifier=? (quote-syntax x) (quote-syntax x))) 27 | (check (not (bound-identifier=? (quote-syntax x) (quote-syntax y)))) 28 | 29 | (check-fail (syntax-e #f) "not a syntax object") 30 | (check-fail (syntax-e '(x y)) "not a syntax object") 31 | (check-fail (bound-identifier=? '(x) 'x) "not a syntax object") 32 | (check-fail (bound-identifier=? 'x '(x)) "not a syntax object") 33 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/lib.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (define (caar p) (car (car p))) 4 | (define (cadr p) (car (cdr p))) 5 | (define (cdar p) (cdr (car p))) 6 | (define (cddr p) (cdr (cdr p))) 7 | 8 | (define map 9 | (letrec ([map (lambda (f vs) 10 | (if (null? vs) 11 | '() 12 | (cons (f (car vs)) (map f (cdr vs)))))]) 13 | map)) 14 | 15 | (define map2 16 | (letrec ([map2 (lambda (f vs v2s) 17 | (if (null? vs) 18 | '() 19 | (cons (f (car vs) (car v2s)) 20 | (map2 f (cdr vs) (cdr v2s)))))]) 21 | map2)) 22 | 23 | (define (foldl f init vs) 24 | (letrec ([fold (lambda (vs accum) 25 | (if (null? vs) 26 | accum 27 | (fold (cdr vs) (f (car vs) accum))))]) 28 | (fold vs init))) 29 | 30 | (define (ormap f vs) 31 | (letrec ([ormap (lambda (vs) 32 | (if (null? vs) 33 | #f 34 | (or (f (car vs)) (ormap (cdr vs)))))]) 35 | (ormap vs))) 36 | 37 | (define (mod-path=? a b) 38 | (if (or (symbol? a) (symbol? b)) 39 | (eq? a b) 40 | (string=? a b))) 41 | 42 | (define (gensym sym) 43 | (string->uninterned-symbol (symbol->string sym))) 44 | -------------------------------------------------------------------------------- /tests/syntax.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "syntax objects") 6 | 7 | (check (identifier? (quote-syntax x))) 8 | (check (identifier? 'x)) 9 | (check (not (identifier? #f))) 10 | (check (not (identifier? (quote-syntax (x y))))) 11 | (check (not (identifier? '(x y)))) 12 | (check (andmap identifier? (quote-syntax (x y)))) 13 | 14 | (check (syntax-e (quote-syntax x)) 'x) 15 | (check (syntax-e 'x) 'x) 16 | (check-arg-fail (syntax-e #f) "not a syntax object") 17 | (check-arg-fail (syntax-e '(x y)) "not a syntax object") 18 | 19 | (check (syntax->datum 'x) 'x) 20 | (check (syntax->datum (quote-syntax x)) 'x) 21 | (check (syntax->datum (quote-syntax (x y))) '(x y)) 22 | (check (syntax->datum '(1 #f)) '(1 #f)) 23 | 24 | (check (datum->syntax 'x 'y) 'y) 25 | (check (datum->syntax (quote-syntax x) 'y) 'y) 26 | (check (syntax-e (datum->syntax (quote-syntax x) 'y)) 'y) 27 | (check-arg-fail (datum->syntax '(x) 'y) "not a syntax object") 28 | 29 | (check (bound-identifier=? 'x 'x)) 30 | (check (bound-identifier=? (quote-syntax x) (quote-syntax x))) 31 | (check (not (bound-identifier=? (quote-syntax x) (quote-syntax y)))) 32 | (check (not (bound-identifier=? 'x (quote-syntax x)))) 33 | (check-arg-fail (bound-identifier=? '(x) 'x) "not a syntax object") 34 | (check-arg-fail (bound-identifier=? 'x '(x)) "not a syntax object") 35 | 36 | -------------------------------------------------------------------------------- /lib/zuo/shell.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | (require "thread.zuo") 3 | 4 | (provide shell 5 | shell/wait 6 | build-shell) 7 | 8 | (define (shell command [options (hash)]) 9 | (unless (string? command) (arg-error 'shell "string" command)) 10 | (unless (hash? options) (arg-error 'shell "hash table" options)) 11 | (cond 12 | [(eq? (hash-ref (runtime-env) 'system-type) 'unix) 13 | (apply process (append '("/bin/sh" "-c") (list command options)))] 14 | [else 15 | (let ([cmd (build-path (hash-ref (runtime-env) 'sys-dir) "cmd.exe")]) 16 | (process cmd (~a cmd " /c \"" command "\"") (hash-set options 'exact? #t)))])) 17 | 18 | (define (shell/wait command [options (hash)] [what "shell command"]) 19 | (unless (string? command) (arg-error 'shell/wait "string" command)) 20 | (unless (hash? options) (arg-error 'shell/wait "hash table" options)) 21 | (unless (string? what) (arg-error 'shell/wait "string" what)) 22 | (unless (hash-ref options 'quiet? #f) 23 | (displayln (let ([dir (hash-ref options 'dir #f)]) 24 | (if dir 25 | (~a "cd " (string->shell dir) " && " command) 26 | command)))) 27 | (define p (shell command (hash-remove options 'quiet?))) 28 | (thread-process-wait (hash-ref p 'process)) 29 | (unless (= 0 (process-status (hash-ref p 'process))) 30 | (error (~a what " failed")))) 31 | 32 | (define (build-shell . strs) 33 | (string-join (filter 34 | (lambda (s) 35 | (unless (string? s) (arg-error 'build-shell "string" s)) 36 | (not (equal? s ""))) 37 | strs))) 38 | -------------------------------------------------------------------------------- /tests/equal.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | ;; We need certain things to work for checking even to work, but all 6 | ;; we can do is assume that things work... 7 | 8 | (alert "equal") 9 | 10 | (check #t) 11 | (check (not #f)) 12 | (check (eq? 'apple 'apple)) 13 | (check (not (eq? 'apple 'banana))) 14 | (check (not (eq? 'apple "apple"))) 15 | 16 | (check (string=? "apple" "apple")) 17 | (check (not (string=? "apple" "banana"))) 18 | (check (string-ci=? "apple" "aPPle")) 19 | (check (not (string-ci=? "apple" "banana"))) 20 | 21 | (check (= 1 1)) 22 | (check (not (= 1 -1))) 23 | 24 | (check (equal? 1 1)) 25 | (check (equal? "apple" "apple")) 26 | 27 | (check (equal? "apple" "apple")) 28 | (check (equal? '("apple") '("apple"))) 29 | (check (equal? '(0 "apple") '(0 "apple"))) 30 | (check (not (equal? '("apple") '("banana")))) 31 | (check (not (equal? '(0 "apple") '(0 "banana")))) 32 | 33 | (check (equal? (hash 'a 1) (hash 'a 1))) 34 | (check (not (equal? (hash 'a 1) (hash 'b 1)))) 35 | (check (not (equal? (hash 'a 1) (hash 'a 2)))) 36 | 37 | (check (not (equal? "apple" 'other))) 38 | (check (not (equal? 'other "apple"))) 39 | (check (not (equal? 1 'other))) 40 | (check (not (equal? 'other 1))) 41 | (check (not (equal? 1 (hash 'a 1)))) 42 | (check (not (equal? (hash 'a 1) 1))) 43 | 44 | (check-fail (= 1 'apple) not-integer) 45 | (check-fail (= 'apple 1) not-integer) 46 | (check-arg-fail (string=? 1 "apple") not-string) 47 | (check-arg-fail (string=? "apple" 1) not-string) 48 | (check-arg-fail (string-ci=? 1 "apple") not-string) 49 | (check-arg-fail (string-ci=? "apple" 1) not-string) 50 | 51 | (check (eq? (void) (void))) 52 | (check (void? (void))) 53 | (check (not (void? 'void))) 54 | -------------------------------------------------------------------------------- /lib/zuo/config.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | 3 | (provide config-file->hash) 4 | 5 | (define (config-file->hash path) 6 | (unless (path-string? path) (arg-error 'config->hash "path string" path)) 7 | (define content (file->string path)) 8 | (define lines (string-split content "\n")) 9 | (foldl (lambda (line accum) 10 | (define positions ; (list var-start var-end =-pos) or #f 11 | (let loop ([i 0] [start #f] [end #f]) 12 | (cond 13 | [(= i (string-length line)) #f] 14 | [else 15 | (let ([c (string-ref line i)]) 16 | (cond 17 | [(= (char "=") c) (and start (list start (or end i) i))] 18 | [(or (= (char "_") c) 19 | (and (<= (char "a") c) 20 | (<= c (char "z"))) 21 | (and (<= (char "A") c) 22 | (<= c (char "Z"))) 23 | (and (<= (char "0") c) 24 | (<= c (char "9")))) 25 | (and (not end) 26 | (loop (+ i 1) (or start i) #f))] 27 | [(= (char " ") c) 28 | (if start 29 | (loop (+ i 1) start (or end i)) 30 | (loop (+ i 1) #f #f))] 31 | [else #f]))]))) 32 | (cond 33 | [positions 34 | (define var (string->symbol (substring line (car positions) (cadr positions)))) 35 | (define rhs (substring line (+ (list-ref positions 2) 1) (string-length line))) 36 | (hash-set accum var (string-trim rhs))] 37 | [else accum])) 38 | (hash) 39 | lines)) 40 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/define-help.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "and-or.zuo" 5 | "syntax-error.zuo" 6 | "../list.zuo" 7 | "let.zuo" 8 | "check-dups.zuo") 9 | 10 | (provide check-args 11 | make-define) 12 | 13 | (define check-args 14 | (lambda (stx args) 15 | (let ([arg-names 16 | (let loop ([args args] [must-opt? #f]) 17 | (cond 18 | [(identifier? args) ; rest arg 19 | (list args)] 20 | [(pair? args) 21 | (cond 22 | [(and (identifier? (car args)) 23 | (not must-opt?)) 24 | (cons (car args) (loop (cdr args) #f))] 25 | [(and (list? (car args)) 26 | (= 2 (length (car args))) 27 | (identifier? (caar args))) 28 | (cons (caar args) (loop (cdr args) #t))] 29 | [else 30 | (syntax-error (~a (syntax-e (car stx)) ": bad syntax at argument") 31 | (car args))])] 32 | [(null? args) '()] 33 | [else (bad-syntax stx)]))]) 34 | (check-duplicates arg-names) 35 | arg-names))) 36 | 37 | (define make-define 38 | (lambda (orig-define opt-lambda) 39 | (lambda (stx) 40 | (unless (and (list? stx) (>= (length stx) 3)) (bad-syntax stx)) 41 | (let ([head (cadr stx)]) 42 | (cond 43 | [(identifier? head) 44 | ;; regular define 45 | (cons orig-define (cdr stx))] 46 | [(and (pair? head) 47 | (identifier? (car head))) 48 | ;; procedure shorthand 49 | (let* ([name (car head)] 50 | [args (cdr head)]) 51 | (check-args stx args) 52 | (list orig-define name (list* opt-lambda args (cddr stx))))] 53 | [else (bad-syntax stx)]))))) 54 | -------------------------------------------------------------------------------- /tests/procedure.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "procedures") 6 | 7 | (check (procedure? procedure?)) 8 | (check (procedure? (lambda (x) x))) 9 | (check (procedure? (lambda args args))) 10 | (check (procedure? apply)) 11 | (check (procedure? call/cc)) 12 | (check (procedure? (call/cc (lambda (k) k)))) 13 | (check (not (procedure? 1))) 14 | 15 | (check (apply + '()) 0) 16 | (check (apply + '(1)) 1) 17 | (check (apply + '(1 2)) 3) 18 | (check (apply + '(1 2 3 4)) 10) 19 | (check (apply apply (list + '(1 2))) 3) 20 | (check-fail (apply +) arity) 21 | (check-fail (apply '(+ 1 2)) arity) 22 | (check-fail (apply apply (cons + '(1 2))) arity) 23 | (check-arg-fail (apply + 1) "not a list") 24 | 25 | (check (call/cc (lambda (k) (+ 1 (k 'ok)))) 'ok) 26 | (check (let ([f (call/cc (lambda (k) k))]) 27 | (if (procedure? f) 28 | (f 10) 29 | f)) 30 | 10) 31 | (check-fail (call/cc 1) "not a procedure") 32 | 33 | (check (call/prompt (lambda () 10)) 10) 34 | (check (let ([k (call/prompt 35 | (lambda () 36 | (call/cc (lambda (k) k))))]) 37 | (+ 1 (call/prompt (lambda () (k 11))))) 38 | 12) 39 | (check (let ([k (call/prompt 40 | (lambda () 41 | (call/cc 42 | (lambda (esc) 43 | (+ 1 44 | (* 2 45 | (call/cc 46 | (lambda (k) (esc k)))))))))]) 47 | (list (call/prompt (lambda () (k 3))) 48 | (call/prompt (lambda () (k 4))))) 49 | (list 7 9)) 50 | (check-fail (call/prompt 1) "not a procedure") 51 | 52 | (check (let ([k (call/prompt 53 | (lambda () 54 | (call/cc 55 | (lambda (esc) 56 | (+ 1 57 | (* 2 58 | (call/comp esc)))))))]) 59 | (list (k 30) 60 | (k 40))) 61 | (list 61 81)) 62 | (check-arg-fail (call/comp 1) "not a procedure") 63 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/parse-lib.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; Helpers for "parse.zuo" that depends on the implementation of 4 | ;; syntax objects 5 | 6 | (define (name-lambda name form) 7 | (if name 8 | ;; `zuo/kernel` recognizes this pattern to name the form 9 | (cons 'lambda (cons (cadr form) (cons (symbol->string (syntax-e name)) (cddr form)))) 10 | form)) 11 | 12 | (define (syntax-error msg s) 13 | (error (~a msg ": " (~s (syntax->datum s))))) 14 | 15 | (define (bad-syntax s) 16 | (syntax-error "bad syntax" s)) 17 | 18 | (define (duplicate-identifier id s) 19 | (error "duplicate identifier:" (syntax-e id) (syntax->datum s))) 20 | 21 | (define (id-sym-eq? id sym) 22 | (and (identifier? id) 23 | (eq? (syntax-e id) sym))) 24 | 25 | (define (unwrap-mod-path mod-path) 26 | (if (identifier? mod-path) 27 | (syntax-e mod-path) 28 | mod-path)) 29 | 30 | (define (add-binding state id binding) 31 | (state-set-binds state (add-binding* (state-binds state) id binding))) 32 | 33 | (define (resolve state id same-defn-ctx?) 34 | (let* ([bind (resolve* (state-binds state) id same-defn-ctx?)] 35 | [bind (unwrap-specific bind)]) 36 | (if (initial-import? bind) 37 | (initial-import-bind bind) 38 | bind))) 39 | 40 | (define (merge-binds state m-binds) 41 | (if m-binds 42 | (state-set-binds state (merge-binds* (state-binds state) m-binds)) 43 | state)) 44 | 45 | (define (new-defn-context state) 46 | (state-set-binds state (new-defn-context* (state-binds state)))) 47 | 48 | (define (nest-bindings new-cls body) 49 | (letrec ([nest-bindings (lambda (new-cls) 50 | (if (null? new-cls) 51 | body 52 | (list 'let (list (car new-cls)) 53 | (nest-bindings (cdr new-cls)))))]) 54 | (nest-bindings (reverse new-cls)))) 55 | 56 | ;; Use to communicate a `variable-set!` form from `define` to `parse`: 57 | (define set-var-tag (string->uninterned-symbol "setvar")) 58 | 59 | (define (print-result v) 60 | (unless (eq? v (void)) 61 | (alert (~v v)))) 62 | 63 | (define (add-print s) 64 | (list print-result s)) 65 | (define (no-wrap s) s) 66 | -------------------------------------------------------------------------------- /tests/hash.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "hash tables") 6 | 7 | (check (hash? (hash))) 8 | (check (not (hash? 'apple))) 9 | 10 | (check (hash-ref (hash 'a 1) 'a #f) 1) 11 | (check (hash-ref (hash 'a 1) 'b #f) #f) 12 | (check (hash-ref (hash 'a 1) 'b 'no) 'no) 13 | (check-arg-fail (hash-ref 0 0 0) "not a hash table") 14 | (check-arg-fail (hash-ref (hash) 0 0) "not a symbol") 15 | 16 | (check (hash-set (hash 'a 1) 'b 2) (hash 'a 1 'b 2)) 17 | (check (hash-ref (hash-set (hash 'a 1) 'b 2) 'a #f) 1) 18 | (check (hash-ref (hash-set (hash 'a 1) 'b 2) 'b #f) 2) 19 | (check (hash-ref (hash-set (hash 'a 1) 'b 2) 'c #f) #f) 20 | (check-arg-fail (hash-set 0 0 0) "not a hash table") 21 | (check-arg-fail (hash-set (hash) 0 0) "not a symbol") 22 | 23 | (check (hash-remove (hash 'a 1) 'a) (hash)) 24 | (check (hash-remove (hash 'a 1) 'b) (hash 'a 1)) 25 | (check (hash-remove (hash 'a 1 'b 2) 'a) (hash 'b 2)) 26 | (check (hash-ref (hash-remove (hash 'a 1) 'a) 'a #f) #f) 27 | (check-arg-fail (hash-remove 0 0) "not a hash table") 28 | (check-arg-fail (hash-remove (hash) 0) "not a symbol") 29 | 30 | (check (hash-count (hash)) 0) 31 | (check (hash-count (hash 'a 1 'a 2 'b 3)) 2) 32 | (check (hash-count (hash-set (hash 'a 1 'b 3) 'c 3)) 3) 33 | (check (hash-count (hash-remove (hash 'a 1 'b 3) 'b)) 1) 34 | (check-arg-fail (hash-count 0) "not a hash table") 35 | 36 | (check (hash-keys (hash)) '()) 37 | (check (hash-keys (hash 'a 1)) '(a)) 38 | (check (let ([keys (hash-keys (hash 'a 1 'b 2))]) 39 | (or (equal? keys '(a b)) 40 | (equal? keys '(b a))))) 41 | (check (length (hash-keys (hash 'a 1 'b 2 'c 3))) 3) 42 | (check (length (hash-keys (hash 'a 1 'b 2 'a 3))) 2) 43 | (check-arg-fail (hash-keys 0) "not a hash table") 44 | 45 | (check (hash-keys-subset? (hash) (hash 'a 1)) #t) 46 | (check (hash-keys-subset? (hash 'a 1) (hash)) #f) 47 | (check (hash-keys-subset? (hash 'a 1) (hash 'a 1 'b 2)) #t) 48 | (check (hash-keys-subset? (hash 'b 2) (hash 'a 1 'b 2)) #t) 49 | (check (hash-keys-subset? (hash 'a 1 'b 2) (hash 'a 1)) #f) 50 | (check (hash-keys-subset? (hash 'a 1 'b 2) (hash 'b 1)) #f) 51 | (check-arg-fail (hash-keys-subset? 0 (hash)) "not a hash table") 52 | (check-arg-fail (hash-keys-subset? (hash) 0) "not a hash table") 53 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/entry.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; The `read-and-eval` entry point for a language using the expander 4 | 5 | (define (make-read-and-eval make-initial-state) 6 | (lambda (str start mod-path) 7 | (let* ([es (string-read str start mod-path)] 8 | [ctx (make-module-context mod-path)] 9 | [es (map (lambda (e) (datum->syntax ctx e)) es)] 10 | [parse (make-parse ctx mod-path)] 11 | [initial-state (make-initial-state ctx)] 12 | [es+state+modtop (expand-sequence es initial-state empty-modtop mod-path ctx parse)] 13 | [es (car es+state+modtop)] 14 | [state (cadr es+state+modtop)] 15 | [modtop (cadr (cdr es+state+modtop))] 16 | [outs (resolve-provides (modtop-provides modtop) state ctx mod-path)] 17 | [body (map (lambda (e) (add-print (parse e #f state))) es)] 18 | [submods (parse-submodules (modtop-modules modtop) state mod-path ctx parse)]) 19 | (kernel-eval (cons 'begin (cons '(void) body))) 20 | (hash 'macromod-provides outs 21 | 'submodules submods 22 | merge-bindings-export-key (make-export-merge-binds ctx (state-binds state)))))) 23 | 24 | (hash 25 | ;; makes `#lang zuo/private/base[-hygienic] work: 26 | 'read-and-eval (make-read-and-eval (lambda (ctx) 27 | (make-state (binds-create top-provides ctx) 28 | (initial-nominals language-mod-path top-provides)))) 29 | ;; makes `(require zuo/private/base[hygienic])` work: 30 | 'macromod-provides top-provides 31 | ;; for making a new `#lang` with initial imports from `mod-path`: 32 | 'make-language 33 | (lambda (mod-path) 34 | (let* ([mod (module->hash mod-path)] 35 | [provides (hash-ref mod 'macromod-provides #f)] 36 | [m-binds (hash-ref mod merge-bindings-export-key #f)]) 37 | (unless provides 38 | (syntax-error "not a compatible module for initial imports" mod-path)) 39 | (hash 'read-and-eval 40 | (make-read-and-eval 41 | (lambda (ctx) 42 | (merge-binds (make-state (binds-create provides ctx) 43 | (initial-nominals mod-path provides)) 44 | m-binds))) 45 | 'macromode-provides (hash-ref (module->hash mod-path) 'macromod-provides #f))))) 46 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | srcdir=`dirname "$0"` 4 | installprefix=/usr/local 5 | : ${CC:="cc"} 6 | : ${CFLAGS:="-O2"} 7 | embed=zuo 8 | LIB_PATH=lib 9 | 10 | while [ $# != 0 ] ; do 11 | case $1 in 12 | --embed=*) 13 | embed=`echo $1 | sed -e 's/^--embed=//'` 14 | ;; 15 | --big) 16 | embed="zuo zuo/hygienic" 17 | ;; 18 | --prefix=*) 19 | installprefix=`echo $1 | sed -e 's/^--prefix=//'` 20 | LIB_PATH=${installprefix}/share/zuo 21 | ;; 22 | --help) 23 | help=yes 24 | ;; 25 | CC=*) 26 | CC=`echo $1 | sed -e 's/^CC=//'` 27 | ;; 28 | CPPFLAGS=*) 29 | CPPFLAGS=`echo $1 | sed -e 's/^CPPFLAGS=//'` 30 | ;; 31 | CFLAGS=*) 32 | CFLAGS=`echo $1 | sed -e 's/^CFLAGS=//'` 33 | cflagsset=yes 34 | ;; 35 | LDFLAGS=*) 36 | LDFLAGS=`echo $1 | sed -e 's/^LDFLAGS=//'` 37 | ;; 38 | LIBS=*) 39 | LIBS=`echo $1 | sed -e 's/^LIBS=//'` 40 | ;; 41 | *) 42 | echo "option '$1' unrecognized or missing an argument; try $0 --help" 43 | exit 1 44 | ;; 45 | esac 46 | shift 47 | done 48 | 49 | if [ "$help" = "yes" ]; then 50 | echo "" 51 | echo "Options (defaults shown in parens):" 52 | echo " --prefix= installation root ($installprefix)" 53 | echo " --embed=\" ...\" embed s in executable (zuo)" 54 | echo " --big shorthand for --embed=\"zuo zuo/hygienic\"" 55 | echo " CC= C compiler" 56 | echo " CPPFLAGS= C preprocessor flags" 57 | echo " CFLAGS= C compiler flags" 58 | echo " LDFLAGS= additional linker flags" 59 | echo " LIBS= additional libraries" 60 | echo "" 61 | echo "" 62 | exit 0 63 | fi 64 | 65 | echo "srcdir = ${srcdir}" > Makefile 66 | echo "EMBED_LIBS = ${embed}" >> Makefile 67 | echo "CC = ${CC}" >> Makefile 68 | echo "CPPFLAGS = ${CPPFLAGS}" >> Makefile 69 | echo "CFLAGS = ${CFLAGS}" >> Makefile 70 | echo "LDFLAGS = ${LDFLAGS}" >> Makefile 71 | echo "LIBS = ${LIBS}" >> Makefile 72 | echo "INSTALL_PREFIX = ${installprefix}" >> Makefile 73 | cat ${srcdir}/Makefile.in >> Makefile 74 | 75 | echo "#lang zuo" > main.zuo 76 | echo "(require "'"'"${srcdir}/local/main.zuo"'"'")" >> main.zuo 77 | echo "(build/command-line* targets-at at-source)" >> main.zuo 78 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/let.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "and-or.zuo" 5 | "syntax-error.zuo" 6 | "../list.zuo" 7 | "check-dups.zuo") 8 | 9 | (provide (rename-out [let-or-named-let let]) 10 | let*) 11 | 12 | (define-syntax let-or-named-let 13 | (lambda (stx) 14 | (cond 15 | [(not (pair? stx)) (bad-syntax stx)] 16 | [(and (pair? (cdr stx)) 17 | (identifier? (cadr stx))) 18 | ;; named `let` 19 | (unless (and (list? stx) 20 | (>= (length stx) 4)) 21 | (bad-syntax stx)) 22 | (let ([name (cadr stx)] 23 | [bindings (cadr (cdr stx))]) 24 | (for-each (lambda (binding) 25 | (unless (and (list? binding) 26 | (= 2 (length binding)) 27 | (identifier? (car binding))) 28 | (syntax-error "named let: bad syntax at binding" binding))) 29 | bindings) 30 | (let ([args (map car bindings)] 31 | [inits (map cadr bindings)]) 32 | (check-duplicates args) 33 | (cons (list (quote-syntax letrec) 34 | (list (list name 35 | (list* (quote-syntax lambda) 36 | args 37 | (cddr (cdr stx))))) 38 | name) 39 | inits)))] 40 | [else (cons (quote-syntax let) (cdr stx))]))) 41 | 42 | (define-syntax let* 43 | (lambda (stx) 44 | (unless (and (list? stx) (>= (length stx) 3)) 45 | (bad-syntax stx)) 46 | (let ([bindings (cadr stx)]) 47 | (unless (list? bindings) (bad-syntax stx)) 48 | (for-each (lambda (binding) 49 | (unless (and (list? binding) 50 | (= 2 (length binding)) 51 | (identifier? (car binding))) 52 | (syntax-error "let*: bad syntax at binding" binding))) 53 | bindings) 54 | (letrec ([nest-bindings 55 | (lambda (bindings) 56 | (if (null? bindings) 57 | (cons (quote-syntax begin) (cddr stx)) 58 | (list (quote-syntax let) (list (car bindings)) 59 | (nest-bindings (cdr bindings)))))]) 60 | (nest-bindings bindings))))) 61 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/state.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; The state of expansion is a combinion of 4 | ;; * bindings 5 | ;; * defined variables being lifted, or #f for a module top 6 | ;; * "nominals", which is information about `require`s that is 7 | ;; used to implement `(provide (all-from-out ....))` 8 | 9 | (define make-state (lambda (binds nominals) (cons binds (cons #f nominals)))) 10 | (define state-binds car) 11 | (define state-variables cadr) 12 | (define state-nominals cddr) 13 | (define (state-set-binds state binds) (cons binds (cdr state))) 14 | (define (state-set-nominals state nominals) (cons (car state) (cons (cadr state) nominals))) 15 | (define (state-set-variables state variables) (cons (car state) (cons variables (cddr state)))) 16 | 17 | ;; helper to lookup or update nominals: 18 | (define (call-with-nominal state mod-path default-ids k) 19 | (let* ([fronted 20 | (letrec ([assoc-to-front 21 | (lambda (l) 22 | (cond 23 | [(null? l) (list (cons mod-path default-ids))] 24 | [(mod-path=? mod-path (caar l)) l] 25 | [else (let ([new-l (assoc-to-front (cdr l))]) 26 | (cons (car new-l) (cons (car l) (cdr new-l))))]))]) 27 | (assoc-to-front (state-nominals state)))]) 28 | (k (cdar fronted) 29 | (lambda (new-sym+bs) 30 | (let* ([new-noms (cons (cons (caar fronted) new-sym+bs) 31 | (cdr fronted))]) 32 | (state-set-nominals state new-noms)))))) 33 | 34 | (define (init-nominal state mod-path) 35 | (call-with-nominal state mod-path '() 36 | (lambda (sym+binds install) 37 | (install sym+binds)))) 38 | 39 | (define (record-nominal state mod-path sym bind) 40 | (call-with-nominal state mod-path '() 41 | (lambda (sym+binds install) 42 | (install (cons (cons sym bind) sym+binds))))) 43 | 44 | (define (lookup-nominal state mod-path) 45 | (call-with-nominal state mod-path #f 46 | (lambda (sym+binds install) 47 | sym+binds))) 48 | 49 | ;; in case `all-from-out` is used on the initial import, 50 | ;; adds all the current ids in `binds` as nominally imported 51 | (define (initial-nominals mod-path sym+bs) 52 | (list (cons mod-path sym+bs))) 53 | 54 | ;; Module top-level state contains provides and submodules 55 | (define empty-modtop (cons '() '())) 56 | (define modtop-provides car) 57 | (define modtop-modules cdr) 58 | (define (modtop-set-provides modtop provides) (cons provides (cdr modtop))) 59 | (define (modtop-set-modules modtop modules) (cons (car modtop) modules)) 60 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/quasiquote.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "and-or.zuo" 5 | "syntax-error.zuo" 6 | "../list.zuo" 7 | "let.zuo") 8 | 9 | (provide quasiquote 10 | unquote 11 | unquote-splicing) 12 | 13 | (define-syntax quasiquote 14 | (context-consumer 15 | (lambda (stx free-id=? name) 16 | (unless (and (list? stx) (= (length stx) 2)) 17 | (bad-syntax stx)) 18 | (let ([quot (quote-syntax quote)]) 19 | (let loop ([s (cadr stx)] [depth 0]) 20 | (let ([loop-pair (lambda (combine combine-name a d depth) 21 | (let ([a (loop a depth)] 22 | [d (loop d depth)]) 23 | (if (and (pair? a) 24 | (eq? (car a) quot) 25 | (pair? d) 26 | (eq? (car d) quot)) 27 | (list quot (combine (cadr a) (cadr d))) 28 | (list combine-name a d))))]) 29 | (cond 30 | [(pair? s) 31 | (let ([a (car s)]) 32 | (cond 33 | [(and (identifier? a) 34 | (free-id=? (syntax-e a) 'unquote)) 35 | (unless (= (length s) 2) 36 | (bad-syntax s)) 37 | (if (= depth 0) 38 | (cadr s) 39 | (loop-pair list (quote-syntax list) a (cadr s) (- depth 1)))] 40 | [(and (identifier? a) 41 | (free-id=? (syntax-e a) 'unquote-splicing)) 42 | (syntax-error "misplaced splicing unquote" s)] 43 | [(and (pair? a) 44 | (identifier? (car a)) 45 | (free-id=? (syntax-e (car a)) 'unquote-splicing)) 46 | (unless (= (length a) 2) 47 | (bad-syntax a)) 48 | (if (= depth 0) 49 | (if (null? (cdr s)) 50 | (cadr a) 51 | (list (quote-syntax append) (cadr a) (loop (cdr s) depth))) 52 | (loop-pair cons (quote-syntax cons) a (cdr s) depth))] 53 | [(and (identifier? a) 54 | (free-id=? (syntax-e a) 'quasiquote)) 55 | (unless (= (length s) 2) 56 | (bad-syntax s)) 57 | (loop-pair list (quote-syntax list) a (cadr s) (+ depth 1))] 58 | [else 59 | (loop-pair cons (quote-syntax cons) a (cdr s) depth)]))] 60 | [else (list quot s)]))))))) 61 | 62 | (define-syntax unquote misplaced-syntax) 63 | (define-syntax unquote-splicing misplaced-syntax) 64 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/and-or.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "syntax-error.zuo") 5 | 6 | (provide or 7 | and 8 | cond else 9 | when 10 | unless) 11 | 12 | (define-syntax or 13 | (lambda (stx) 14 | (if (list? stx) 15 | (if (null? (cdr stx)) 16 | #f 17 | (if (null? (cddr stx)) 18 | (cadr stx) 19 | (list (quote-syntax let) (list (list 'tmp (cadr stx))) 20 | (list (quote-syntax if) 'tmp 21 | 'tmp 22 | (cons (quote-syntax or) (cddr stx)))))) 23 | (bad-syntax stx)))) 24 | 25 | (define-syntax and 26 | (lambda (stx) 27 | (if (list? stx) 28 | (if (null? (cdr stx)) 29 | #t 30 | (if (null? (cddr stx)) 31 | (cadr stx) 32 | (list (quote-syntax if) (cadr stx) 33 | (cons (quote-syntax and) (cddr stx)) 34 | #f))) 35 | (bad-syntax stx)))) 36 | 37 | (define-syntax else misplaced-syntax) 38 | 39 | (define-syntax cond 40 | (context-consumer 41 | (lambda (stx free-id=? name) 42 | (if (and (list? stx) 43 | (letrec ([ok-clauses? 44 | (lambda (l) 45 | (or (null? l) 46 | (let ([cl (car l)]) 47 | (and (list? cl) 48 | (>= (length cl) 2) 49 | (ok-clauses? (cdr l))))))]) 50 | (ok-clauses? (cdr stx)))) 51 | (if (null? (cdr stx)) 52 | (list (quote-syntax void)) 53 | (let ([cl1 (cadr stx)] 54 | [cls (cddr stx)]) 55 | (list 'if (if (and (null? cls) 56 | (identifier? (car cl1)) 57 | (free-id=? 'else (car cl1))) 58 | #t 59 | (car cl1)) 60 | (cons (quote-syntax let) (cons '() (cdr cl1))) 61 | (if (null? cls) 62 | '(void) 63 | (cons (quote-syntax cond) cls))))) 64 | (bad-syntax stx))))) 65 | 66 | (define-syntax when 67 | (lambda (stx) 68 | (if (and (list? stx) 69 | (>= (length stx) 3)) 70 | (list 'if (cadr stx) 71 | (cons (quote-syntax let) (cons '() (cddr stx))) 72 | '(void)) 73 | (bad-syntax stx)))) 74 | 75 | (define-syntax unless 76 | (lambda (stx) 77 | (if (and (list? stx) 78 | (>= (length stx) 3)) 79 | (list 'if (cadr stx) 80 | '(void) 81 | (cons (quote-syntax let) (cons '() (cddr stx)))) 82 | (bad-syntax stx)))) 83 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/bind.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; Creation of the initial bindings and managing imports/exports 4 | 5 | ;; A binding can be any non-pair value or one of the record 6 | ;; types described in "struct.zuo" 7 | 8 | (define (make-core-initial-bind bind) 9 | (as-specific (make-initial-import bind))) 10 | 11 | ;; Start with kernel-supplied primitives 12 | (define kernel-provides 13 | (let* ([ht (kernel-env)]) 14 | (foldl (lambda (sym provides) 15 | (hash-set provides sym (make-core-initial-bind (hash-ref ht sym #f)))) 16 | (hash) 17 | (hash-keys ht)))) 18 | 19 | ;; Add expander-defined syntactic forms 20 | (define top-form-provides 21 | (foldl (lambda (sym provides) 22 | (hash-set provides sym (make-core-initial-bind (make-core-form sym)))) 23 | kernel-provides 24 | '(lambda let letrec quote if begin 25 | define define-syntax require provide module+ 26 | quote-syntax quote-module-path 27 | include))) 28 | 29 | ;; Add some functions/constants defined in the expander 30 | (define top-provides 31 | (let* ([provides top-form-provides] 32 | [add (lambda (provides name val) (hash-set provides name (make-core-initial-bind val)))] 33 | [provides (add provides 'identifier? identifier?)] 34 | [provides (add provides 'syntax-e checked-syntax-e)] 35 | [provides (add provides 'syntax->datum checked-syntax->datum)] 36 | [provides (add provides 'datum->syntax checked-datum->syntax)] 37 | [provides (add provides 'bound-identifier=? bound-identifier=?)] 38 | [provides (add provides 'context-consumer context-consumer)] 39 | [provides (add provides 'context-consumer? context-consumer?)]) 40 | provides)) 41 | 42 | ;; Used to convert a local binding into one that goes in a provides 43 | ;; table, so suitable to import into another module 44 | (define (export-bind bind ctx binds) 45 | (let* ([label (and (specific? bind) 46 | (specific-label bind))] 47 | [bind (unwrap-specific bind)] 48 | [bind (if (initial-import? bind) 49 | (initial-import-bind bind) 50 | bind)] 51 | [bind (cond 52 | [(defined? bind) 53 | (make-local-variable (variable-var bind))] 54 | [(defined-macro? bind) 55 | (make-exported-macro (defined-macro-proc bind) ctx)] 56 | [else bind])]) 57 | (if label 58 | (make-specific (cons bind label)) 59 | bind))) 60 | 61 | ;; in case `all-from-out` is used on the initial import, 62 | ;; adds all the current ids in `binds` as nominally imported 63 | (define (initial-nominals mod-path provides) 64 | (list (cons mod-path 65 | (map (lambda (sym) (cons sym (hash-ref provides sym #f))) 66 | (hash-keys provides))))) 67 | -------------------------------------------------------------------------------- /local/tree.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | ;; This module implements a simple version of the `tree` program, 4 | ;; which shows the content of a directory in tree form. 5 | 6 | ;; Another script could use this `tree` function... 7 | (provide tree) 8 | 9 | ;; ... but if this script is the main one passed to Zuo, 10 | ;; then the `main` submodule is run, which parses command-line 11 | ;; arguments and call `tree`. 12 | (module+ main 13 | ;; Imitates Racket's `command-line` form, but we have to explicitly 14 | ;; thread through `accum`, because there's no state 15 | (command-line 16 | :init (hash) ; initial accumulator (but `(hash)` is the default, anyway) 17 | :once-each 18 | ;; Each flag clause starts with the accumulator id 19 | [accum ("-a") "Include names that start with `.`" 20 | (hash-set accum 'all? #t)] 21 | [accum ("-h") "Show file sizes human-readable" 22 | (hash-set accum 'h-size? #t)] 23 | :args ([dir "."]) 24 | (lambda (accum) ; args handler as procedure to receive the accumulator 25 | (if (directory-exists? dir) 26 | (tree dir 27 | (hash-ref accum 'all? #f) 28 | (hash-ref accum 'h-size? #f)) 29 | (error (~a (hash-ref (runtime-env) 'script) 30 | ": no such directory: " 31 | dir)))))) 32 | 33 | ;; Recur using `ls` to get a directory's content 34 | (define (tree dir show-all? show-size?) 35 | (displayln dir) 36 | (let tree ([dir dir] [depth 0]) 37 | (define elems (sort (ls dir) stringmatcher ".*")]) 62 | (lambda (s) (not (dot? s))))) 63 | 64 | ;; Arithmetic is not Zuo's strong suit, since it supports only 65 | ;; 64-bit signed integers 66 | (define (human-readable n) 67 | (define (decimal n) 68 | (define d (quotient 1024 10)) 69 | (define dec (quotient (+ (modulo n 1024) (quotient d 2)) d)) 70 | (~a (quotient n (* 1024)) "." dec)) 71 | (define s 72 | (cond 73 | [(< n 1024) (~a n)] 74 | [(< n (quotient (* 1024 1024) 10)) (~a (decimal n) "K")] 75 | [else (~a (decimal (quotient n 1024)) "M")])) 76 | (if (< (string-length s) 4) 77 | (~a (substring " " (string-length s)) s) 78 | s)) 79 | -------------------------------------------------------------------------------- /tests/cleanable.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "cleanables") 6 | 7 | (define adios-file (build-path tmp-dir "adios.txt")) 8 | 9 | (define (check-cleaned pre post expect-status expect-exist?) 10 | (run-zuo* '("") 11 | (~a "#lang zuo\n" 12 | (~s 13 | `(begin 14 | ,@pre 15 | (define cl (cleanable-file ,adios-file)) 16 | ,@post))) 17 | (lambda (status out err) 18 | (check status expect-status))) 19 | (check (file-exists? adios-file) expect-exist?)) 20 | 21 | (fd-close (fd-open-output adios-file :truncate)) 22 | (check-cleaned '() 23 | '() 24 | 0 25 | #f) 26 | (check-cleaned `((void (fd-open-output ,adios-file :truncate))) 27 | '() 28 | 0 29 | #f) 30 | (check-cleaned `((void (fd-open-output ,adios-file :truncate))) 31 | '((car '())) 32 | 1 33 | #f) 34 | (check-cleaned `((void (fd-open-output ,adios-file :truncate))) 35 | '((cleanable-cancel cl)) 36 | 0 37 | #t) 38 | 39 | ;; check that a process doesn't exit before a subprocess, 40 | ;; even when it doesn't explicitly wait, or that it does exit 41 | ;; in no-wait mode 42 | (define (check-sub no-wait?) 43 | (define sub.zuo (build-path tmp-dir "sub.zuo")) 44 | (define inner.zuo (build-path tmp-dir "inner.zuo")) 45 | (let ([o (fd-open-output sub.zuo :truncate)]) 46 | (fd-write o (~a "#lang zuo\n" 47 | (~s `(void (process (hash-ref (runtime-env) 'exe) 48 | ,inner.zuo 49 | ,(if no-wait? 50 | '(hash 'cleanable? #f) 51 | '(hash))))))) 52 | (fd-close o)) 53 | (let ([o (fd-open-output inner.zuo :truncate)]) 54 | (fd-write o (~a "#lang zuo\n" 55 | (~s `(let ([in (fd-open-input 'stdin)] 56 | [out (fd-open-output 'stdout)]) 57 | (define s (fd-read in 1)) 58 | (fd-write out s) 59 | (fd-read in 1))))) 60 | (fd-close o)) 61 | (define p (process (hash-ref (runtime-env) 'exe) 62 | sub.zuo 63 | (hash 'stdin 'pipe 'stdout 'pipe))) 64 | (define to (hash-ref p 'stdin)) 65 | (define from (hash-ref p 'stdout)) 66 | (cond 67 | [no-wait? (process-wait (hash-ref p 'process))] 68 | [else (check (process-status (hash-ref p 'process)) 'running)]) 69 | (fd-write to "x") 70 | (check (fd-read from 1) "x") 71 | (unless no-wait? 72 | (check (process-status (hash-ref p 'process)) 'running)) 73 | (fd-write to "y") 74 | (process-wait (hash-ref p 'process)) 75 | (check (process-status (hash-ref p 'process)) 0)) 76 | 77 | (check-sub #f) 78 | (check-sub #f) 79 | (check-sub #t) 80 | 81 | (check-arg-fail (cleanable-file 10) not-path) 82 | (check-arg-fail (cleanable-cancel 10) "cleanable handle") 83 | -------------------------------------------------------------------------------- /tests/glob.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "glob") 6 | 7 | (check (glob-match? "apple" "apple")) 8 | (check (glob-match? "apple" "banana") #f) 9 | 10 | (check (glob-match? "" "")) 11 | (check (glob-match? "" "x") #f) 12 | (check (glob-match? "x" "") #f) 13 | 14 | (check (glob-match? "a*le" "apple")) 15 | (check (glob-match? "a*le" "ale")) 16 | (check (glob-match? "a*le" "aple")) 17 | (check (glob-match? "a*le" "a//p//le")) 18 | (check (glob-match? "a*le" "appe") #f) 19 | (check (glob-match? "a*le" "pple") #f) 20 | 21 | (check (glob-match? "a*?le" "apple")) 22 | (check (glob-match? "a*?le" "aple")) 23 | (check (glob-match? "a*?le" "ale") #f) 24 | 25 | (check (glob-match? "*le" "apple")) 26 | (check (glob-match? "*le" ".apple")) 27 | 28 | (check (glob-match? "*le" "apple")) 29 | (check (glob-match? "*le" ".apple")) 30 | 31 | (check (glob-match? "x[a-c]x" "x0x") #f) 32 | (check (glob-match? "x[a-c]x" "xax")) 33 | (check (glob-match? "x[a-c]x" "xbx")) 34 | (check (glob-match? "x[a-c]x" "xcx")) 35 | (check (glob-match? "x[a-c]x" "xdx") #f) 36 | (check (glob-match? "x[a-c]x" "x[x") #f) 37 | (check (glob-match? "x[a-c]x" "x]x") #f) 38 | 39 | (check (glob-match? "x[0-9][A-Z]x" "x0Ax")) 40 | (check (glob-match? "x[0-9][A-Z]x" "x9Zx")) 41 | (check (glob-match? "x[0-9][A-Z]x" "xA0x") #f) 42 | 43 | (check (glob-match? "x[0-9a]x" "x0x")) 44 | (check (glob-match? "x[0-9a]x" "xax")) 45 | (check (glob-match? "x[0-9a]x" "xbx") #f) 46 | (check (glob-match? "x[0-9a]x" "x-x") #f) 47 | (check (glob-match? "x[-0-9a]x" "x-x")) 48 | (check (glob-match? "x[0-9a-]x" "x-x")) 49 | (check (glob-match? "x[]0-9a]x" "x]x")) 50 | (check (glob-match? "x[]0-9a]x" "x0x")) 51 | (check (glob-match? "x[]0-9a]x" "x[x") #f) 52 | (check (glob-match? "x[a-]x" "x-x")) 53 | (check (glob-match? "x[a-]x" "x.x") #f) 54 | 55 | (check (glob-match? "x[^0-9a]x" "x_x")) 56 | (check (glob-match? "x[^0-9a]x" "x0x") #f) 57 | (check (glob-match? "x[^0-9a]x" "x5x") #f) 58 | (check (glob-match? "x[^0-9a]x" "x9x") #f) 59 | (check (glob-match? "x[^0-9a]x" "xax") #f) 60 | (check (glob-match? "x[^0-9a]x" "xbx")) 61 | (check (glob-match? "x[^0-9a]x" "xbx")) 62 | (check (glob-match? "x[^^]x" "xbx")) 63 | (check (glob-match? "x[^^]x" "x^x") #f) 64 | (check (glob-match? "x[^-]x" "x-x") #f) 65 | (check (glob-match? "x[^x]x" "x-x")) 66 | (check (glob-match? "x[^]]x" "x]x") #f) 67 | (check (glob-match? "x[^]]x" "x-x")) 68 | 69 | (check (glob-match? "**e" "apple")) 70 | (check (glob-match? "**" "apple")) 71 | (check (glob-match? "**z" "apple") #f) 72 | 73 | (check (procedure? (glob->matcher "a*c"))) 74 | (check ((glob->matcher "a*c") "abxyzc")) 75 | 76 | (define-syntax (check-glob-fail stx) 77 | `(check-fail (begin 78 | (require zuo/glob) 79 | ,(cadr stx)) 80 | ,(list-ref stx 2))) 81 | 82 | (check-glob-fail (glob-match? 10 "a") not-string) 83 | (check-glob-fail (glob-match? "a" 10) not-string) 84 | (check-glob-fail (glob->matcher 10) not-string) 85 | (check-glob-fail (glob->matcher "[") "unclosed square bracket") 86 | (check-glob-fail (glob->matcher "[]") "unclosed square bracket") 87 | (check-glob-fail (glob->matcher "[^]") "unclosed square bracket") 88 | (check-glob-fail (glob->matcher "[z-a]") "bad range") 89 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/struct.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | (require "and-or.zuo" 3 | "syntax-error.zuo" 4 | "../pair.zuo" 5 | "../list.zuo" 6 | "define.zuo" 7 | "let.zuo" 8 | "quasiquote.zuo" 9 | "../more.zuo") 10 | 11 | (provide struct) 12 | 13 | (define-syntax struct 14 | (lambda (stx) 15 | (unless (and (list? stx) 16 | (= (length stx) 3) 17 | (identifier? (cadr stx))) 18 | (bad-syntax stx)) 19 | (define name (cadr stx)) 20 | (define fields (cadr (cdr stx))) 21 | (unless (and (list? fields) 22 | (andmap identifier? fields)) 23 | (bad-syntax stx)) 24 | (define key `(,(quote-syntax quote) 25 | ,(string->uninterned-symbol (symbol->string (syntax-e name))))) 26 | (define name? (string->symbol (datum->syntax name (~a (syntax-e name) "?")))) 27 | `(,(quote-syntax begin) 28 | (,(quote-syntax define) ,name 29 | (,(quote-syntax lambda) 30 | ,fields 31 | (,(quote-syntax opaque) ,key 32 | (,(quote-syntax list) ,@fields)))) 33 | (,(quote-syntax define) (,name? v) (,(quote-syntax and) 34 | (,(quote-syntax opaque-ref) ,key v #f) 35 | #t)) 36 | ,@(let loop ([fields fields] [index 0]) 37 | (cond 38 | [(null? fields) '()] 39 | [else 40 | (let ([field (car fields)]) 41 | (let ([ref (datum->syntax field (string->symbol (~a (syntax-e name) 42 | "-" 43 | (syntax-e field))))] 44 | [set (datum->syntax field (string->symbol (~a (syntax-e name) 45 | "-set-" 46 | (syntax-e field))))]) 47 | (define mk 48 | (lambda (head res) 49 | `(,(quote-syntax define) ,head 50 | (,(quote-syntax let) 51 | ([c (,(quote-syntax opaque-ref) ,key v #f)]) 52 | (,(quote-syntax if) 53 | c 54 | ,res 55 | (,(quote-syntax arg-error) 56 | (,(quote-syntax quote) ,(car head)) 57 | ,(symbol->string (syntax-e name)) 58 | v)))))) 59 | (cons 60 | `(,(quote-syntax begin) 61 | ,(mk `(,ref v) `(,(quote-syntax list-ref) c ,index)) 62 | ,(mk `(,set v a) `(,(quote-syntax opaque) ,key (,(quote-syntax list-set) c ,index a)))) 63 | (loop (cdr fields) 64 | (+ index 1)))))]))))) 65 | -------------------------------------------------------------------------------- /tests/read+print.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "reading and printing") 6 | 7 | (check (string-read " 1 (apple) \n 2 \n\n" 0) '(1 (apple) 2)) 8 | (check (string-read " 1 (apple) \n 2 \n\n" 3) '((apple) 2)) 9 | (check (string-read "" 0) '()) 10 | (check (string-read "x" 1) '()) 11 | (check-fail (string-read "(" 0) "missing closer") 12 | (check-fail (string-read 'apple 0) not-string) 13 | (check-fail (string-read "x" "y") not-integer) 14 | (check-fail (string-read "x" 2) "out of bounds") 15 | (check-fail (string-read "x" -2) "out of bounds") 16 | 17 | (check (~v 1 '(apple) "banana") "1 (list 'apple) \"banana\"") 18 | (check (~v 1 '(apple . pie) (string->uninterned-symbol "banana")) "1 (cons 'apple 'pie) #") 19 | (check (~s 1 '(apple) "banana") "1 (apple) \"banana\"") 20 | (check (~s 1 '(apple . pie) (string->uninterned-symbol "banana")) "1 (apple . pie) #") 21 | (check (~a 1 '(apple) "banana") "1(apple)banana") 22 | (check (~a 1 '(apple . pie) (string->uninterned-symbol "banana")) "1(apple . pie)banana") 23 | 24 | (define table 25 | (list 26 | (list #t "#t" "#t" "#t") 27 | (list #f "#f" "#f" "#f") 28 | (list 1 "1" "1" "1") 29 | (list 0 "0" "0" "0") 30 | (list -1 "-1" "-1" "-1") 31 | (list 'apple "'apple" "apple" "apple") 32 | (list (string->uninterned-symbol "banana") "#" "#" "banana") 33 | (list "cherry" "\"cherry\"" "\"cherry\"" "cherry") 34 | (list (cons "cherry" 'pie) "(cons \"cherry\" 'pie)" "(\"cherry\" . pie)" "(cherry . pie)") 35 | (list (list* 1 2 3) "(list* 1 2 3)" "(1 2 . 3)" "(1 2 . 3)") 36 | (list (hash 'a "x") "(hash 'a \"x\")" "#hash((a . \"x\"))" "#hash((a . x))") 37 | (list apply "#" "#" "#") 38 | (list call/cc "#" "#" "#") 39 | (list (let ([f (lambda (x) x)]) f) "#" "#" "#") 40 | (list (opaque 'donut 5) "#" "#" "#") 41 | (list (variable 'elderberry) "#" "#" "#") 42 | (list (void) "#" "#" "#"))) 43 | 44 | (for-each (lambda (row) 45 | (apply (lambda (v pr wr di) 46 | (check (~v v) pr) 47 | (check (~s v) wr) 48 | (check (~a v) di)) 49 | row)) 50 | table) 51 | 52 | (check-output (alert "hello" 'x) "hello: 'x\n") 53 | (check-output (alert 'hello 'x) "'hello 'x\n") 54 | (check-output (alert 'hello 'x 3 4) "'hello 'x 3 4\n") 55 | (check-output (error "hello" 'x) "" "hello: 'x\n") 56 | (check-output (error 'hello 'x) "" "'hello 'x\n") 57 | (check-output (error 'hello 'x 3 4) "" "'hello 'x 3 4\n") 58 | 59 | (check-fail (arity-error 'hello '()) not-string) 60 | (check-fail (arity-error "hello" 'oops) "not a list") 61 | (check-output (arity-error "hello" '(1 () "apple")) "" "hello: wrong number of arguments: 1 '() \"apple\"\n") 62 | 63 | (check (~s (let loop ([i 10000]) 64 | (if (= i 0) 65 | '() 66 | (list (loop (- i 1)))))) 67 | (apply ~a 68 | (let loop ([i 10000] [accum '()]) 69 | (if (= i 0) 70 | (cons "()" accum) 71 | (cons "(" (loop (- i 1) (cons ")" accum))))))) 72 | -------------------------------------------------------------------------------- /zuo-doc/lang-zuo-hygienic.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require (for-label (except-in zuo-doc/fake-zuo 3 | identifier? 4 | syntax-e 5 | syntax->datum 6 | datum->syntax 7 | bound-identifier=?) 8 | zuo-doc/fake-zuo-hygienic) 9 | "real-racket.rkt") 10 | 11 | @title[#:tag "zuo-hygienic"]{Zuo with Hygienic Macros} 12 | 13 | @defmodulelang[zuo/hygienic #:no-declare #:packages ()] 14 | @declare-exporting[zuo/hygienic #:packages () #:use-sources(zuo-doc/fake-zuo-hygienic)] 15 | 16 | The @racketmodname[zuo/hygienic] language provides the same set of 17 | bindings as @racketmodname[zuo/base], but with hygienic macros. Its 18 | macro-expansion protocol uses a different representation of 19 | identifiers and binding scope, and different rules for 20 | @racket[quote-syntax] and macros: 21 | 22 | @itemlist[ 23 | 24 | @item{A @racketmodname[zuo/hygienic] term's representation always 25 | uses identifier syntax objects in place of symbols. A macro 26 | will never receive a plain symbol in its input, and if the 27 | macro produces a term with plain symbol, it is automatically 28 | coerced to a syntax object using the scope of the module that 29 | defines the macro.} 30 | 31 | @item{A syntax object's context includes a @defterm{set of scopes}, 32 | instead of just one @tech{scope}. Before expanding forms in a 33 | new context, a fresh scope representation is added to every 34 | identifier appearing within the context. An reference is 35 | resolved by finding the binding identifier with the most 36 | specific set of scopes that is a subset of the referencing 37 | identifier's scopes.} 38 | 39 | @item{In addition to binding contexts, a specific macro invocation is 40 | also represented by a scope: a fresh scope is added to every 41 | syntax object introduced by a macro expansion. This fresh scope 42 | means that an identifier introduced by the expansion can only 43 | bind identifiers that were introduced by the same expansion. 44 | Meanwhile, a @racket[quote-syntax]-imposed scope on an 45 | introduced identifier prevents it from being bound by an 46 | identifier that's at the macro-use site and not visible at the 47 | macro-definition site.} 48 | 49 | @item{The @racket[quote-syntax] form produces an identifier syntax 50 | object with all of its scope intact. That syntax object 51 | acquires additional scope if it is returned from a macro 52 | expander into a new context.} 53 | 54 | ] 55 | 56 | These differences particularly affect the functions that operate on 57 | @tech{syntax objects}: 58 | 59 | @deftogether[( 60 | @defproc[(identifier? [v any?]) boolean?] 61 | @defproc[(syntax-e [v identifier?]) symbol?] 62 | @defproc[(syntax->datum [v any?]) any?] 63 | @defproc[(datum->syntax [ctx identifier?] [v any?]) any?] 64 | @defproc[(bound-identifier=? [id1 identifier?] 65 | [id2 identifier?]) boolean?] 66 | )]{ 67 | 68 | Unlike the @racketmodname[zuo] function, @racket[identifier?] does not 69 | recognize a plain symbol as an identifier. The @racket[datum->syntax] 70 | function converts symbols in @racket[v] to syntax objects using the 71 | context of @racket[ctx].} 72 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/opt-lambda.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (require "../pair.zuo" 4 | "and-or.zuo" 5 | "syntax-error.zuo" 6 | "define-help.zuo" 7 | "let.zuo") 8 | 9 | (provide (rename-out [opt-lambda lambda])) 10 | 11 | (define-syntax opt-lambda 12 | (context-consumer 13 | (lambda (stx free=? name) 14 | (unless (and (list? stx) (>= (length stx) 3)) (bad-syntax stx)) 15 | (let* ([args (cadr stx)] 16 | [plain? (let loop ([args args]) 17 | (cond 18 | [(null? args) #t] 19 | [(identifier? args) #t] 20 | [else (and (pair? args) 21 | (identifier? (car args)) 22 | (loop (cdr args)))]))]) 23 | (cond 24 | [plain? 25 | (cons (quote-syntax lambda) (cdr stx))] 26 | [else 27 | (let ([all-args (check-args stx args)]) 28 | (let loop ([args args] [rev-plain-args '()]) 29 | (cond 30 | [(identifier? (car args)) 31 | (loop (cdr args) (cons (car args) rev-plain-args))] 32 | [else 33 | (let* ([args-id (string->uninterned-symbol "args")]) 34 | (list (quote-syntax lambda) 35 | (append (reverse rev-plain-args) args-id) 36 | (let loop ([args args]) 37 | (cond 38 | [(null? args) 39 | (list (quote-syntax if) (list (quote-syntax null?) args-id) 40 | (cons (quote-syntax let) (cons (list) (cddr stx))) 41 | (list (quote-syntax opt-arity-error) 42 | (list (quote-syntax quote) name) 43 | (cons (quote-syntax list) 44 | all-args) 45 | args-id))] 46 | [(identifier? args) 47 | (cons (quote-syntax let) 48 | (cons (list (list args args-id)) 49 | (cddr stx)))] 50 | [else 51 | (list (quote-syntax let) 52 | (list (list (caar args) 53 | (list (quote-syntax if) 54 | (list (quote-syntax null?) args-id) 55 | (car (cdar args)) 56 | (list (quote-syntax car) args-id)))) 57 | (list (quote-syntax let) 58 | (list (list args-id 59 | (list (quote-syntax if) 60 | (list (quote-syntax null?) args-id) 61 | (quote-syntax '()) 62 | (list (quote-syntax cdr) args-id)))) 63 | (loop (cdr args))))]))))])))]))))) 64 | 65 | (define opt-arity-error 66 | (lambda (name base-args extra-args) 67 | (arity-error name (append base-args extra-args)))) 68 | -------------------------------------------------------------------------------- /lib/zuo/private/base-common/bind-struct.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; simple transparent structs 4 | (define (make-maker tag) (lambda (v) (cons tag v))) 5 | (define (make-? tag) (lambda (v) (and (pair? v) (eq? tag (car v))))) 6 | (define (make-?? tag1 tag2) (lambda (v) (and (pair? v) (or (eq? tag1 (car v)) 7 | (eq? tag2 (car v)))))) 8 | (define any-ref cdr) ; not bothering to check a tag 9 | 10 | ;; A binding that's a core form recognized by the expander 11 | (define make-core-form (make-maker 'core-form)) 12 | (define core-form? (make-? 'core-form)) 13 | (define form-id any-ref) 14 | 15 | ;; A binding for a local variable 16 | (define make-local (make-maker 'local)) 17 | (define local? (make-? 'local)) 18 | (define local-id any-ref) 19 | 20 | ;; A binding for a definition 21 | (define make-defined (make-maker 'defined)) 22 | (define defined? (make-? 'defined)) 23 | 24 | ;; A `letrec` bindind or an imported definition 25 | (define make-local-variable (make-maker 'local-variable)) 26 | 27 | ;; A `variable` is a definition or `letrec` 28 | (define variable? (make-?? 'local-variable 'defined)) 29 | (define variable-var any-ref) 30 | 31 | ;; A macro is specifically an imported macro: 32 | (define make-macro (make-maker macro-protocol)) 33 | (define macro-implementation any-ref) 34 | 35 | ;; A macro defined in the current moddule: 36 | (define make-defined-macro (make-maker 'defined-macro)) 37 | (define defined-macro? (make-? 'defined-macro)) 38 | (define defined-macro-proc any-ref) 39 | 40 | ;; Imported or current-module macro 41 | (define macro? (make-?? macro-protocol 'defined-macro)) 42 | 43 | ;; A `literal` wrapper is needed for a pair as a value; any 44 | ;; other kind of value is distinct from our "record"s 45 | (define make-literal (make-maker 'literal)) 46 | (define literal? (make-? 'literal)) 47 | (define literal-val any-ref) 48 | 49 | ;; Wraps a binding to indicate that's from the initial import, 50 | ;; so it's shadowable by `require` 51 | (define make-initial-import (make-maker 'initial)) 52 | (define initial-import? (make-? 'initial)) 53 | (define initial-import-bind any-ref) 54 | 55 | ;; Wraps a binding to give it an identity that persists across 56 | ;; imports 57 | (define make-specific (make-maker 'specific)) 58 | (define specific? (make-? 'specific)) 59 | (define (specific-label s) (cdr (any-ref s))) 60 | 61 | (define (unwrap-specific v) 62 | (if (specific? v) 63 | (car (any-ref v)) 64 | v)) 65 | 66 | (define (as-specific v) 67 | (make-specific (cons v (string->uninterned-symbol "u")))) 68 | 69 | (define (specific=? a b) 70 | (if (specific? a) 71 | (if (specific? b) 72 | (eq? (specific-label a) (specific-label b)) 73 | #f) 74 | (eq? a b))) 75 | 76 | ;; bubbles `specific` outside `initial-import` 77 | (define (initial-import bind) 78 | (let* ([label (and (specific? bind) 79 | (specific-label bind))] 80 | [bind (unwrap-specific bind)] 81 | [bind (make-initial-import bind)]) 82 | (if label 83 | (make-specific (cons bind label)) 84 | bind))) 85 | 86 | (define context-consumer-key (string->uninterned-symbol "ctxer")) 87 | (define (context-consumer proc) 88 | (unless (procedure? proc) (error "context-consumer: not a procedure" proc)) 89 | (opaque context-consumer-key proc)) 90 | (define (context-consumer? v) (and (opaque-ref context-consumer-key v #f) #t)) 91 | (define (context-consumer-procedure v) (opaque-ref context-consumer-key v #f)) 92 | -------------------------------------------------------------------------------- /tests/module-path.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "module paths") 6 | 7 | (check (module-path? 'zuo)) 8 | (check (module-path? 'zuo/main)) 9 | (check (module-path? 'zuo/private/main)) 10 | (check (module-path? '/zuo) #f) 11 | (check (module-path? 'zuo/) #f) 12 | (check (module-path? 'zuo//main) #f) 13 | (check (module-path? 'zuo?) #f) 14 | (check (module-path? 'zuo/?/x) #f) 15 | 16 | (check (module-path? "main.zuo")) 17 | (check (module-path? "private/main.zuo")) 18 | (check (module-path? "private/../main.zuo")) 19 | (check (module-path? "./../main.zuo")) 20 | (check (module-path? "main")) 21 | (check (module-path? "main.rkt")) 22 | (check (module-path? " main.zuo ")) 23 | (check (module-path? "") #f) 24 | (check (module-path? "a\x00b") #f) 25 | 26 | (check (module-path? 1) #f) 27 | (check (module-path? '(zuo)) #f) 28 | 29 | (check (build-module-path 'zuo "list.zuo") 'zuo/list) 30 | (check (build-module-path 'zuo/main "list.zuo") 'zuo/list) 31 | (check (build-module-path 'zuo/private/main "list.zuo") 'zuo/private/list) 32 | (check (build-module-path 'zuo "helper/list.zuo") 'zuo/helper/list) 33 | (check (build-module-path 'zuo/main "helper/list.zuo") 'zuo/helper/list) 34 | (check (build-module-path 'zuo/private/main "helper/list.zuo") 'zuo/private/helper/list) 35 | (check (build-module-path 'zuo/private/main "../list.zuo") 'zuo/list) 36 | (check (build-module-path 'zuo/private/main "./list.zuo") 'zuo/private/list) 37 | (check (build-module-path 'zuo/private/main "./././../././list.zuo") 'zuo/list) 38 | (check-arg-fail (build-module-path 'zuo "list") "lacks \".zuo\"") 39 | (check-arg-fail (build-module-path 'zuo "../list.zuo") "too many up elements") 40 | (check-arg-fail (build-module-path 'zuo "x//list.zuo") "not a relative module library path") 41 | (check-arg-fail (build-module-path 'zuo "..//list.zuo") "not a relative module library path") 42 | (check-arg-fail (build-module-path 'zuo "list@.zuo") "not a relative module library path") 43 | (check-arg-fail (build-module-path 'zuo "@/list.zuo") "not a relative module library path") 44 | (check-arg-fail (build-module-path 'zuo "list.rkt") "not a relative module library path") 45 | (check-arg-fail (build-module-path 'zuo "x.y/list.zuo") "not a relative module library path") 46 | 47 | (check (build-module-path "lib/zuo/main.zuo" "list.zuo") "lib/zuo/list.zuo") 48 | (check (build-module-path "lib/zuo/main.zuo" "../list.zuo") "lib/list.zuo") 49 | (check (build-module-path "lib.zuo" "list.zuo") "list.zuo") 50 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "list") "lacks \".zuo\"") 51 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "x//list.zuo") "not a relative module library path") 52 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "..//list.zuo") "not a relative module library path") 53 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "list@.zuo") "not a relative module library path") 54 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "@/list.zuo") "not a relative module library path") 55 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "list.rkt") "not a relative module library path") 56 | (check-arg-fail (build-module-path "lib/zuo/main.zuo" "x.y/list.zuo") "not a relative module library path") 57 | 58 | (check-arg-fail (build-module-path "" "x.zuo") "not a module path") 59 | (check-arg-fail (build-module-path 1 "x.zuo") "not a module path") 60 | (check-arg-fail (build-module-path "main.zuo" 1) "not a module path") 61 | (check-arg-fail (build-module-path 'zuo 1) "not a module path") 62 | 63 | (check (hash? (module->hash 'zuo))) 64 | (check-arg-fail (module->hash 8) "not a module path") 65 | -------------------------------------------------------------------------------- /tests/macro-common.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (define macro-dir (build-path tmp-dir "macros")) 4 | (rm* macro-dir) 5 | (mkdir macro-dir) 6 | 7 | (check ((lambda lambda lambda) 3) '(3)) 8 | (check (let ([let 10]) let) 10) 9 | (check (let ([let 11]) (let* ([let let]) let)) 11) 10 | (check (let ([quote list]) '1) '(1)) 11 | 12 | (let () 13 | (define-syntax (let-one stx) 14 | (list (quote-syntax let) 15 | (list (list (cadr stx) 1)) 16 | (cadr (cdr stx)))) 17 | (check (let-one x (list x x)) '(1 1)) 18 | (check (let-one x (let ([let 0]) (list x let x))) '(1 0 1))) 19 | 20 | (let ([five 5]) 21 | (define-syntax (let-five stx) 22 | (list (quote-syntax let) 23 | (list (list (cadr stx) (quote-syntax five))) 24 | (cadr (cdr stx)))) 25 | (check (let-five x (list x x)) '(5 5)) 26 | (check (let-five x (let ([five 10]) (list x x))) '(5 5)) 27 | (check (let ([five 10]) (let-five x (list x x))) '(5 5))) 28 | 29 | (define (make-file* path content) 30 | (let ([fd (fd-open-output (build-path macro-dir path) :truncate)]) 31 | (fd-write fd (~a "#lang " lang-name "\n" 32 | (~s (cons 'begin content)))) 33 | (fd-close fd))) 34 | 35 | (define-syntax (make-file stx) 36 | (list (quote-syntax make-file*) 37 | (cadr stx) 38 | (cons (quote-syntax list) 39 | (map (lambda (c) (list (quote-syntax quote) c)) 40 | (cddr stx))))) 41 | 42 | (make-file "exports-macro.zuo" 43 | (provide macro) 44 | (define (my-list . x) x) 45 | (define-syntax (macro stx) 46 | (list (quote-syntax my-list) 47 | (cadr stx) 48 | (cadr stx)))) 49 | 50 | (make-file "uses-macro.zuo" 51 | (require "exports-macro.zuo") 52 | (provide macro-to-macro) 53 | (define hello "hi") 54 | (macro hello) 55 | (define-syntax (macro-to-macro stx) 56 | (list (quote-syntax list) 57 | (list (quote-syntax macro) (cadr stx)) 58 | (list (quote-syntax macro) (cadr stx))))) 59 | 60 | (run-zuo* (list (build-path macro-dir "uses-macro.zuo")) 61 | "" 62 | (lambda (status out err) 63 | (check err "") 64 | (check status 0) 65 | (check out "(list \"hi\" \"hi\")\n"))) 66 | 67 | (make-file "uses-macro-to-macro.zuo" 68 | (require "uses-macro.zuo") 69 | (define-syntax (go stx) (quote-syntax 'went)) 70 | (macro-to-macro go)) 71 | 72 | (run-zuo* (list (build-path macro-dir "uses-macro-to-macro.zuo")) 73 | "" 74 | (lambda (status out err) 75 | (check err "") 76 | (check status 0) 77 | (check out "(list \"hi\" \"hi\")\n(list (list 'went 'went) (list 'went 'went))\n"))) 78 | 79 | (make-file "exports-helper.zuo" 80 | (provide doubled) 81 | (define (my-list . x) x) 82 | (define (doubled stx) 83 | (list (quote-syntax my-list) 84 | stx 85 | stx))) 86 | 87 | (make-file "uses-helper.zuo" 88 | (provide macro) 89 | (require "exports-helper.zuo") 90 | (define-syntax (macro stx) 91 | (doubled (cadr stx)))) 92 | 93 | (make-file "uses-macro-with-helper.zuo" 94 | (require "uses-helper.zuo") 95 | (define hello "hi") 96 | (macro hello)) 97 | 98 | (run-zuo* (list (build-path macro-dir "uses-macro-with-helper.zuo")) 99 | "" 100 | (lambda (status out err) 101 | (check err "") 102 | (check status 0) 103 | (check out "(list \"hi\" \"hi\")\n"))) 104 | -------------------------------------------------------------------------------- /zuo-doc/fake-zuo.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define-syntax-rule (define-fake id ...) 4 | (begin 5 | (provide id ...) 6 | (define id 'id) ...)) 7 | 8 | (define-syntax-rule (intro-define-fake) 9 | (define-fake 10 | lambda 11 | let 12 | let* 13 | letrec 14 | if 15 | and 16 | or 17 | when 18 | unless 19 | begin 20 | cond 21 | quote 22 | quasiquote 23 | unquote 24 | unquote-splicing 25 | quote-syntax 26 | 27 | define 28 | define-syntax 29 | include 30 | require 31 | provide 32 | module+ 33 | quote-module-path 34 | 35 | pair? 36 | null? 37 | integer? 38 | string? 39 | symbol? 40 | hash? 41 | list? 42 | procedure? 43 | path-string? 44 | module-path? 45 | relative-path? 46 | handle? 47 | boolean? 48 | void 49 | 50 | apply 51 | call/cc 52 | context-consumer 53 | context-consumer? 54 | 55 | cons 56 | car 57 | cdr 58 | list 59 | append 60 | reverse 61 | length 62 | member 63 | assoc 64 | remove 65 | list-ref 66 | list-set 67 | 68 | not 69 | eq? 70 | equal? 71 | void? 72 | 73 | + 74 | - 75 | * 76 | quotient 77 | modulo 78 | < 79 | <= 80 | = 81 | >= 82 | > 83 | bitwise-and 84 | bitwise-ior 85 | bitwise-xor 86 | bitwise-not 87 | 88 | string-length 89 | string-ref 90 | string-u32-ref 91 | substring 92 | string=? 93 | string-ci=? 94 | string->symbol 95 | string->uninterned-symbol 96 | symbol->string 97 | string 98 | string-sha1 99 | char 100 | string-split string-join string-trim 101 | 102 | hash 103 | hash-ref 104 | ref 105 | hash-set 106 | hash-remove 107 | hash-keys 108 | hash-count 109 | hash-keys-subset? 110 | 111 | opaque 112 | opaque-ref 113 | 114 | build-path 115 | split-path 116 | at-source 117 | 118 | variable? 119 | variable 120 | variable-ref 121 | variable-set! 122 | 123 | identifier? 124 | syntax-e 125 | syntax->datum 126 | datum->syntax 127 | bound-identifier=? 128 | syntax-error 129 | bad-syntax 130 | misplaced-syntax 131 | duplicate-identifier 132 | 133 | fd-open-input 134 | fd-open-output 135 | fd-close 136 | fd-read 137 | fd-write 138 | eof 139 | fd-terminal? 140 | file->string 141 | display-to-file 142 | 143 | stat 144 | ls rm mv mkdir rmdir ln readlink cp 145 | current-time 146 | system-type 147 | file-exists? 148 | directory-exists? 149 | link-exists? 150 | explode-path 151 | simple-form-path 152 | find-relative-path 153 | build-raw-path 154 | path-replace-suffix 155 | path-only 156 | file-name-from-path 157 | path->complete-path 158 | rm* cp* mkdir* 159 | :error :truncate :must-truncate :append :update :can-update 160 | cleanable-file 161 | cleanable-cancel 162 | 163 | process 164 | process-status 165 | process-wait 166 | find-executable-path 167 | shell->strings 168 | string->shell 169 | 170 | error 171 | alert 172 | ~v 173 | ~a 174 | ~s 175 | arity-error 176 | arg-error 177 | display displayln 178 | 179 | string-read 180 | module->hash 181 | build-module-path 182 | kernel-env 183 | kernel-eval 184 | 185 | runtime-env 186 | dump-image-and-exit 187 | exit 188 | suspend-signal resume-signal 189 | 190 | command-line 191 | 192 | target 193 | rule 194 | phony-rule 195 | input-file-target 196 | input-data-target 197 | target-path 198 | target-name 199 | target? 200 | token? 201 | rule? 202 | phony-rule? 203 | sha1? 204 | file-sha1 205 | no-sha1 206 | build 207 | build/command-line 208 | build/command-line* 209 | build/recur 210 | provide-targets 211 | find-target 212 | 213 | shell 214 | shell/wait 215 | build-shell 216 | 217 | call-in-main-thread 218 | thread? thread channel? channel channel-put channel-get 219 | thread-process-wait 220 | config-file->hash)) 221 | 222 | (intro-define-fake) 223 | -------------------------------------------------------------------------------- /tests/kernel.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "kernel eval") 6 | 7 | (define bad-kernel-stx "bad kernel syntax") 8 | 9 | (check (kernel-eval 1) 1) 10 | (check (kernel-eval 'cons) cons) 11 | 12 | (check (kernel-eval '(cons 1 2)) '(1 . 2)) 13 | (check-fail (kernel-eval '(cons 1 . 2)) bad-kernel-stx) 14 | (check-fail (kernel-eval '(cons . 2)) bad-kernel-stx) 15 | 16 | (check (procedure? (kernel-eval '(lambda (x) x))) #t) 17 | (check (procedure? (kernel-eval '(lambda (x x) x))) #t) 18 | (check (procedure? (kernel-eval '(lambda (x . x) x))) #t) 19 | (check (procedure? (kernel-eval '(lambda (x x) "name" x))) #t) 20 | (check ((kernel-eval '(lambda (x x) x)) #f 2) 2) 21 | (check ((kernel-eval '(lambda (x x . x) x)) #f 2 3 4) '(3 4)) 22 | (check-fail (kernel-eval '(lambda)) bad-kernel-stx) 23 | (check-fail (kernel-eval '(lambda . x)) bad-kernel-stx) 24 | (check-fail (kernel-eval '(lambda x)) bad-kernel-stx) 25 | (check-fail (kernel-eval '(lambda (x x))) bad-kernel-stx) 26 | (check-fail (kernel-eval '(lambda (x x . x) . x)) bad-kernel-stx) 27 | (check-fail (kernel-eval '(lambda (x y . x) . x)) bad-kernel-stx) 28 | (check-fail (kernel-eval '(lambda (x x . 5) x)) bad-kernel-stx) 29 | (check-fail (kernel-eval '(lambda 5 x)) bad-kernel-stx) 30 | (check-fail (kernel-eval '(lambda x #f 2)) bad-kernel-stx) 31 | (check-fail (kernel-eval '(lambda x #f . 2)) bad-kernel-stx) 32 | (check-fail (kernel-eval 'lambda) "undefined: 'lambda") 33 | (check (((kernel-eval '(lambda (lambda) (lambda x x))) 1) 2) '(2)) 34 | 35 | (check (kernel-eval '(quote cons)) 'cons) 36 | (check-fail (kernel-eval '(quote)) bad-kernel-stx) 37 | (check-fail (kernel-eval '(quote cons list)) bad-kernel-stx) 38 | (check-fail (kernel-eval '(quote . cons)) bad-kernel-stx) 39 | (check-fail (kernel-eval '(quote cons . list)) bad-kernel-stx) 40 | (check-fail (kernel-eval 'quote) "undefined: 'quote") 41 | 42 | (check (kernel-eval '(if #t 1 2)) 1) 43 | (check (kernel-eval '(if 0 1 2)) 1) 44 | (check (kernel-eval '(if #f 1 2)) 2) 45 | (check-fail (kernel-eval '(if)) bad-kernel-stx) 46 | (check-fail (kernel-eval '(if . 1)) bad-kernel-stx) 47 | (check-fail (kernel-eval '(if 1)) bad-kernel-stx) 48 | (check-fail (kernel-eval '(if 1 . 2)) bad-kernel-stx) 49 | (check-fail (kernel-eval '(if 1 2)) bad-kernel-stx) 50 | (check-fail (kernel-eval '(if 1 2 . 3)) bad-kernel-stx) 51 | (check-fail (kernel-eval '(if 1 2 3 . 4)) bad-kernel-stx) 52 | (check-fail (kernel-eval '(if 1 2 3 4)) bad-kernel-stx) 53 | (check-fail (kernel-eval 'if) "undefined: 'if") 54 | 55 | (check (kernel-eval '(let ([x 1]) x)) 1) 56 | (check (kernel-eval '(let ([x 1]) (let ([x 2]) x))) 2) 57 | (check (kernel-eval '(let ([x 1]) (list (let ([x 2]) x) x))) '(2 1)) 58 | (check-fail (kernel-eval '(let)) bad-kernel-stx) 59 | (check-fail (kernel-eval '(let . x)) bad-kernel-stx) 60 | (check-fail (kernel-eval '(let ())) bad-kernel-stx) 61 | (check-fail (kernel-eval '(let () x)) bad-kernel-stx) 62 | (check-fail (kernel-eval '(let (x) x)) bad-kernel-stx) 63 | (check-fail (kernel-eval '(let ([x]) x)) bad-kernel-stx) 64 | (check-fail (kernel-eval '(let ([x . 1]) x)) bad-kernel-stx) 65 | (check-fail (kernel-eval '(let ([x 1 . 2]) x)) bad-kernel-stx) 66 | (check-fail (kernel-eval '(let ([x 1 2]) x)) bad-kernel-stx) 67 | (check-fail (kernel-eval '(let ([1 2]) x)) bad-kernel-stx) 68 | (check-fail (kernel-eval '(let ([x 2] . y) x)) bad-kernel-stx) 69 | (check-fail (kernel-eval '(let ([x 2] y) x)) bad-kernel-stx) 70 | (check-fail (kernel-eval '(let ([x 2]))) bad-kernel-stx) 71 | (check-fail (kernel-eval '(let ([x 2]) . x)) bad-kernel-stx) 72 | (check-fail (kernel-eval '(let ([x 2]) x . x)) bad-kernel-stx) 73 | (check-fail (kernel-eval '(let ([x 2]) x x)) bad-kernel-stx) 74 | (check-fail (kernel-eval 'let) "undefined: 'let") 75 | 76 | (check (kernel-eval '(begin 1)) 1) 77 | (check (kernel-eval '(begin 1 2)) 2) 78 | (check (kernel-eval '(begin 1 2 3 4)) 4) 79 | (check-fail (kernel-eval '(begin)) bad-kernel-stx) 80 | (check-fail (kernel-eval '(begin . 1)) bad-kernel-stx) 81 | (check-fail (kernel-eval '(begin 1 2 3 . 4)) bad-kernel-stx) 82 | (check-fail (kernel-eval 'begin) "undefined: 'begin") 83 | 84 | (check (andmap (lambda (k) 85 | (eq? (kernel-eval k) (hash-ref (kernel-env) k #f))) 86 | (hash-keys (kernel-env)))) 87 | 88 | (check (kernel-eval 89 | (let loop ([i 10000]) 90 | (if (= i 0) 91 | "ok" 92 | `(kernel-eval ',(loop (- i 1)))))) 93 | "ok") 94 | -------------------------------------------------------------------------------- /zuo-doc/lang-zuo-kernel.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require (for-label zuo-doc/fake-kernel 3 | (except-in zuo-doc/fake-zuo 4 | lambda 5 | let 6 | quote 7 | if 8 | define 9 | begin)) 10 | "real-racket.rkt") 11 | 12 | @title[#:tag "zuo-kernel"]{Zuo Kernel Language} 13 | 14 | @defmodulelang[zuo/kernel #:no-declare #:packages ()] 15 | @declare-exporting[zuo-doc/fake-kernel #:packages ()] 16 | 17 | The body of a @racketmodname[zuo/kernel] module is a single expression 18 | using a set of core @seclink["kernel-syntax"]{syntactic forms} 19 | and @seclink["kernel-primitives"]{primitives}. The expression 20 | must produce a @tech{hash table} that serves as the module's 21 | representation (see @secref["module-protocol"]). 22 | 23 | 24 | @section[#:tag "kernel-syntax"]{Syntactic Forms} 25 | 26 | @deftogether[( 27 | @defform[#:link-target? #f #:id not-id id] 28 | @defform[#:link-target? #f #:id not-literal literal] 29 | @defform[#:link-target? #f #:id not-expr (expr expr ...)] 30 | @defform[(lambda formals maybe-name maybe-arity-mask expr) 31 | #:grammar ([formals (id ...) 32 | id 33 | (id ... . id)] 34 | [maybe-name string 35 | code:blank] 36 | [maybe-arity-mask integer 37 | code:blank])] 38 | @defform[(quote datum)] 39 | @defform[(if expr expr expr)] 40 | @defform[(let ([id expr]) expr)] 41 | @defform[(begin expr ...+)] 42 | )]{ 43 | 44 | These forms are analogous to a variable reference, literal, procedure 45 | application, @realracket*[lambda quote if let begin] in 46 | @racketmodname[racket], but often restricted to a single expression or 47 | binding clause. Unlike the corresponding @racketmodname[racket] or 48 | @racketmodname[zuo] forms, the names of syntactic forms are not 49 | shadowed by a @racket[lambda] or @racket[let] binding, and they refer 50 | to syntactic forms only at the head of a term. A reference to an 51 | unbound variable is a run-time error. If an @racket[id] appears 52 | multiple times in @racket[formals], the last instance shadows the 53 | others. 54 | 55 | A @racket[lambda] form can optionally include a name and/or 56 | arity mask. If an arity mask is provided, it must be a subset of the mask 57 | implied by the @racket[formals]. If @racket[formals] allows 63 or more 58 | arguments, then it must allow any number of arguments (to be 59 | consistent with the possible arities expressed by a mask). 60 | 61 | Although @racket[let] and @racket[begin] could be encoded with 62 | @racket[lambda] easily enough, they're useful shortcuts to make 63 | explicit internally.} 64 | 65 | 66 | @section[#:tag "kernel-primitives"]{Primitives} 67 | 68 | The following names provided by @racketmodname[zuo] are also available 69 | in @racketmodname[zuo/kernel] (and the values originate there): 70 | 71 | @racketblock[ 72 | 73 | pair? null? list? cons car cdr list append reverse length 74 | list-ref list-set 75 | 76 | integer? + - * quotient modulo < <= = >= > 77 | bitwise-and bitwise-ior bitwise-xor bitwise-not 78 | 79 | string? string-length string-ref string-u32-ref substring string 80 | string=? string-ci=? string-sha1 81 | 82 | symbol? symbol->string string->symbol string->uninterned-symbol 83 | 84 | hash? hash hash-ref hash-set hash-remove 85 | hash-keys hash-count hash-keys-subset? 86 | 87 | procedure? apply call/cc call/prompt 88 | 89 | eq? not void 90 | 91 | opaque opaque-ref 92 | 93 | path-string? build-path build-raw-path split-path relative-path? 94 | module-path? build-module-path 95 | 96 | variable? variable variable-ref variable-set! 97 | 98 | handle? fd-open-input fd-open-output fd-close fd-read fd-write eof 99 | fd-terminal? cleanable-file cleanable-cancel 100 | 101 | stat ls rm mv mkdir rmdir ln readlink cp runtime-env current-time 102 | 103 | process process-status process-wait string->shell shell->strings 104 | 105 | string-read ~v ~a ~s alert error arity-error arg-error 106 | 107 | kernel-env kernel-eval module->hash dump-image-and-exit exit 108 | suspend-signal resume-signal 109 | 110 | ] 111 | -------------------------------------------------------------------------------- /tests/string.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "strings") 6 | 7 | (check (string? "apple")) 8 | (check (string? "")) 9 | (check (not (string? 'apple))) 10 | (check (not (string? 10))) 11 | 12 | (check (string 48 97) "0a") 13 | (check (string) "") 14 | (check-fail (string -1) "not an integer in [0, 255]") 15 | (check-fail (string 256) "not an integer in [0, 255]") 16 | (check-fail (string "a") "not an integer in [0, 255]") 17 | 18 | (check (string-length "") 0) 19 | (check (string-length "apple") 5) 20 | (check-fail (string-length 'apple) not-string) 21 | 22 | (check (string-ref "0123" 0) 48) 23 | (check (string-ref "0123" 2) 50) 24 | (check-fail (string-ref "0123" 4) "out of bounds") 25 | (check-fail (string-ref "0123" -1) "out of bounds") 26 | 27 | (check (substring "0123" 0 0) "") 28 | (check (substring "0123" 0 1) "0") 29 | (check (substring "0123" 0 4) "0123") 30 | (check (substring "0123" 4 4) "") 31 | (check-fail (substring "0123" -1 0) "out of bounds") 32 | (check-fail (substring "0123" 5 6) "out of bounds") 33 | (check-fail (substring "0123" -1 5) "out of bounds") 34 | (check-fail (substring "0123" 1 5) "out of bounds") 35 | (check-fail (substring "0123" 1 0) "index less than starting") 36 | 37 | (check (string-u32-ref "\x00\x00\x00\x00" 0) 0) 38 | (check (string-u32-ref "\x00\x04\x04\x00" 0) (+ (* 256 4) (* 256 256 4))) 39 | (check (string-u32-ref "\x03\x00\x00\x03" 0) (+ 3 (* 256 256 256 3))) 40 | (check (string-u32-ref "\xff\x00\x00\xff" 0) (+ 255 (* 256 256 256 255))) 41 | 42 | (check (string-u32-ref "__\x00\x00\x00\x00!" 2) 0) 43 | (check (string-u32-ref "__\x00\x04\x04\x00!" 2) (+ (* 256 4) (* 256 256 4))) 44 | (check (string-u32-ref "__\x03\x00\x00\x03!" 2) (+ 3 (* 256 256 256 3))) 45 | (check (string-u32-ref "__\xff\x00\x00\xff!" 2) (+ 255 (* 256 256 256 255))) 46 | 47 | (check (char "0") 48) 48 | (check (char "\xff") 255) 49 | (check-fail (char) bad-stx) 50 | (check-fail (char "0" "more") bad-stx) 51 | (check-fail (char . "0") bad-stx) 52 | 53 | (check (string-split " apple pie " " ") '("" "apple" "pie" "" "")) 54 | (check (string-split "__apple____pie__" "__") '("" "apple" "" "pie" "")) 55 | (check (string-split " apple pie ") '("apple" "pie")) 56 | (check-fail (string-split 10) not-string) 57 | (check-fail (string-split "apple" "") "not a nonempty string") 58 | 59 | (check (string-join '("a" "b" "c")) "a b c") 60 | (check (string-join '("a" "b" "c") "x") "axbxc") 61 | (check (string-join '("a" "b" "c") "") "abc") 62 | (check (string-join '()) "") 63 | (check (string-join '() "x") "") 64 | (check-fail (string-join 10) "not a list of strings") 65 | (check-fail (string-join '("x") 10) not-string) 66 | 67 | (check (string-trim " a ") "a") 68 | (check (string-trim " a b c ") "a b c") 69 | (check (string-trim " a " " ") " a ") 70 | (check (string-trim " a " " ") " a ") 71 | (check-fail (string-trim 10) not-string) 72 | (check-fail (string-trim "apple" "") "not a nonempty string") 73 | 74 | (let ([s "hello! / \\ \\\\ // \\\" \"\\ the:re/547\\65\"13\"2-*()*^$*&^'|'&~``'"]) 75 | (let i-loop ([i 0]) 76 | (let j-loop ([j i]) 77 | (let* ([s (substring s i j)]) 78 | (check (shell->strings (string->shell s)) (list s)) 79 | (check (shell->strings (~a " " (string->shell s) " ")) (list s))) 80 | (unless (= j (string-length s)) (j-loop (+ j 1)))) 81 | (unless (= i (string-length s)) (i-loop (+ i 1))))) 82 | 83 | (check (string-sha1 "hello\n") "f572d396fae9206628714fb2ce00f72e94f2258f") 84 | 85 | (check (string->integer "10") 10) 86 | (check (string->integer "-10") -10) 87 | (check (string->integer "-0") 0) 88 | (check (string->integer "-") #f) 89 | (check (string->integer "") #f) 90 | (check (string->integer "12x") #f) 91 | (check (string->integer "9223372036854775807") 9223372036854775807) 92 | (check (string->integer "9223372036854775808") #f) 93 | (check (string->integer "-9223372036854775807") -9223372036854775807) 94 | (check (string->integer "-9223372036854775808") -9223372036854775808) 95 | (check (string->integer "-9223372036854775809") #f) 96 | (check (string->integer "000000000000000000000007") 7) 97 | (check-fail (string->integer 1) not-string) 98 | 99 | (check (string= n 0)) (arg-error 'list-tail "index" n)) 25 | (letrec ([list-tail (lambda (n l) 26 | (cond 27 | [(= n 0) l] 28 | [(pair? l) (list-tail (- n 1) (cdr l))] 29 | [else (error "list-tail: encountered a non-pair" l)]))]) 30 | (list-tail n l)))) 31 | 32 | (define foldl 33 | (lambda (f init lst) 34 | (unless (procedure? f) (arg-error 'foldl "procedure" f)) 35 | (unless (list? lst) (arg-error 'foldl "list" lst)) 36 | (letrec ([foldl (lambda (accum lst) 37 | (if (null? lst) 38 | accum 39 | (foldl (f (car lst) accum) (cdr lst))))]) 40 | (foldl init lst)))) 41 | 42 | ;; Other functions could be written with `foldl`, but we write them 43 | ;; directly so that a more helpful name shows up stack traces 44 | 45 | (define map 46 | (lambda (f lst . lsts) 47 | (unless (procedure? f) (arg-error 'map "procedure" f)) 48 | (unless (list? lst) (arg-error 'map "list" lst)) 49 | (cond 50 | [(null? lsts) 51 | (letrec ([map (lambda (lst) 52 | (if (null? lst) 53 | '() 54 | (cons (f (car lst)) (map (cdr lst)))))]) 55 | (map lst))] 56 | [else 57 | (letrec ([check (lambda (lsts) 58 | (unless (null? lsts) 59 | (unless (list? (car lsts)) 60 | (arg-error 'map "list" (car lsts))) 61 | (unless (= (length lst) (length (car lsts))) 62 | (error "map: lists have different lengths" (cons lst lsts))) 63 | (check (cdr lsts))))]) 64 | (check lsts)) 65 | (let ([map1 map]) 66 | (letrec ([map (lambda (lsts) 67 | (if (null? (car lsts)) 68 | '() 69 | (cons (apply f (map1 car lsts)) 70 | (map (map1 cdr lsts)))))]) 71 | (map (cons lst lsts))))]))) 72 | 73 | (define for-each 74 | (lambda (f lst) 75 | (unless (procedure? f) (arg-error 'for-each "procedure" f)) 76 | (unless (list? lst) (arg-error 'for-each "list" lst)) 77 | (letrec ([for-each (lambda (lst) 78 | (unless (null? lst) 79 | (f (car lst)) 80 | (for-each (cdr lst))))]) 81 | (for-each lst)))) 82 | 83 | (define andmap 84 | (lambda (f lst) 85 | (unless (procedure? f) (arg-error 'andmap "procedure" f)) 86 | (unless (list? lst) (arg-error 'andmap "list" lst)) 87 | (letrec ([andmap (lambda (lst) 88 | (cond 89 | [(null? lst) #t] 90 | [(null? (cdr lst)) (f (car lst))] 91 | [else (and (f (car lst)) (andmap (cdr lst)))]))]) 92 | (andmap lst)))) 93 | 94 | (define ormap 95 | (lambda (f lst) 96 | (unless (procedure? f) (arg-error 'ormap "procedure" f)) 97 | (unless (list? lst) (arg-error 'ormap "list" lst)) 98 | (letrec ([ormap (lambda (lst) 99 | (cond 100 | [(null? lst) #f] 101 | [(null? (cdr lst)) (f (car lst))] 102 | [else (or (f (car lst)) (ormap (cdr lst)))]))]) 103 | (ormap lst)))) 104 | 105 | (define filter 106 | (lambda (f lst) 107 | (unless (procedure? f) (arg-error 'filter "procedure" f)) 108 | (unless (list? lst) (arg-error 'filter "list" lst)) 109 | (letrec ([filter (lambda (lst) 110 | (if (null? lst) 111 | '() 112 | (if (f (car lst)) 113 | (cons (car lst) (filter (cdr lst))) 114 | (filter (cdr lst)))))]) 115 | (filter lst)))) 116 | -------------------------------------------------------------------------------- /lib/zuo/c.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | (require "shell.zuo") 3 | 4 | (provide c-compile 5 | c-link 6 | c-ar 7 | 8 | .c->.o 9 | .exe 10 | .a 11 | 12 | config-include 13 | config-define 14 | config-merge) 15 | 16 | (define (c-compile .o .c config) 17 | (unless (path-string? .o) (arg-error 'c-compile "path string" .o)) 18 | (unless (path-string? .c) (arg-error 'c-compile "path string" .c)) 19 | (unless (hash? config) (arg-error 'c-compile "hash table" config)) 20 | (define windows? (eq? (hash-ref (runtime-env) 'system-type) 'windows)) 21 | (define lookup (make-lookup config)) 22 | (define command 23 | (build-shell (or (lookup 'CC) 24 | (if windows? 25 | "cl.exe" 26 | "cc")) 27 | (or (lookup 'CPPFLAGS) "") 28 | (or (lookup 'CFLAGS) "") 29 | (if windows? "/Fe:" "-o") (string->shell .o) 30 | "-c" (string->shell .c))) 31 | (shell/wait command (hash) "compile")) 32 | 33 | (define (c-link .exe ins config) 34 | (unless (path-string? .exe) (arg-error 'c-link "path string" .exe)) 35 | (unless (and (list? ins) (andmap path-string? ins)) (arg-error 'c-link "list of path strings" ins)) 36 | (unless (hash? config) (arg-error 'c-link "hash table" config)) 37 | (define windows? (eq? (hash-ref (runtime-env) 'system-type) 'windows)) 38 | (define lookup (make-lookup config)) 39 | (define command 40 | (build-shell (or (lookup 'CC) 41 | (if (windows?) 42 | "cl.exe" 43 | "cc")) 44 | "-o" (string->shell .exe) 45 | (string-join (map string->shell ins)) 46 | (or (lookup 'LDFLAGS) "") 47 | (or (lookup 'LIBS) ""))) 48 | (shell/wait command (hash) "link")) 49 | 50 | (define (c-ar .a ins config) 51 | (unless (path-string? .a) (arg-error 'c-ar "path string" .exe)) 52 | (unless (and (list? ins) (andmap path-string? ins)) (arg-error 'c-ar "list of path strings" ins)) 53 | (unless (hash? config) (arg-error 'c-ar "hash table" config)) 54 | (define windows? (eq? (hash-ref (runtime-env) 'system-type) 'windows)) 55 | (define lookup (make-lookup config)) 56 | (shell/wait 57 | (build-shell (or (lookup 'AR) 58 | (if windows? 59 | "lib.exe" 60 | "ar")) 61 | (or (lookup 'ARFLAGS) "") 62 | (string->shell .a) 63 | (string-join (map string->shell ins))) 64 | (hash) 65 | "library creation")) 66 | 67 | (define (make-lookup config) 68 | (lambda (key) (hash-ref config key #f))) 69 | 70 | (define (.c->.o .c) 71 | (unless (path-string? .c) (arg-error '.c->.o "path string" .c)) 72 | (path-replace-suffix .c (if (eq? (hash-ref (runtime-env) 'system-type) 'windows) 73 | ".obj" 74 | ".o"))) 75 | 76 | (define (.exe name) 77 | (unless (path-string? name) (arg-error '.exe "string" name)) 78 | (if (eq? (hash-ref (runtime-env) 'system-type) 'windows) 79 | (~a name ".exe") 80 | name)) 81 | 82 | (define (.a name) 83 | (unless (path-string? name) (arg-error '.a "string" name)) 84 | (if (eq? (hash-ref (runtime-env) 'system-type) 'windows) 85 | (~a name ".lib") 86 | (let ([l (split-path name)]) 87 | (build-path (or (car l) ".") (~a "lib" (cdr l) ".a"))))) 88 | 89 | (define (config-include config . paths) 90 | (unless (hash? config) (arg-error 'config-include "hash table" config)) 91 | (foldl (lambda (path config) 92 | (unless (path-string? path) (arg-error 'config-include "path string" path)) 93 | (do-config-merge config 'CPPFLAGS (~a "-I" (string->shell path)))) 94 | config 95 | paths)) 96 | 97 | (define (config-define config . defs) 98 | (unless (hash? config) (arg-error 'config-define "hash table" config)) 99 | (foldl (lambda (def config) 100 | (unless (string? def) (arg-error 'config-define "string" def)) 101 | (do-config-merge config 'CPPFLAGS (~a "-D" (string->shell def)))) 102 | config 103 | defs)) 104 | 105 | (define (config-merge config key shell-str) 106 | (unless (hash? config) (arg-error 'config-merge "hash table" config)) 107 | (unless (symbol? key) (arg-error 'config-merge "symbol" key)) 108 | (unless (string? shell-str) (arg-error 'config-merge "string" shell-str)) 109 | (do-config-merge config key shell-str)) 110 | 111 | (define (do-config-merge config key shell-str) 112 | (define now-str (hash-ref config key "")) 113 | (hash-set config key (build-shell now-str shell-str))) 114 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Moved 2 | ===== 3 | 4 | This repo has the starting development history of Zuo, but it's 5 | now maintained at [racket/racket](https://github.com/racket/racket) 6 | and mirrored at [racket/zuo](https://github.com/racket/zuo). 7 | 8 | Zuo: A Tiny Racket for Scripting 9 | ================================ 10 | 11 | You should use Racket to write scripts. But what if you need something 12 | much smaller than Racket for some reason — or what if you're trying 13 | to script a build of Racket itself? Zuo is a tiny Racket with 14 | primitives for dealing with files and running processes, and it comes 15 | with a `make`-like embedded DSL. 16 | 17 | Zuo is a Racket variant in the sense that program files start with 18 | `#lang`, and the module path after `#lang` determines the parsing and 19 | expansion of the file content. That's how the `make`-like DSL is 20 | defined, and even the base Zuo language is defined by layers of 21 | `#lang`s. One of the early layers implements macros. 22 | 23 | 24 | Some Example Scripts 25 | -------------------- 26 | 27 | See [`local/hello.zuo`](local/hello.zuo), 28 | [`local/tree.zuo`](local/tree.zuo), 29 | [`local/image.zuo`](local/image.zuo), and 30 | [`local/main.zuo`](local/main.zuo). 31 | 32 | 33 | Building and Running Zuo 34 | ------------------------ 35 | 36 | Compile `zuo.c` with a C compiler. No additional are files needed, 37 | other than system and C library headers. No compiler flags should be 38 | needed, although flags like `-o zuo` or `-O2` are a good idea. 39 | 40 | You can also use `configure`, `make`, and `make install`, where `make` 41 | targets mostly invoke a Zuo script after compiling `zuo.c`. If you 42 | don't use `configure` but compile to `zuo` in the current directory, 43 | then `./zuo local` and `./zuo local install` (omit the `./` on Windows) 44 | will do the same thing as `make` and `make install` with a default 45 | configuration. 46 | 47 | The Zuo executable runs only modules. If you run Zuo with no 48 | command-line arguments, then it loads `main.zuo`. Otherwise, the first 49 | argument to Zuo is a file to run or a directory containing a 50 | `main.zuo` to run, and additional arguments are delivered to that Zuo 51 | program via the `runtime-env` procedure. Running the command 52 | `./zuo local install`, for example, runs the `local/main.zuo` program 53 | with the argument `install`. Whatever initial script is run, if it has 54 | a `main` submodule, that submodule is also run. 55 | 56 | 57 | Library Modules and Startup Performance 58 | --------------------------------------- 59 | 60 | Except for the built-in `zuo/kernel` language module, Zuo finds 61 | languages and modules through a collection of libraries. By default, 62 | Zuo looks for a directory `lib` relative to the executable as the root 63 | of the library-collection tree. You can supply an alternate collection 64 | path with the `-X` command-line flag. 65 | 66 | You can also create an instance of Zuo with a set of libraries 67 | embedded as a heap image. Embedding a heap image has two advantages: 68 | 69 | * No extra directory of library modules is necessary. 70 | 71 | * Zuo can start especially quickly, competitive with the fastest 72 | command-line programs. 73 | 74 | The `local/image.zuo` script generates a `.c` file that is a copy of 75 | `zuo.c` plus embedded modules. By default, the `zuo` module and its 76 | dependencies are included, but you can specify others with `++lib`. In 77 | addition, the default collection-root path is disabled in the 78 | generated copy, unless you supply `--keep-collects` to 79 | `local/image.zuo`. 80 | 81 | When you use `configure` and `make` or `./zuo local`, the default 82 | build target creates a `to-run/zuo` that embeds the `zuo` library, as 83 | well as a `to-install/zuo` that has the right internal path to find 84 | other libraries after `make install` or `./zuo local install`. 85 | 86 | You can use heap images without embedding. The `dump-heap-and-exit` 87 | Zuo kernel permitive creates a heap image, and a `-B` or `--boot` 88 | command-line flag for Zuo uses the given boot image on startup. 89 | 90 | A boot image is machine-independent, whether in a stand-alone file or 91 | embedded in `.c` source. 92 | 93 | 94 | Embedding Zuo in Another Application 95 | ------------------------------------ 96 | 97 | Zuo can be embedded in a larger application, with or without an 98 | embedded boot image. To support embedding, compile `zuo.c` or the 99 | output of `local/image.zuo` with the `ZUO_EMBEDDED` preprocessor macro 100 | defined (to anything); the `zuo.h` header will be used in that case, 101 | and `zuo.h` should also be used by the embedding application. 102 | Documentation for the embedding API is provided as comments within 103 | `zuo.h`. 104 | 105 | 106 | More Information 107 | ---------------- 108 | 109 | Install the `zuo-doc` directory as a package in Racket to render the 110 | documentation there. 111 | -------------------------------------------------------------------------------- /local/main.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | (require "image.zuo" 3 | "compile.zuo") 4 | 5 | ;; The `targets` function generates targets, and `to-dir` determines 6 | ;; the build directory --- so these targets could be used by another 7 | ;; build script that wants the output in a subdirectory, for example 8 | (define (targets at-dir [vars (hash)]) 9 | ;; The `configure` script writes configuration info to "Makefile", so 10 | ;; use that if it's available, or use defaults otherwise 11 | (define Makefile (at-dir "Makefile")) 12 | (define config-in 13 | (cond 14 | [(file-exists? Makefile) (config-file->hash Makefile)] 15 | ;; no `configure`-generated `Makefile`, so use defaults 16 | [(eq? (hash-ref (runtime-env) 'system-type) 'unix) 17 | (hash 'INSTALL_PREFIX "/usr/local" 18 | 'CC "cc" 19 | 'CFLAGS "-O2")] 20 | [else 21 | (hash 'INSTALL_PREFIX "C:\\Program Files\\Zuo" 22 | 'CC "cl.exe" 23 | 'CFLAGS "/O2")])) 24 | (define config (foldl (lambda (key config) 25 | (hash-set config key (hash-ref vars key))) 26 | config-in 27 | (hash-keys vars))) 28 | 29 | (define install-prefix (hash-ref config 'INSTALL_PREFIX)) 30 | 31 | ;; Get a target for "image_zuo.c" from `image.zuo` 32 | (define image_zuo.c 33 | (image-target (hash 'output (at-dir "image_zuo.c") 34 | 'libs (map string->symbol (string-split (hash-ref config 'EMBED_LIBS "zuo"))) 35 | 'keep-collects? #t))) 36 | 37 | ;; We'll build two executables; they are the same except for the 38 | ;; embedded libary path, so we have a target maker parameterized 39 | ;; over that choice 40 | (define (exe-target name lib-path) 41 | (target (at-dir (add-exe name)) 42 | (lambda (path token) 43 | (rule (list image_zuo.c 44 | (input-data-target 'config config) 45 | (quote-module-path) 46 | (at-source "compile.zuo")) 47 | (lambda () 48 | (define l (split-path path)) 49 | (when (car l) (mkdir* (car l))) 50 | (compile-c path 51 | (target-path image_zuo.c) 52 | (list (~a "-DZUO_LIB_PATH=" lib-path)) 53 | config 54 | thread-process-wait)))))) 55 | 56 | (define (add-exe name) 57 | (if (eq? (hash-ref (runtime-env) 'system-type) 'windows) 58 | (~a name ".exe") 59 | name)) 60 | 61 | ;; The library path gets used as a C string constant, which isn't 62 | ;; trivial because there are likely to be backslashes on Windows 63 | (define (as-c-string path) (~s path)) ; probably a good enough approximation 64 | 65 | ;; The two executable targets 66 | (define zuo-to-run (exe-target "to-run/zuo" (as-c-string (at-source ".." ".." "lib")))) 67 | (define zuo-to-install (exe-target "to-install/zuo" (as-c-string (build-path install-prefix "lib")))) 68 | 69 | ;; A phony target to build both executables, which we'll list first 70 | ;; so it's used as the default target 71 | (define zuos-to-run-and-install 72 | (target 'zuos-to-run-and-install 73 | (lambda (token) 74 | (phony-rule (list zuo-to-run zuo-to-install) 75 | void)))) 76 | 77 | ;; A phony target to install 78 | (define install 79 | (target 'install 80 | (lambda (token) 81 | (phony-rule (list zuo-to-install) 82 | (lambda () 83 | (define (say-copy cp a b) 84 | (displayln (~a "copying " a " to " b)) 85 | (cp a b)) 86 | (mkdir* install-prefix) 87 | (mkdir* (build-path install-prefix "bin")) 88 | (define dest-exe (build-path install-prefix "bin" "zuo")) 89 | (when (file-exists? dest-exe) (rm dest-exe)) ; needed for macOS 90 | (say-copy cp (target-name zuo-to-install) dest-exe) 91 | (mkdir* (build-path install-prefix "lib")) 92 | (say-copy cp* 93 | (at-source "lib" "zuo") 94 | (build-path install-prefix "lib" "zuo"))))))) 95 | 96 | ;; Return all the targets 97 | (list zuos-to-run-and-install 98 | image_zuo.c 99 | zuo-to-run 100 | zuo-to-install 101 | install)) 102 | 103 | ;; Exports `targets` and also defines a `main` submodule 104 | ;; that handles command-line arguments and builds a target 105 | ;; in a `make`-like way 106 | (provide-targets targets) 107 | -------------------------------------------------------------------------------- /tests/harness-common.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | (provide check 4 | check-fail 5 | check-fail* 6 | check-arg-fail 7 | check-output 8 | 9 | run-zuo* 10 | run-zuo 11 | contains? 12 | 13 | bad-stx 14 | arity 15 | not-integer 16 | not-string 17 | not-path 18 | 19 | tmp-dir) 20 | 21 | (define (check* e a b) 22 | (unless (equal? a b) 23 | (error (~a "failed: " 24 | (~s e) 25 | "\n result: " (~v a) 26 | "\n result: " (~v b))))) 27 | 28 | (define-syntax (check stx) 29 | (unless (list? stx) (bad-syntax stx)) 30 | (list* (quote-syntax check*) 31 | (list (quote-syntax quote) stx) 32 | (let ([len (length (cdr stx))]) 33 | (cond 34 | [(= 1 len) (cons #t (cdr stx))] 35 | [(= 2 len) (cdr stx)] 36 | [else (bad-syntax stx)])))) 37 | 38 | (define (run-zuo* args input k) 39 | (define p (apply process 40 | (cons (hash-ref (runtime-env) 'exe #f) 41 | (append args 42 | (list (hash 'stdin 'pipe 'stdout 'pipe 'stderr 'pipe)))))) 43 | (fd-write (hash-ref p 'stdin) input) 44 | (fd-close (hash-ref p 'stdin)) 45 | (define out (fd-read (hash-ref p 'stdout) eof)) 46 | (define err (fd-read (hash-ref p 'stderr) eof)) 47 | (fd-close (hash-ref p 'stdout)) 48 | (fd-close (hash-ref p 'stderr)) 49 | (process-wait (hash-ref p 'process)) 50 | (k (process-status (hash-ref p 'process)) out err)) 51 | 52 | (define (run-zuo e k) 53 | (run-zuo* '("") (~a "#lang " language-name " " (~s e)) k)) 54 | 55 | (define (contains? err msg) 56 | (let loop ([i 0]) 57 | (and (not (> i (- (string-length err) (string-length msg)))) 58 | (or (string=? (substring err i (+ i (string-length msg))) msg) 59 | (loop (+ i 1)))))) 60 | 61 | (define (check-fail* e who msg) 62 | (run-zuo 63 | e 64 | (lambda (status out err) 65 | (when (= 0 status) 66 | (error (~a "check-fail: failed to fail: " (~s e) 67 | "\n stdout: " (~s out) 68 | "\n stderr: " (~s err)))) 69 | (unless (contains? err msg) 70 | (error (~a "check-fail: didn't find expected message: " (~s e) 71 | "\n expected: " (~s msg) 72 | "\n stderr: " (~s err)))) 73 | (when who 74 | (let* ([who (symbol->string who)] 75 | [len (string-length who)]) 76 | (unless (and (> (string-length err) len) 77 | (string=? (substring err 0 len) who)) 78 | (error (~a "check-fail: didn't find expected who: " (~s e) 79 | "\n expected: " who 80 | "\n stderr: " (~s err))))))))) 81 | 82 | (define-syntax (check-fail stx) 83 | (unless (and (list? stx) (= 3 (length stx))) (bad-syntax stx)) 84 | (list (quote-syntax check-fail*) 85 | (list (quote-syntax quasiquote) (cadr stx)) 86 | #f 87 | (cadr (cdr stx)))) 88 | 89 | (define-syntax (check-arg-fail stx) 90 | (unless (and (list? stx) (= 3 (length stx)) 91 | (pair? (cadr stx)) (identifier? (car (cadr stx)))) 92 | (bad-syntax stx)) 93 | (list (quote-syntax check-fail*) 94 | (list (quote-syntax quasiquote) (cadr stx)) 95 | (list (quote-syntax quote) (car (cadr stx))) 96 | (cadr (cdr stx)))) 97 | 98 | (define (check-output* e stdout stderr) 99 | (run-zuo 100 | e 101 | (lambda (status out err) 102 | (unless ((if (equal? stderr "") (lambda (v) v) not) 103 | (= 0 status)) 104 | (error (~a "check-output: process failed: " (~s e) 105 | "\n stdout: " (~s out) 106 | "\n stderr: " (~s err)))) 107 | (unless (and (equal? out stdout) 108 | (equal? err stderr)) 109 | (error (~a "check-output: process failed: " (~s e) 110 | "\n stdout: " (~s out) 111 | "\n expect: " (~s stdout) 112 | "\n stderr: " (~s err) 113 | "\n expect: " (~s stderr))))))) 114 | 115 | (define-syntax (check-output stx) 116 | (unless (list? stx) (bad-syntax stx)) 117 | (cond 118 | [(= 3 (length stx)) 119 | (list (quote-syntax check-output*) 120 | (list (quote-syntax quote) (cadr stx)) 121 | (list-ref stx 2) 122 | "")] 123 | [(= 4 (length stx)) 124 | (list (quote-syntax check-output*) 125 | (list (quote-syntax quote) (cadr stx)) 126 | (list-ref stx 2) 127 | (list-ref stx 3))] 128 | [else (bad-syntax stx)])) 129 | 130 | ;; Some common error messages 131 | (define bad-stx "bad syntax") 132 | (define arity "wrong number of arguments") 133 | (define not-integer "not an integer") 134 | (define not-string "not a string") 135 | (define not-path "not a path string") 136 | 137 | (define tmp-dir (build-path (car (split-path (quote-module-path))) ".." "build" "tmp")) 138 | (mkdir* tmp-dir) 139 | -------------------------------------------------------------------------------- /tests/pair.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "pairs") 6 | 7 | (check (null? '())) 8 | (check (null? 10) #f) 9 | (check (null? '(1)) #f) 10 | 11 | (check (pair? '()) #f) 12 | (check (pair? 10) #f) 13 | (check (pair? '(1))) 14 | 15 | (check (list? '())) 16 | (check (list? 10) #f) 17 | (check (list? '(1))) 18 | (check (list? '(1 2 3 4 5 6 7))) 19 | (check (list? '(1 . 2)) #f) 20 | (check (list? '(1 2 3 4 5 6 . 7)) #f) 21 | 22 | (check (cons 1 2) '(1 . 2)) 23 | 24 | (check (car '(1 2)) 1) 25 | (check (car '(1 . 2)) 1) 26 | (check-arg-fail (car '()) "not a pair") 27 | (check-arg-fail (car 'apple) "not a pair") 28 | 29 | (check (cdr '(1 . 2)) 2) 30 | (check (cdr '(1 2)) '(2)) 31 | (check-arg-fail (cdr '()) "not a pair") 32 | (check-arg-fail (cdr 'apple) "not a pair") 33 | 34 | (check (list) '()) 35 | (check (list 1 2 3) '(1 2 3)) 36 | 37 | (check (list* 1) 1) 38 | (check (list* 1 2 3) '(1 2 . 3)) 39 | (check-fail (list*) arity) 40 | 41 | (check (append) '()) 42 | (check (append 1) 1) 43 | (check (append '(1 2)) '(1 2)) 44 | (check (append '(1 2) 3) '(1 2 . 3)) 45 | (check (append '(1 2) '(3 4)) '(1 2 3 4)) 46 | (check (append '(1 2) '(3 4) 5) '(1 2 3 4 . 5)) 47 | 48 | (check (reverse '()) '()) 49 | (check (reverse '(1 2 3)) '(3 2 1)) 50 | (check-arg-fail (reverse 1) "not a list") 51 | (check-arg-fail (reverse '(1 . 2)) "not a list") 52 | 53 | (check (list-ref '(1) 0) 1) 54 | (check (list-ref '(1 . 2) 0) 1) 55 | (check (list-ref '(1 2 3 . 4) 2) 3) 56 | (check-arg-fail (list-ref '(1 . 2) 1) "encountered a non-pair") 57 | 58 | (check (list-set '(1) 0 'x) '(x)) 59 | (check (list-set '(1 . 2) 0 'x) '(x . 2)) 60 | (check (list-set '(1 2 3 . 4) 2 'x) '(1 2 x . 4)) 61 | (check-arg-fail (list-set '(1 . 2) 1 'x) "encountered a non-pair") 62 | 63 | (check (list-tail '() 0) '()) 64 | (check (list-tail 1 0) 1) 65 | (check (list-tail '(1 . 2) 1) 2) 66 | (check (list-tail '(1 2 3 . 4) 2) '(3 . 4)) 67 | (check-arg-fail (list-tail '(1 . 2) 2) "encountered a non-pair") 68 | 69 | (check (caar '((1) (2))) 1) 70 | (check-arg-fail (caar 1) "not a valid argument") 71 | (check-arg-fail (caar '(1)) "not a valid argument") 72 | 73 | (check (cadr '((1 2) (3 4))) '(3 4)) 74 | (check-arg-fail (cadr 1) "not a valid argument") 75 | (check-arg-fail (cadr '(1)) "not a valid argument") 76 | 77 | (check (cdar '((1 2) (3 4))) '(2)) 78 | (check-arg-fail (cdar 1) "not a valid argument") 79 | (check-arg-fail (cdar '(1 . 2)) "not a valid argument") 80 | 81 | (check (cddr '((1 2) (3 4) (5 6))) '((5 6))) 82 | (check-arg-fail (cddr 1) "not a valid argument") 83 | (check-arg-fail (cddr '(1 . 2)) "not a valid argument") 84 | 85 | (check (map (lambda (x) (+ x 1)) '(0 1 2)) '(1 2 3)) 86 | (check (map (lambda (x y) (+ x y)) '(1 2 3) '(-10 -20 -30)) '(-9 -18 -27)) 87 | (check-arg-fail (map 1 '()) "not a procedure") 88 | (check-arg-fail (map (lambda (a) a) 1) "not a list") 89 | (check-arg-fail (map (lambda (a) a) '(1) 1) "not a list") 90 | (check-arg-fail (map (lambda (a b) a) '(1) '(1 2)) "lists have different lengths") 91 | 92 | (check (for-each (lambda (x) x) '(1 2 3)) (void)) 93 | (check-output (for-each alert '(1 2 3)) "1\n2\n3\n") 94 | (check-arg-fail (for-each (lambda (a) a) 1) "not a list") 95 | (check-arg-fail (for-each 9 '(1 2)) "not a procedure") 96 | 97 | (check (foldl (lambda (x a) (+ a x)) 7 '(0 1 2)) 10) 98 | (check-arg-fail (foldl (lambda (x a) (+ a x)) 7 7) "not a list") 99 | (check-arg-fail (foldl 10 0 '(1)) "not a procedure") 100 | 101 | (check (andmap integer? '(1 2 3))) 102 | (check (andmap integer? '())) 103 | (check (andmap (lambda (x) (< x 10)) '(1 2 3))) 104 | (check (andmap (lambda (x) (< x 3)) '(1 2 3)) #f) 105 | (check (andmap (lambda (x) (< x 3)) '(1 2 3 "oops")) #f) 106 | (check-arg-fail (andmap 10 '(1)) "not a procedure") 107 | (check-arg-fail (andmap (lambda (x) (< x 3)) '(1 2 3 . "oops")) "not a list") 108 | 109 | (check (ormap integer? '(1 2 3))) 110 | (check (ormap string? '(1 2 3)) #f) 111 | (check (ormap string? '("a" 2 3)) #t) 112 | (check (ormap (lambda (x) (< x 10)) '(1 "oops"))) 113 | (check-arg-fail (ormap 10 '(1)) "not a procedure") 114 | (check-arg-fail (ormap (lambda (x) (< x 3)) '(1 2 3 . "oops")) "not a list") 115 | 116 | (check (member "x" '()) #f) 117 | (check (member "x" '("x" y z)) '("x" y z)) 118 | (check (member "x" '(x "x" y z)) '("x" y z)) 119 | (check-arg-fail (member "x" "y") "not a list") 120 | 121 | (check (assoc "x" '()) #f) 122 | (check (assoc "x" '(("x" . x) y z)) '("x" . x)) 123 | (check (assoc "x" '((x . x) ("x" . x) y z)) '("x" . x)) 124 | (check-arg-fail (assoc "x" "y") "not a list") 125 | (check-arg-fail (assoc "y" '((x . x) ("x" . x) y z)) "non-pair found in list") 126 | 127 | (check (filter (lambda (x) (> x 7)) '()) '()) 128 | (check (filter (lambda (x) (> x 7)) '(1 11 2 12 3 13 4)) '(11 12 13)) 129 | (check-arg-fail (filter "x" '()) "not a procedure") 130 | (check-arg-fail (filter (lambda (x) #t) "y") "not a list") 131 | 132 | (check (sort '() <) '()) 133 | (check (sort '(1 2 3 4) <) '(1 2 3 4)) 134 | (check (sort '(3 4 2 1) <) '(1 2 3 4)) 135 | (check (sort '("z" "d" "a" "m" "p" "q" "w" "f" "b") string 1 1))) 106 | (check (> 2 1)) 107 | (check (> -1 -2)) 108 | (check (not (> -2 -1))) 109 | (check (not (> -9223372036854775808 -9223372036854775808))) 110 | (check (> 9223372036854775807 -9223372036854775808)) 111 | (check (not (> -9223372036854775808 9223372036854775807))) 112 | (check-arg-fail (> 'apple 5) not-integer) 113 | (check-arg-fail (> 5 'apple) not-integer) 114 | 115 | (check (>= 1 1)) 116 | (check (>= 2 1)) 117 | (check (>= -1 -2)) 118 | (check (not (>= -2 -1))) 119 | (check (>= -9223372036854775808 -9223372036854775808)) 120 | (check (>= 9223372036854775807 -9223372036854775808)) 121 | (check (not (>= -9223372036854775808 9223372036854775807))) 122 | (check-arg-fail (>= 'apple 5) not-integer) 123 | (check-arg-fail (>= 5 'apple) not-integer) 124 | 125 | (alert "bitwise") 126 | 127 | (check 1 (bitwise-and 3 1)) 128 | (check 0 (bitwise-and 2 1)) 129 | (check 42 (bitwise-and -1 42)) 130 | (check -42 (bitwise-and -1 -42)) 131 | (check 0 (bitwise-and -1 0)) 132 | (check 0 (bitwise-and -9223372036854775808 9223372036854775807)) 133 | (check-arg-fail (bitwise-and 'apple 5) not-integer) 134 | (check-arg-fail (bitwise-and 5 'apple) not-integer) 135 | 136 | (check 3 (bitwise-ior 3 1)) 137 | (check 3 (bitwise-ior 2 1)) 138 | (check -1 (bitwise-ior -1 42)) 139 | (check 42 (bitwise-ior 0 42)) 140 | (check -42 (bitwise-ior 0 -42)) 141 | (check -1 (bitwise-ior -9223372036854775808 9223372036854775807)) 142 | (check-arg-fail (bitwise-ior 'apple 5) not-integer) 143 | (check-arg-fail (bitwise-ior 5 'apple) not-integer) 144 | 145 | (check 2 (bitwise-xor 3 1)) 146 | (check 3 (bitwise-xor 2 1)) 147 | (check -43 (bitwise-xor -1 42)) 148 | (check 42 (bitwise-xor 0 42)) 149 | (check -42 (bitwise-xor 0 -42)) 150 | (check -1 (bitwise-xor -9223372036854775808 9223372036854775807)) 151 | (check-arg-fail (bitwise-xor 'apple 5) not-integer) 152 | (check-arg-fail (bitwise-xor 5 'apple) not-integer) 153 | 154 | (check -1 (bitwise-not 0)) 155 | (check 0 (bitwise-not -1)) 156 | (check 41 (bitwise-not -42)) 157 | (check -43 (bitwise-not 42)) 158 | (check 9223372036854775807 (bitwise-not -9223372036854775808)) 159 | (check-arg-fail (bitwise-not 'apple) not-integer) 160 | -------------------------------------------------------------------------------- /tests/filesystem.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "filesystem") 6 | 7 | (check (hash? (stat tmp-dir #f))) 8 | (check (stat (build-path tmp-dir "nonesuch.txt") #f) #f) 9 | 10 | (let ([s (stat tmp-dir #f)]) 11 | (check (hash-ref s 'type) 'dir)) 12 | (check (directory-exists? tmp-dir)) 13 | (check (file-exists? tmp-dir) #f) 14 | (check (link-exists? tmp-dir) #f) 15 | (check-arg-fail (stat 10) not-path) 16 | 17 | (define now (current-time)) 18 | 19 | (define exists.txt (build-path tmp-dir "exists.txt")) 20 | (let ([fd (fd-open-output exists.txt :truncate)]) 21 | (fd-write fd "xyz") 22 | (fd-close fd)) 23 | 24 | (define exists2.txt (build-path tmp-dir "exists2.txt")) 25 | (fd-close (fd-open-output exists2.txt :can-update)) 26 | 27 | (check (file-exists? exists.txt)) 28 | (check (file-exists? exists2.txt)) 29 | (check (directory-exists? exists2.txt) #f) 30 | (check (link-exists? exists2.txt) #f) 31 | 32 | (check-arg-fail (file-exists? 10) not-path) 33 | (check-arg-fail (directory-exists? 10) not-path) 34 | (check-arg-fail (link-exists? 10) not-path) 35 | 36 | (let ([s (stat exists.txt #f)]) 37 | (check (hash? s)) 38 | (check (hash-ref s 'type) 'file) 39 | (check (hash-ref s 'size) 3) 40 | ;; Seems to be too precise for some Linux configurations: 41 | #; 42 | (check (or (> (hash-ref s 'modify-time-seconds) (car now)) 43 | (and (= (hash-ref s 'modify-time-seconds) (car now)) 44 | (>= (hash-ref s 'modify-time-nanoseconds) (cdr now))))) 45 | (check (>= (hash-ref s 'modify-time-seconds) (car now))) 46 | (let ([s2 (stat exists.txt #t)]) 47 | (check s s2)) 48 | (let ([s2 (stat exists2.txt #t)]) 49 | (check (hash? s2)) 50 | (check (not (equal? (hash-ref s 'inode) (hash-ref s2 'inode)))) 51 | (check (equal? (hash-ref s 'device-id) (hash-ref s2 'device-id))))) 52 | 53 | (let ([l (ls tmp-dir)]) 54 | (check (pair? (member "exists.txt" l))) 55 | (check (pair? (member "exists2.txt" l)))) 56 | (check-arg-fail (ls 10) not-path) 57 | 58 | (rm exists2.txt) 59 | (check (stat exists2.txt #t) #f) 60 | (check (member "exists2.txt" (ls tmp-dir)) #f) 61 | 62 | (define sub-dir (build-path tmp-dir "sub")) 63 | (rm* sub-dir) 64 | 65 | (check (directory-exists? sub-dir) #f) 66 | (check (mkdir sub-dir) (void)) 67 | (check (directory-exists? sub-dir)) 68 | (check-arg-fail (mkdir 10) not-path) 69 | 70 | (define sub-sub-dir (build-path sub-dir "subsub")) 71 | (check (directory-exists? sub-sub-dir) #f) 72 | (check (mkdir sub-sub-dir) (void)) 73 | (check (directory-exists? sub-sub-dir)) 74 | (check (rmdir sub-sub-dir) (void)) 75 | (check (directory-exists? sub-sub-dir) #f) 76 | (check (mkdir sub-sub-dir) (void)) 77 | 78 | (fd-close (fd-open-output (build-path sub-sub-dir "apple") :can-update)) 79 | (fd-close (fd-open-output (build-path sub-sub-dir "banana") :can-update)) 80 | (fd-close (fd-open-output (build-path sub-sub-dir "cherry") :can-update)) 81 | (fd-close (fd-open-output (build-path sub-dir "donut") :can-update)) 82 | 83 | (check (length (ls sub-dir)) 2) 84 | (check (length (ls sub-sub-dir)) 3) 85 | 86 | (check (void? (mv (build-path sub-sub-dir "banana") 87 | (build-path sub-dir "banana")))) 88 | (check (length (ls sub-dir)) 3) 89 | (check (length (ls sub-sub-dir)) 2) 90 | (check (void? (mv (build-path sub-dir "banana") 91 | (build-path sub-sub-dir "eclair")))) 92 | (let ([l (ls sub-sub-dir)]) 93 | (check (pair? (member "apple" l))) 94 | (check (pair? (member "cherry" l))) 95 | (check (pair? (member "eclair" l))) 96 | (check (not (member "banana" l)))) 97 | (check-arg-fail (mv 10 "x") not-path) 98 | (check-arg-fail (mv "x" 10) not-path) 99 | 100 | (check-fail (rm ,sub-dir) "failed") 101 | (check-arg-fail (rm 10) not-path) 102 | 103 | (rm* sub-dir) 104 | (check (directory-exists? sub-sub-dir) #f) 105 | (check (directory-exists? sub-dir) #f) 106 | (check-arg-fail (rm* 10) not-path) 107 | 108 | (mkdir* sub-sub-dir) 109 | (check (directory-exists? sub-sub-dir)) 110 | (check (directory-exists? sub-dir)) 111 | (check-arg-fail (mkdir* 10) not-path) 112 | 113 | (when (eq? 'unix (hash-ref (runtime-env) 'system-type)) 114 | (let ([fd (fd-open-output (build-path sub-dir "high") :can-update)]) 115 | (fd-write fd "HIGH") 116 | (fd-close fd)) 117 | (let ([fd (fd-open-output (build-path sub-sub-dir "low") :can-update)]) 118 | (fd-write fd "LOW") 119 | (fd-close fd)) 120 | (define (get path) 121 | (let ([fd (fd-open-input path)]) 122 | (define v (fd-read fd eof)) 123 | (fd-close fd) 124 | v)) 125 | (ln "low" (build-path sub-sub-dir "below")) 126 | (check (get (build-path sub-sub-dir "below")) "LOW") 127 | (check (readlink (build-path sub-sub-dir "below")) "low") 128 | (check (hash-ref (stat (build-path sub-sub-dir "below") #f) 'type) 'link) 129 | (check (hash-ref (stat (build-path sub-sub-dir "below") #t) 'type) 'file) 130 | (check (link-exists? (build-path sub-sub-dir "below"))) 131 | (check (rm (build-path sub-sub-dir "below")) (void)) 132 | (check (get (build-path sub-sub-dir "low")) "LOW") 133 | 134 | (ln "../high" (build-path sub-sub-dir "above")) 135 | (check (get (build-path sub-sub-dir "above")) "HIGH") 136 | (check (readlink (build-path sub-sub-dir "above")) "../high") 137 | (check (rm (build-path sub-sub-dir "above")) (void)) 138 | (check (get (build-path sub-dir "high")) "HIGH") 139 | 140 | (ln ".." (build-path sub-sub-dir "again")) 141 | (check (link-exists? (build-path sub-sub-dir "again"))) 142 | (check (hash-ref (stat (build-path sub-sub-dir "again") #f) 'type) 'link) 143 | (check (hash-ref (stat (build-path sub-sub-dir "again") #t) 'type) 'dir) 144 | (check (get (build-path sub-sub-dir "again" "high")) "HIGH") 145 | (check (get (build-path sub-sub-dir "again" "subsub" "low")) "LOW") 146 | (check (ls sub-dir) (ls (build-path sub-sub-dir "again"))) 147 | 148 | (rm* sub-sub-dir) 149 | (check (get (build-path sub-dir "high")) "HIGH") 150 | 151 | (void)) 152 | 153 | (check-arg-fail (readlink 10) not-path) 154 | (check-arg-fail (ln 10 "a") not-path) 155 | (check-arg-fail (ln "a" 10) not-path) 156 | 157 | (rm* sub-dir) 158 | -------------------------------------------------------------------------------- /tests/process.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "processes") 6 | 7 | (define zuo.exe (hash-ref (runtime-env) 'exe)) 8 | (define answer.txt (build-path tmp-dir "answer.txt")) 9 | 10 | ;; check process without redirection, inculding multiple processes 11 | (let () 12 | (define echo-to-file.zuo (build-path tmp-dir "echo-to-file.zuo")) 13 | 14 | (let ([out (fd-open-output echo-to-file.zuo :truncate)]) 15 | (fd-write out (~a "#lang zuo\n" 16 | (~s '(let* ([args (hash-ref (runtime-env) 'args)] 17 | [out (fd-open-output (car args) :truncate)]) 18 | (fd-write out (cadr args)))))) 19 | (fd-close out)) 20 | 21 | (let ([ht (process zuo.exe 22 | echo-to-file.zuo 23 | answer.txt 24 | "anybody home?")]) 25 | (check (hash? ht)) 26 | (check (= 1 (hash-count ht))) 27 | (check (handle? (hash-ref ht 'process))) 28 | (let ([p (hash-ref ht 'process)]) 29 | (check (handle? p)) 30 | (check (process-wait p) p) 31 | (check (process-wait p p p) p) 32 | (check (handle? p)) 33 | (check (process-status p) 0)) 34 | (let ([in (fd-open-input answer.txt)]) 35 | (check (fd-read in eof) "anybody home?") 36 | (fd-close in))) 37 | 38 | (define answer2.txt (build-path tmp-dir "answer2.txt")) 39 | (let ([ht1 (process zuo.exe echo-to-file.zuo answer.txt "one")] 40 | [ht2 (process zuo.exe echo-to-file.zuo answer2.txt "two")]) 41 | (define p1 (hash-ref ht1 'process)) 42 | (define p2 (hash-ref ht2 'process)) 43 | (define pa (process-wait p1 p2)) 44 | (define pb (process-wait (if (eq? p1 pa) p2 p1))) 45 | (check (or (and (eq? p1 pa) (eq? p2 pb)) 46 | (and (eq? p1 pb) (eq? p2 pa)))) 47 | (check (process-status p1) 0) 48 | (check (process-status p2) 0) 49 | (check (process-wait p1) p1) 50 | (check (process-wait p2) p2) 51 | (define pc (process-wait p1 p2)) 52 | (check (or (eq? pc p1) (eq? pc p2))) 53 | (let ([in (fd-open-input answer.txt)]) 54 | (check (fd-read in eof) "one") 55 | (fd-close in)) 56 | (let ([in (fd-open-input answer2.txt)]) 57 | (check (fd-read in eof) "two") 58 | (fd-close in)))) 59 | 60 | ;; check setting the process directory and environment variables 61 | (let ([path->absolute-path (lambda (p) (if (relative-path? p) 62 | (build-path (hash-ref (runtime-env) 'dir) p) 63 | p))]) 64 | (define runtime-to-file 65 | (~a "#lang zuo\n" 66 | (~s `(let* ([out (fd-open-output ,(path->absolute-path answer.txt) :truncate)]) 67 | (fd-write out (~s (cons 68 | (hash-ref (runtime-env) 'dir) 69 | (hash-ref (runtime-env) 'env)))))))) 70 | 71 | (let ([ht (process zuo.exe "" (hash 'stdin 'pipe))]) 72 | (check (hash? ht)) 73 | (check (= 2 (hash-count ht))) 74 | (check (handle? (hash-ref ht 'process))) 75 | (check (handle? (hash-ref ht 'stdin))) 76 | (fd-write (hash-ref ht 'stdin) runtime-to-file) 77 | (fd-close (hash-ref ht 'stdin)) 78 | (process-wait (hash-ref ht 'process)) 79 | (check (process-status (hash-ref ht 'process)) 0) 80 | (let () 81 | (define in (fd-open-input answer.txt)) 82 | (define dir+env (car (string-read (fd-read in eof)))) 83 | (fd-close in) 84 | (check (car dir+env) (hash-ref (runtime-env) 'dir)) 85 | (check (andmap (lambda (p) 86 | (define p2 (assoc (car p) (cdr dir+env))) 87 | (and p2 (equal? (cdr p) (cdr p2)))) 88 | (hash-ref (runtime-env) 'env))))) 89 | 90 | (let* ([env (list (cons "HELLO" "there"))] 91 | [ht (process zuo.exe "" (hash 'stdin 'pipe 92 | 'dir tmp-dir 93 | 'env env))]) 94 | (fd-write (hash-ref ht 'stdin) runtime-to-file) 95 | (fd-close (hash-ref ht 'stdin)) 96 | (process-wait (hash-ref ht 'process)) 97 | (check (process-status (hash-ref ht 'process)) 0) 98 | (let () 99 | (define in (fd-open-input answer.txt)) 100 | (define dir+env (car (string-read (fd-read in eof)))) 101 | (fd-close in) 102 | (define (dir-identity d) (hash-ref (stat d #t) 'inode)) 103 | (check (dir-identity (car dir+env)) (dir-identity tmp-dir)) 104 | (check (andmap (lambda (p) 105 | (define p2 (assoc (car p) (cdr dir+env))) 106 | (and p2 (equal? (cdr p) (cdr p2)))) 107 | env))))) 108 | 109 | ;; make sure that the file descriptor for one process's pipe isn't 110 | ;; kept open by a second process 111 | (let () 112 | (define ht1 (process zuo.exe "" (hash 'stdin 'pipe 'stdout 'pipe))) 113 | (define ht2 (process zuo.exe "" (hash 'stdin 'pipe))) 114 | 115 | (define in1 (hash-ref ht1 'stdin)) 116 | (fd-write in1 "#lang zuo 'hello") 117 | (fd-close in1) 118 | (check (fd-read (hash-ref ht1 'stdout) eof) "'hello\n") 119 | (process-wait (hash-ref ht1 'process)) 120 | (fd-close (hash-ref ht1 'stdout)) 121 | 122 | (define in2 (hash-ref ht2 'stdin)) 123 | (fd-write in2 "#lang zuo") 124 | (fd-close in2) 125 | (process-wait (hash-ref ht2 'process)) 126 | (void)) 127 | 128 | ;; check transfer of UTF-8 arguments and related 129 | (define (check-process-arg arg) 130 | (define p (process (hash-ref (runtime-env) 'exe) 131 | "" 132 | arg 133 | (hash 'stdin 'pipe 'stdout 'pipe))) 134 | (define to (hash-ref p 'stdin)) 135 | (fd-write to "#lang zuo (displayln (hash-ref (runtime-env) 'args))") 136 | (fd-close to) 137 | (define from (hash-ref p 'stdout)) 138 | (define s (fd-read from eof)) 139 | (process-wait (hash-ref p 'process)) 140 | (check s (~a"(" arg ")\n"))) 141 | 142 | (check-process-arg "\xCE\xBB") 143 | (check-process-arg "a b c") 144 | (check-process-arg "a \"b\" c") 145 | (check-process-arg "a \"b c") 146 | (check-process-arg "a \\b c") 147 | -------------------------------------------------------------------------------- /tests/path.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | (require "harness.zuo") 4 | 5 | (alert "paths") 6 | 7 | (check (path-string? "x")) 8 | (check (path-string? "") #f) 9 | (check (path-string? "xy\x00z") #f) 10 | (check (path-string? 'apple) #f) 11 | 12 | (define unix? (eq? (hash-ref (runtime-env) 'system-type) 'unix)) 13 | 14 | (check (build-path "x" "y") (if unix? "x/y" "x\\y")) 15 | (check (build-path "." "y") "y") 16 | (check (build-raw-path "." "y") (if unix? "./y" ".\\y")) 17 | (check (build-path ".." "y") (if unix? "../y" "..\\y")) 18 | (check (build-path "x" ".") "x") 19 | (check (build-raw-path "x" ".") (if unix? "x/." "x\\.")) 20 | (check (build-path "x" "..") ".") 21 | (check (build-raw-path "x" "..") (if unix? "x/.." "x\\..")) 22 | (check (build-path "x/y/z/./.." "..") "x/") 23 | (check (build-raw-path "x/y/z/./.." "..") (if unix? "x/y/z/./../.." "x/y/z/./..\\..")) 24 | (check (build-path "x/y/./.." "..") ".") 25 | (check (build-path "x/y/./.." "../../..") (if unix? "../.." "..\\..")) 26 | (check (build-path "x/y/./.." "../q/../..") "..") 27 | (check (build-path "x/" "y") (if unix? "x/y" "x/y")) 28 | (check (build-path "x//" "y") (if unix? "x//y" "x//y")) 29 | (check (build-path "x\\" "y") (if unix? "x\\/y" "x\\y")) 30 | (check (build-path "x" "y/z") (if unix? "x/y/z" "x\\y\\z")) 31 | (check (build-raw-path "x" "y/z") (if unix? "x/y/z" "x\\y/z")) 32 | (check (build-path "x/y" "z") (if unix? "x/y/z" "x/y\\z")) 33 | (check (build-path "x/y/" "z") (if unix? "x/y/z" "x/y/z")) 34 | (check (build-path "/x" "z") (if unix? "/x/z" "/x\\z")) 35 | (check-arg-fail (build-path "" "z") "not a path string") 36 | (check-arg-fail (build-path "z" "") "not a path string") 37 | (check-arg-fail (build-path 0 "z") "not a path string") 38 | (check-arg-fail (build-path "z" 0) "not a path string") 39 | (check-arg-fail (build-path "z" "/x") "path is not relative") 40 | 41 | (check (build-path "x") "x") 42 | (check (build-path "x" "y" "z") (if unix? "x/y/z" "x\\y\\z")) 43 | 44 | (check (split-path "x/y") '("x/" . "y")) 45 | (check (split-path "x/y/") '("x/" . "y")) 46 | (check (split-path "x//y/") '("x//" . "y")) 47 | (check (split-path "x/y///") '("x/" . "y")) 48 | (check (split-path "x") '(#f . "x")) 49 | (check (split-path "x/") '(#f . "x")) 50 | (check (split-path "x//") '(#f . "x")) 51 | (check (split-path "x\\y") (if unix? '(#f . "x\\y") '("x\\" . "y"))) 52 | (check (split-path "/") '(#f . "/")) 53 | (check-arg-fail (split-path "") "not a path string") 54 | (check-arg-fail (split-path 0) "not a path string") 55 | 56 | (unless unix? 57 | (check (split-path "c:/") '(#f . "c:/")) 58 | (check (split-path "c:///") '(#f . "c:/")) 59 | (check (split-path "c:/x") '("c:/" . "x")) 60 | (check (split-path "c:/x/") '("c:/" . "x")) 61 | (check (split-path "c:\\") '(#f . "c:\\")) 62 | (check (split-path "c:\\x") '("c:\\" . "x")) 63 | (check (split-path "//mach/drive/") '(#f . "//mach/drive/")) 64 | (check (split-path "//mach/drive/\\\\") '(#f . "//mach/drive/")) 65 | (check (split-path "//mach/drive/z") '("//mach/drive/" . "z")) 66 | (check (split-path "\\\\mach\\drive\\") '(#f . "\\\\mach\\drive\\")) 67 | (check (split-path "\\\\mach\\drive\\z") '("\\\\mach\\drive\\" . "z")) 68 | (check (split-path "\\\\?\\c:\\elem") '("\\\\?\\c:\\" . "elem")) 69 | (check (split-path "\\\\?\\c:\\") '(#f . "\\\\?\\c:\\"))) 70 | 71 | (check (relative-path? "x/y")) 72 | (check (relative-path? "x/y/")) 73 | (check (relative-path? "/x/") #f) 74 | (check (relative-path? "/") #f) 75 | (check (relative-path? "\\x") unix?) 76 | (check-arg-fail (relative-path? "") "not a path string") 77 | (check-arg-fail (relative-path? 0) "not a path string") 78 | 79 | (check (path-string? (at-source "adjacent.txt"))) 80 | (check (at-source) (path-only (quote-module-path))) 81 | (check (procedure? at-source)) 82 | (check-fail (at-source . x) bad-stx) 83 | 84 | (check (simple-form-path "a//b//c/d/../f/g") 85 | (if unix? 86 | "a/b/c/f/g" 87 | "a\\b\\c\\f\\g")) 88 | (check (simple-form-path "a//b//c/d/.././../f/g") 89 | (if unix? 90 | "a/b/f/g" 91 | "a\\b\\f\\g")) 92 | (check (simple-form-path "../../a//b//c/d") 93 | (if unix? 94 | "../../a/b/c/d" 95 | "..\\..\\a\\b\\c\\d")) 96 | 97 | (check (find-relative-path "home/zuo/src" "home/zuo/src/private/optimize") 98 | (build-path "private" "optimize")) 99 | (check (find-relative-path "home/zuo/src" "home/zuo/lib") 100 | (build-path ".." "lib")) 101 | (check (find-relative-path "home/zuo/src" "home/zuo/src") 102 | ".") 103 | (check (find-relative-path "home/zuo/src" "tmp/cache") 104 | (build-path ".." ".." ".." "tmp" "cache")) 105 | (check (find-relative-path "." "tmp/cache") 106 | (build-path "tmp" "cache")) 107 | (check (find-relative-path "tmp/cache" ".") 108 | (build-path ".." "..")) 109 | (check (find-relative-path "../bin/tarm64osx/bin/" "main.o") 110 | (build-path ".." ".." ".." (cdr (split-path (hash-ref (runtime-env) 'dir))) "main.o")) 111 | (check-arg-fail (find-relative-path "/home/zuo/src" "tmp/cache") 112 | "both relative or both absolute") 113 | 114 | (when unix? 115 | (check (find-relative-path "/home/zuo/src" "/home/zuo/src/private/optimize") 116 | "private/optimize") 117 | (check (find-relative-path "/home/zuo/src" "/home/zuo/lib") 118 | "../lib") 119 | (check (find-relative-path "/home/zuo/src" "/home/zuo/src") 120 | ".") 121 | (check (find-relative-path "/home/zuo/src" "/tmp/cache") 122 | "../../../tmp/cache")) 123 | 124 | (check (path-only "hello.txt") ".") 125 | (check (path-only ".") ".") 126 | (check (path-only "greeting/hello.txt") "greeting/") 127 | (check (path-only "in/greeting/hello.txt") "in/greeting/") 128 | (check (path-only "/") "/") 129 | (check (path-only "a/") "a/") 130 | (check (path-only "a\\") (if unix? "." "a\\")) 131 | (check (path-only "a/.") "a/.") 132 | (check (path-only "a/..") "a/..") 133 | (check-arg-fail (path-only 10) not-path) 134 | 135 | (check (file-name-from-path "hello.txt") "hello.txt") 136 | (check (file-name-from-path ".") #f) 137 | (check (file-name-from-path "greeting/hello.txt") "hello.txt") 138 | (check (file-name-from-path "in/greeting/hello.txt") "hello.txt") 139 | (check (file-name-from-path "/") #f) 140 | (check (file-name-from-path "a/") #f) 141 | (check (file-name-from-path "a\\") (if unix? "a\\" #f)) 142 | (check (file-name-from-path "a/.") #f) 143 | (check (file-name-from-path "a/..") #f) 144 | (check-arg-fail (file-name-from-path 10) not-path) 145 | -------------------------------------------------------------------------------- /zuo.h: -------------------------------------------------------------------------------- 1 | /* This header is used only when embedding Zuo in a larger 2 | application, and this file defines the embedding interface. 3 | 4 | To use an embedded Zuo, it must be initialized through the three 5 | startup steps below. The space between those steps offer two 6 | interposition opportunities: adding primitives before an image 7 | (that might rely on the primitives) is loaded, and configuring 8 | runtime information that is reported by `runtime-env`. */ 9 | 10 | #ifndef ZUO_EMBEDDED_H 11 | #define ZUO_EMBEDDED_H 12 | 13 | #ifndef ZUO_EXPORT 14 | # define ZUO_EXPORT extern 15 | #endif 16 | 17 | /* The type `zuo_ext_t*` represents a Zuo value. All values are 18 | subject to garbage collection or relocation during 19 | `zuo_eval_module` or a `zuo_ext_apply` of a non-primitive to a 20 | primitive that evaluates (`kernel-eval` or `module->hash`). Use 21 | `zuo_ext_stash_push` and `zuo_ext_stash_pop` to save something 22 | across a potential collection. */ 23 | typedef struct zuo_t zuo_ext_t; 24 | 25 | /* ======================================================================== */ 26 | /* 27 | Startup step 1: initialize primitives, and maybe add your own. 28 | 29 | Any added primitives will appear in `kernel-env`, as well as being 30 | propagated as `zuo/kernel`, `zuo`, etc., initial imports. To ensure 31 | that images will work, primitives must be added in the same order, 32 | always, and imagines will only work in an environment with the same 33 | set of primitives. 34 | */ 35 | ZUO_EXPORT void zuo_ext_primitive_init(); 36 | 37 | /* Add more primitives only after calling `zuo_ext_primitive_init`: */ 38 | typedef zuo_ext_t *(*zuo_ext_primitive_t)(zuo_ext_t *args_list); 39 | ZUO_EXPORT void zuo_ext_add_primitive(zuo_ext_primitive_t proc, int arity_mask, const char *name); 40 | 41 | /* ======================================================================== */ 42 | /* 43 | Startup step 2: load a boot image, or initialize with the default 44 | or embedded image if `boot_image_file` is NULL. 45 | */ 46 | ZUO_EXPORT void zuo_ext_image_init(char *boot_image_file); 47 | 48 | /* After calling `zuo_ext_image_init`, the following functions are available: */ 49 | 50 | /* Functions that get a constant: */ 51 | ZUO_EXPORT zuo_ext_t *zuo_ext_false(); 52 | ZUO_EXPORT zuo_ext_t *zuo_ext_true(); 53 | ZUO_EXPORT zuo_ext_t *zuo_ext_null(); 54 | ZUO_EXPORT zuo_ext_t *zuo_ext_void(); 55 | ZUO_EXPORT zuo_ext_t *zuo_ext_eof(); 56 | ZUO_EXPORT zuo_ext_t *zuo_ext_empty_hash(); 57 | 58 | /* Other data constructors and accessors: */ 59 | ZUO_EXPORT zuo_ext_t *zuo_ext_integer(long long i); 60 | ZUO_EXPORT long long zuo_ext_integer_value(zuo_ext_t *v); 61 | ZUO_EXPORT zuo_ext_t *zuo_ext_cons(zuo_ext_t *car, zuo_ext_t *cdr); 62 | ZUO_EXPORT zuo_ext_t *zuo_ext_car(zuo_ext_t *obj); 63 | ZUO_EXPORT zuo_ext_t *zuo_ext_cdr(zuo_ext_t *obj); 64 | ZUO_EXPORT zuo_ext_t *zuo_ext_string(const char *str, long long len); 65 | ZUO_EXPORT long long zuo_ext_string_length(zuo_ext_t *str); 66 | ZUO_EXPORT char *zuo_ext_string_ptr(zuo_ext_t *str); 67 | ZUO_EXPORT zuo_ext_t *zuo_ext_symbol(const char *str); 68 | ZUO_EXPORT zuo_ext_t *zuo_ext_hash_ref(zuo_ext_t *ht, zuo_ext_t *key, zuo_ext_t *fail); 69 | ZUO_EXPORT zuo_ext_t *zuo_ext_hash_set(zuo_ext_t *ht, zuo_ext_t *key, zuo_ext_t *val); 70 | 71 | /* To get more functions, use a symbol key to look them up in the 72 | kernel environment via `zuo_ext_hash_ref` --- but don't try to 73 | load, evaluate, or use any modules, yet: */ 74 | ZUO_EXPORT zuo_ext_t *zuo_ext_kernel_env(); 75 | 76 | /* At this stage, use `zuo_ext_apply` to apply primitives that don't 77 | evaluate. After `zuo_ext_runtime_init`, use this to apply and 78 | procedure. Arguments are in a list created with `zuo_ext_cons` and 79 | `zuo_ext_null`: */ 80 | ZUO_EXPORT zuo_ext_t *zuo_ext_apply(zuo_ext_t *proc, zuo_ext_t *args); 81 | 82 | /* ======================================================================== */ 83 | /* 84 | Startup step 3: finalize `runtime-env` and the full path for 85 | finding library modules. The `lib_path` argument can be `#f` to 86 | disable library loading. The `runtime_env` hash table is used as 87 | the starting point for a `runtime-env` result; include 'exe, 'args, 88 | and 'script as appropriate; other keys like 'dir are added 89 | automatically, while non-standard keys are allowed and preserved. 90 | */ 91 | ZUO_EXPORT void zuo_ext_runtime_init(zuo_ext_t *lib_path, zuo_ext_t *runtime_env); 92 | 93 | /* After `zuo_ext_runtime_init`, all functionality is available. You 94 | can load a module from a file by extracting `module->hash` from the 95 | kernel env. Or you can declare and run a module directly from 96 | source text, giveing it a module path that is eiter a symbolic 97 | library path or a file path. */ 98 | 99 | ZUO_EXPORT zuo_ext_t *zuo_ext_eval_module(zuo_ext_t *as_module_path, const char *content, long long len); 100 | 101 | /* For saving and retriving a value across an evaluation, which is 102 | when a GC might happen: */ 103 | ZUO_EXPORT void zuo_ext_stash_push(zuo_ext_t *v); 104 | ZUO_EXPORT zuo_ext_t *zuo_ext_stash_pop(); 105 | 106 | #endif 107 | 108 | /* Here's a simple example embedding application: */ 109 | #if 0 110 | 111 | #include 112 | #include 113 | #include "zuo.h" 114 | 115 | static zuo_ext_t *random_five(zuo_ext_t *args) { 116 | return zuo_ext_integer(5); 117 | } 118 | 119 | int main() { 120 | const char *prog = "#lang zuo/kernel (hash 'number (random-five))"; 121 | zuo_ext_t *ht, *v; 122 | 123 | /* Step 1 */ 124 | zuo_ext_primitive_init(); 125 | zuo_ext_add_primitive(random_five, 1, "random-five"); 126 | 127 | /* Step 2 */ 128 | zuo_ext_image_init(NULL); 129 | 130 | /* Step 3 */ 131 | zuo_ext_runtime_init(zuo_ext_false(), zuo_ext_empty_hash()); 132 | 133 | /* Run `prog`: */ 134 | ht = zuo_ext_eval_module(zuo_ext_symbol("five-app"), prog, strlen(prog)); 135 | 136 | /* Inspect the result: */ 137 | v = zuo_ext_hash_ref(ht, zuo_ext_symbol("number"), zuo_ext_false()); 138 | if (zuo_ext_apply(zuo_ext_hash_ref(zuo_ext_kernel_env(), 139 | zuo_ext_symbol("integer?"), 140 | zuo_ext_false()), 141 | zuo_ext_cons(v, zuo_ext_null())) 142 | == zuo_ext_true()) 143 | printf("The answer was %d\n", (int)zuo_ext_integer_value(v)); 144 | else 145 | printf("Something went wrong!\n"); 146 | 147 | return 0; 148 | } 149 | 150 | #endif 151 | -------------------------------------------------------------------------------- /lib/zuo/private/looper.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/kernel 2 | 3 | ;; The `zuo/private/looper` language is like `zuo/kernel`, but adds 4 | ;; `letrec`, `cond`, and `let*` --- because implementing simple 5 | ;; transformations like `or` and `and` is especially tedious without 6 | ;; those. This language use is to implement `zuo/private/stitcher`. 7 | 8 | (let ([convert-var (variable 'convert)]) 9 | (let ([convert (lambda (s) ((variable-ref convert-var) s))]) 10 | (begin 11 | (variable-set! 12 | convert-var 13 | (lambda (s) 14 | (if (pair? s) 15 | (if (eq? (car s) 'letrec) 16 | (let ([no (lambda () (error (~a "letrec: bad looper syntax: " (~s s))))]) 17 | (let ([clauses (if (pair? (cdr s)) 18 | (car (cdr s)) 19 | #f)]) 20 | (if (if (list? clauses) 21 | (if (= 1 (length clauses)) 22 | (= 2 (length (car clauses))) 23 | #f) 24 | #f) 25 | (let ([id (car (car clauses))]) 26 | (let ([rhs (car (cdr (car clauses)))]) 27 | (if (if (pair? rhs) 28 | (eq? 'lambda (car rhs)) 29 | #f) 30 | (let ([var (string->uninterned-symbol "recvar")]) 31 | (list 'let 32 | (list (list var (list 'variable (list 'quote id)))) 33 | (list 'let 34 | (list (list id 35 | (list 'lambda (car (cdr rhs)) 36 | (cons (list 'variable-ref var) 37 | (car (cdr rhs)))))) 38 | (list 'begin 39 | (list variable-set! 40 | var 41 | (let ([lam (convert rhs)]) 42 | (if #t ; keep-names? 43 | (cons (car lam) 44 | (cons (car (cdr lam)) 45 | (cons (symbol->string id) 46 | (cdr (cdr lam))))) 47 | lam))) 48 | (let ([body (cdr (cdr s))]) 49 | (if (if (list? body) 50 | (pair? body) 51 | #f) 52 | (convert (if (null? (cdr body)) 53 | (car body) 54 | (cons 'begin body))) 55 | (no))))))) 56 | (no)))) 57 | (no)))) 58 | (if (eq? (car s) 'cond) 59 | (if (not (list? s)) 60 | (error (~a "cond: bad looper syntax: " (~s s))) 61 | (if (null? (cdr s)) 62 | '(void) 63 | (let ([cl (car (cdr s))]) 64 | (if (if (list? cl) 65 | (>= (length cl) 2) 66 | #f) 67 | (let ([rhs (convert (cons 'begin (cdr cl)))]) 68 | (if (null? (cdr (cdr s))) 69 | (if (eq? (car cl) 'else) 70 | rhs 71 | (list 'if (car cl) rhs '(void))) 72 | (list 'if (car cl) rhs 73 | (convert (cons 'cond (cdr (cdr s))))))) 74 | (error (~a "cond clause: bad looper syntax: " (~s cl))))))) 75 | (if (eq? (car s) 'let*) 76 | (if (if (list? s) 77 | (if (= (length s) 3) 78 | (list? (car (cdr s))) 79 | #f) 80 | #f) 81 | (let ([clauses (car (cdr s))]) 82 | (if (null? clauses) 83 | (convert (car (cdr (cdr s)))) 84 | (let ([cl (car clauses)]) 85 | (if (if (list? cl) 86 | (if (= (length cl) 2) 87 | (symbol? (car cl)) 88 | #f) 89 | #f) 90 | (convert (list 'let (list cl) 91 | (cons 'let* 92 | (cons (cdr clauses) 93 | (cdr (cdr s)))))) 94 | (error (~a "let* clause: bad looper syntax: " (~s cl))))))) 95 | (error (~a "let*: bad looper syntax: " (~s s)))) 96 | (if (eq? (car s) 'quote) 97 | s 98 | (cons (convert (car s)) 99 | (convert (cdr s))))))) 100 | (if (eq? s 'looper-eval) ; this is how we expose looper's eval to the next layer 101 | (lambda (e) (kernel-eval (convert e))) 102 | s)))) 103 | (hash 'read-and-eval 104 | (lambda (str start mod-path) 105 | (let ([es (string-read str start mod-path)]) 106 | (if (= 1 (length es)) 107 | (kernel-eval (convert (car es))) 108 | (error "looper: only one expression allowed")))))))) 109 | -------------------------------------------------------------------------------- /lib/zuo/private/base/s-exp.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/datum 2 | 3 | ;; A context is just a distinct identity used in binding tables 4 | (define (make-module-context mod-path) 5 | (string->uninterned-symbol "module")) 6 | 7 | ;; A syntactic-closure syntax object pairs a symbol with a context 8 | (define syntactic-closure-tag (string->uninterned-symbol "identifier")) 9 | (define (syntactic-closure sym ctx) (opaque syntactic-closure-tag (cons sym ctx))) 10 | (define (syntactic-closure? v) (and (opaque-ref syntactic-closure-tag v #f) #t)) 11 | (define (syntactic-closure-sym sc) (car (opaque-ref syntactic-closure-tag sc #f))) 12 | (define (syntactic-closure-ctx sc) (cdr (opaque-ref syntactic-closure-tag sc #f))) 13 | 14 | (define (identifier? v) 15 | (or (symbol? v) 16 | (syntactic-closure? v))) 17 | (define (syntax-e x) 18 | (if (symbol? x) 19 | x 20 | (syntactic-closure-sym x))) 21 | 22 | (define (datum->syntax ctx d) d) 23 | (define syntax->datum 24 | (letrec ([syntax->datum 25 | (lambda (stx) 26 | (cond 27 | [(pair? stx) (cons (syntax->datum (car stx)) 28 | (syntax->datum (cdr stx)))] 29 | [(identifier? stx) (syntax-e stx)] 30 | [else stx]))]) 31 | syntax->datum)) 32 | 33 | (define checked-syntax-e 34 | (let ([syntax-e (lambda (x) 35 | (unless (identifier? x) (error "syntax-e: not a syntax object" x)) 36 | (syntax-e x))]) 37 | syntax-e)) 38 | (define checked-datum->syntax 39 | (let ([datum->syntax (lambda (ctx d) 40 | (unless (identifier? ctx) (error "datum->syntax: not a syntax object" ctx)) 41 | d)]) 42 | datum->syntax)) 43 | (define checked-syntax->datum syntax->datum) 44 | 45 | ;; Binding information has three parts: 46 | ;; * ctx : the current binding context 47 | ;; * sym -> ctx : the per-symbol default context for plain symbols 48 | ;; * ctx -> sym -> bind : the binding table 49 | (define (make-binds ctx sym-hash ctx-hash) (cons ctx (cons sym-hash ctx-hash))) 50 | (define binds-ctx car) 51 | (define binds-sym-hash cadr) 52 | (define binds-ctx-hash cddr) 53 | (define (binds-set-ctx binds ctx) (cons ctx (cdr binds))) 54 | (define (binds-set-ctx-hash binds ctx-hash) (cons (car binds) (cons (cadr binds) ctx-hash))) 55 | 56 | (define (binds-create ht ctx) 57 | (make-binds ctx 58 | (foldl (lambda (sym sym-hash) 59 | (hash-set sym-hash sym ctx)) 60 | (hash) 61 | (hash-keys ht)) 62 | (hash ctx ht))) 63 | 64 | ;; We don't need scopes, but these functions are here to line 65 | ;; up with the set-of-scopes API 66 | (define (make-scope name) #f) 67 | (define (add-scope e scope) e) 68 | 69 | ;; Install a new binding 70 | (define (add-binding-at binds sym ctx bind) 71 | (let* ([sym-hash (binds-sym-hash binds)] 72 | [ctx-hash (binds-ctx-hash binds)]) 73 | (make-binds (binds-ctx binds) 74 | (hash-set sym-hash sym ctx) 75 | (hash-set ctx-hash ctx (hash-set (hash-ref ctx-hash ctx (hash)) sym bind))))) 76 | (define (add-binding* binds id bind) 77 | (if (symbol? id) 78 | (add-binding-at binds 79 | id (binds-ctx binds) 80 | bind) 81 | (add-binding-at binds 82 | (syntactic-closure-sym id) (syntactic-closure-ctx id) 83 | bind))) 84 | 85 | ;; Find the binding for an identifier 86 | (define (resolve-at binds sym ctx same-defn-ctx?) 87 | (and (or (not same-defn-ctx?) 88 | (eq? ctx (binds-ctx binds))) 89 | (hash-ref (hash-ref (binds-ctx-hash binds) ctx (hash)) sym #f))) 90 | (define (resolve* binds id same-defn-ctx?) 91 | (if (symbol? id) 92 | (resolve-at binds 93 | id (hash-ref (binds-sym-hash binds) id (binds-ctx binds)) 94 | same-defn-ctx?) 95 | (resolve-at binds 96 | (syntactic-closure-sym id) (syntactic-closure-ctx id) 97 | same-defn-ctx?))) 98 | 99 | (define (new-defn-context* binds) 100 | (binds-set-ctx binds (string->uninterned-symbol "def"))) 101 | 102 | ;; When we require a module, we need to pull in binding information 103 | ;; from the macro's module; the separate module contexts keep different binding 104 | ;; information from getting mixed up 105 | (define (merge-binds* binds ctx+m-binds) 106 | (let* ([ctx-hash (binds-ctx-hash binds)] 107 | [ctx (car ctx+m-binds)]) 108 | (if (hash-ref ctx-hash ctx #f) 109 | ;; must be merged already 110 | binds 111 | (let* ([m-ctx-hash (binds-ctx-hash (cdr ctx+m-binds))] 112 | [new-ctx-hash (foldl (lambda (ctx ctx-hash) 113 | (hash-set ctx-hash ctx (hash-ref m-ctx-hash ctx #f))) 114 | ctx-hash 115 | (hash-keys m-ctx-hash))]) 116 | (binds-set-ctx-hash binds new-ctx-hash))))) 117 | 118 | ;; Convert an expansion context plus bindings to mergable ctx+binds 119 | (define (make-export-merge-binds ctx binds) 120 | (cons ctx binds)) 121 | 122 | (define (bound-identifier=? a b) 123 | (unless (identifier? a) (error "bound-identifier=?: not a syntax object" a)) 124 | (unless (identifier? b) (error "bound-identifier=?: not a syntax object" b)) 125 | (or (and (syntactic-closure? a) 126 | (syntactic-closure? b) 127 | (eq? (syntactic-closure-sym a) (syntactic-closure-sym b)) 128 | (eq? (syntactic-closure-ctx a) (syntactic-closure-ctx b))) 129 | (eq? a b))) 130 | 131 | (include "../base-common/free-id-eq.zuo") 132 | 133 | ;; syntax-quote turns a symbol into a syntactic closure, and leaves everything 134 | ;; else alone; the closure captures the enclosing context where the symbol is 135 | ;; currently bound, or the module context if it's not bound 136 | (define (syntax-quote v mod-ctx binds) 137 | (letrec ([syntax-quote 138 | (lambda (v) 139 | (cond 140 | [(pair? v) (list 'cons (syntax-quote (car v)) (syntax-quote (cdr v)))] 141 | [(null? v) '()] 142 | [(symbol? v) 143 | (list 'quote (syntactic-closure v (hash-ref (binds-sym-hash binds) v mod-ctx)))] 144 | [else v]))]) 145 | (syntax-quote v))) 146 | 147 | (define (apply-macro m s ctx binds name k) 148 | (let ([proc (if (defined-macro? m) 149 | (defined-macro-proc m) 150 | (macro-implementation m))]) 151 | (k (apply-macro* proc s name (lambda (a b) (free-id=? binds a b))) 152 | binds))) 153 | 154 | ;; Convert a local macro to one that can be used as imported elsewhere 155 | (define (make-exported-macro proc ctx) 156 | (make-macro proc)) 157 | 158 | -------------------------------------------------------------------------------- /local/image.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo 2 | 3 | ;; This module works in three modes: 4 | ;; * as a library to provide `embed-image` 5 | ;; - that's the `embed-image` provided function, obviously 6 | ;; * as a script that parses command-line arguments to drive `embed-image` 7 | ;; - that's the `(module+ main ...)` below 8 | ;; * as a build component that provides a target to drive `embed-image` 9 | ;; - that's the `image-target` provided function, which takes 10 | ;; the same hash-table specification as `embed-image`, but returns a 11 | ;; target instead of immediately generating output 12 | 13 | (provide embed-image ; hash? -> void? 14 | image-target) ; hash? -> target? 15 | 16 | ;; `embed-image` recognizes the following keys in its argument: 17 | ;; 18 | ;; * 'output : #f or destination path string; #f (default) means to stdout 19 | ;; 20 | ;; * 'libs: list of module-path symbols; default is '(zuo) 21 | ;; 22 | ;; * 'deps: a file to record files reda to create the image; presence 23 | ;; along with non-#f 'output enables a potetial 'up-to-date result 24 | ;; 25 | ;; * 'keep-collects?: boolean for whether to keep the collection library 26 | ;; path enabled; default is #f 27 | 28 | (module+ main 29 | (define cmd 30 | (command-line 31 | :once-each 32 | [cmd "-o" file "Output to instead of stdout" 33 | (hash-set cmd 'output file)] 34 | :multi 35 | [cmd "++lib" module-path "Embed and its dependencies" 36 | (hash-set cmd 'libs (cons (string->symbol module-path) 37 | (hash-ref cmd 'libs '())))] 38 | :once-each 39 | [cmd "--deps" file "Write dependencies to " 40 | (hash-set cmd 'deps file)] 41 | [cmd "--keep-collects" "Keep library collection path enabled" 42 | (hash-set cmd 'keep-collects? #t)])) 43 | (embed-image cmd)) 44 | 45 | (define (image-target cmd) 46 | (target 47 | (hash-ref cmd 'output) ; the output file; `target` uses SHA-1 on this 48 | (lambda (path token) 49 | ;; when a target is demanded, we report dependencies and more via `rule` 50 | (rule 51 | ;; dependencies: 52 | (list (at-source ".." "zuo.c") ; original "zuo.c" that is converted to embed libraries 53 | (quote-module-path) ; this script 54 | (input-data-target 'config (hash-remove cmd 'output))) ; configuration 55 | ;; rebuild function (called if the output file is out of date): 56 | (lambda () 57 | ;; get `embed-image` to tell us which module files it used: 58 | (define deps-file (path-replace-suffix path ".dep")) 59 | ;; generated the output file 60 | (embed-image (let* ([cmd (hash-set cmd 'output path)] 61 | [cmd (hash-set cmd 'deps deps-file)]) 62 | cmd)) 63 | ;; register each source module as a discovered dependency: 64 | (for-each (lambda (p) (build/recur p token)) 65 | (string-read (file->string deps-file) 0 deps-file))))))) 66 | 67 | (define (embed-image cmd) 68 | (define given-libs (hash-ref cmd 'libs '())) 69 | (define libs (if (null? given-libs) 70 | '(zuo) 71 | given-libs)) 72 | 73 | (define deps-file (hash-ref cmd 'deps #f)) 74 | (define c-file (hash-ref cmd 'output #f)) 75 | 76 | (when c-file 77 | (displayln (~a "generating " c-file " embedding these libraries: " (string-join (map ~s libs))))) 78 | (when deps-file 79 | (display-to-file "" deps-file :truncate)) 80 | 81 | (define deps-h (and deps-file (cleanable-file deps-file))) 82 | 83 | (define image 84 | (let ([ht (apply process 85 | (append 86 | (list (hash-ref (runtime-env) 'exe)) 87 | (if deps-file 88 | (list "-M" deps-file) 89 | (list)) 90 | (list "" (hash 'stdin 'pipe 'stdout 'pipe))))]) 91 | (define p (hash-ref ht 'process)) 92 | (define in (hash-ref ht 'stdin)) 93 | (define out (hash-ref ht 'stdout)) 94 | (fd-write in "#lang zuo/kernel\n") 95 | (fd-write in "(begin\n") 96 | (for-each (lambda (lib) 97 | (fd-write in (~a "(module->hash '" lib ")\n"))) 98 | libs) 99 | (fd-write in "(dump-image-and-exit (fd-open-output 'stdout (hash))))\n") 100 | (fd-close in) 101 | (let ([image (fd-read out eof)]) 102 | (fd-close out) 103 | (process-wait p) 104 | (unless (= 0 (process-status p)) 105 | (error "image dump failed")) 106 | image))) 107 | 108 | (define zuo.c (fd-read (fd-open-input (at-source ".." "zuo.c")) eof)) 109 | (define out (if c-file 110 | (fd-open-output c-file (hash 'exists 'truncate)) 111 | (fd-open-output 'stdout (hash)))) 112 | 113 | (define lines (let ([l (reverse (string-split zuo.c "\n"))]) 114 | ;; splitting on newlines should leave us with an empty last string 115 | ;; that doesn't represent a line 116 | (reverse (if (and (pair? l) (equal? "" (car l))) 117 | (cdr l) 118 | l)))) 119 | 120 | (define (~hex v) 121 | (if (= v 0) 122 | "0" 123 | (let loop ([v v] [accum '()]) 124 | (if (= v 0) 125 | (apply ~a accum) 126 | (loop (quotient v 16) 127 | (cons (let ([i (bitwise-and v 15)]) 128 | (substring "0123456789abcdef" i (+ i 1))) 129 | accum)))))) 130 | 131 | (define embedded-image-line "#define EMBEDDED_IMAGE 0") 132 | (define embedded-image-line/cr (~a embedded-image-line "\r")) 133 | 134 | (for-each 135 | (lambda (line) 136 | (cond 137 | [(or (string=? line embedded-image-line) 138 | (string=? line embedded-image-line/cr)) 139 | (define nl (if (string=? line embedded-image-line/cr) "\r\n" "\n")) 140 | (unless (hash-ref cmd 'keep-collects? #f) 141 | (fd-write out (~a "#define ZUO_LIB_PATH NULL" nl))) 142 | (fd-write out (~a "#define EMBEDDED_IMAGE 1" nl)) 143 | (fd-write out (~a "static zuo_uint32_t emedded_boot_image_len = " 144 | (quotient (string-length image) 4) 145 | ";" nl)) 146 | (fd-write out (~a "static zuo_uint32_t emedded_boot_image[] = {" nl)) 147 | (let ([accum->line (lambda (accum) (apply ~a (reverse (cons nl accum))))]) 148 | (let loop ([i 0] [col 0] [accum '()]) 149 | (cond 150 | [(= i (string-length image)) 151 | (unless (null? accum) 152 | (fd-write out (accum->line accum)))] 153 | [(= col 8) 154 | (fd-write out (accum->line accum)) 155 | (loop i 0 '())] 156 | [else 157 | (loop (+ i 4) (+ col 1) 158 | (cons (~a " 0x" (~hex (string-u32-ref image i)) ",") 159 | accum))]))) 160 | (fd-write out (~a " 0 };" nl))] 161 | [else 162 | (fd-write out (~a line "\n"))])) 163 | lines) 164 | 165 | (when c-file (fd-close out)) 166 | 167 | (when deps-h 168 | (cleanable-cancel deps-h))) 169 | -------------------------------------------------------------------------------- /lib/zuo/private/cmdline-run.zuo: -------------------------------------------------------------------------------- 1 | #lang zuo/base 2 | 3 | (provide run-cmdline 4 | flag-parser) 5 | 6 | (define (run-cmdline program cmd args flags finish-handler finish-spec usage help-specs) 7 | 8 | (define (finish cmd args) 9 | (define expected (+ (length (car finish-spec)) 10 | (length (cdr finish-spec)))) 11 | (unless (if (null? (cddr finish-spec)) 12 | (and (>= (length args) (length (car finish-spec))) 13 | (<= (length args) (+ (length (car finish-spec)) 14 | (length (cadr finish-spec))))) 15 | (>= (length args) (length (car finish-spec)))) 16 | (error (~a program 17 | ": expected " 18 | (let ([s (spec->expected-string finish-spec)]) 19 | (if (string=? "" s) 20 | "no command-line arguments" 21 | (~a "arguments " s))) 22 | (if (null? args) 23 | "" 24 | (~a "\n given arguments:\n " 25 | (string-join (map ~a args) "\n ")))))) 26 | (apply-cmd "arguments handler" (apply finish-handler args) cmd)) 27 | 28 | (let loop ([pend-flags '()] [args args] [saw (hash)] [cmd cmd]) 29 | (cond 30 | [(and (null? args) (null? pend-flags)) (finish cmd args)] 31 | [else 32 | (let* ([arg (if (pair? pend-flags) (car pend-flags) (car args))] 33 | [pend-flags (if (pair? pend-flags) (cdr pend-flags) '())] 34 | [args (if (pair? pend-flags) args (cdr args))] 35 | [a (assoc arg flags)]) 36 | (cond 37 | [a ((cdr a) program pend-flags (cons arg args) cmd saw loop)] 38 | [(string=? arg "--") (if (null? pend-flags) 39 | (finish cmd args) 40 | (loop (append pend-flags (list arg)) args saw cmd))] 41 | [(or (string=? arg "--help") 42 | (string=? arg "-h")) 43 | (show-help program finish-spec usage help-specs flags) 44 | (exit 0)] 45 | [(and (> (string-length arg) 2) 46 | (= (string-ref arg 0) (char "-")) 47 | (not (= (string-ref arg 1) (char "-")))) 48 | (loop (split-flags arg) args saw cmd)] 49 | [(and (> (string-length arg) 0) 50 | (or (= (string-ref arg 0) (char "-")) 51 | (= (string-ref arg 0) (char "+")))) 52 | (error (~a program ": unrecognized flag " arg))] 53 | [else (finish cmd (cons arg args))]))]))) 54 | 55 | (define (split-flags s) 56 | (let loop ([i 1]) 57 | (if (= i (string-length s)) 58 | '() 59 | (cons (string (char "-") (string-ref s i)) 60 | (loop (+ i 1)))))) 61 | 62 | (define (spec->expected-string spec) 63 | (~a (string-join (car spec)) 64 | (let ([dots (if (null? (cddr spec)) "" " ...")]) 65 | (if (null? (cadr spec)) 66 | dots 67 | (~a " [" (string-join (cadr spec)) dots "]"))))) 68 | 69 | (define (flag-parser key handler spec) 70 | (lambda (program pend-flags flag+args cmd saw k) 71 | (when key 72 | (when (hash-ref saw key #f) 73 | (error (~a program ": redundant or conflicting flag " (car flag+args))))) 74 | (define new-saw (if key (hash-set saw key #t) saw)) 75 | (define args (cdr flag+args)) 76 | (unless (>= (length args) (length (car spec))) 77 | (error (~a program 78 | ": expected more arguments for " 79 | (car flag+args) 80 | " " 81 | (spec->expected-string spec)))) 82 | (define consumed (if (= 3 (length spec)) 83 | args 84 | (let loop ([args args] [need (length (car spec))] [allow (length (cadr spec))]) 85 | (cond 86 | [(= (+ need allow) 0) '()] 87 | [(null? args) '()] 88 | [else (cons (car args) 89 | (loop (cdr args) 90 | (if (= need 0) 0 (- need 1)) 91 | (if (= need 0) (- allow 1) allow)))])))) 92 | (define rest-args (list-tail args (length consumed))) 93 | (k pend-flags rest-args new-saw (apply-cmd (~a "handler for " (car flag+args)) 94 | (apply handler consumed) 95 | cmd)))) 96 | 97 | (define (apply-cmd who handler cmd) 98 | (if (procedure? handler) 99 | (handler cmd) 100 | (error (~a " did not produce a procedure to receive accumulated state")))) 101 | 102 | (define (show-help program finish-spec usage help-specs flags) 103 | (displayln 104 | (~a "usage: " program " " 105 | (or usage 106 | (~a "[