diff --git a/Makefile b/Makefile index 8e56b85f..6cb10b72 100644 --- a/Makefile +++ b/Makefile @@ -46,10 +46,12 @@ COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \ BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h include/chibi/gc_heap.h -MODULE_DOCS := app ast config diff disasm equiv filesystem generic heap-stats io \ - loop match mime modules net net/http-server parse pathname process repl scribble stty \ - system test time trace type-inference uri weak monad/environment \ - crypto/sha2 +MODULE_DOCS := app ast base64 bytevector config crypto/md5 crypto/rsa \ + crypto/sha2 diff disasm doc equiv filesystem generic heap-stats io \ + iset/base iset/constructors iset/iterators loop match math/prime \ + memoize mime modules net net/http-server net/servlet parse pathname \ + process repl scribble string stty sxml system temp-file test time \ + trace type-inference uri weak monad/environment crypto/sha2 IMAGE_FILES = lib/chibi.img lib/red.img lib/snow.img diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index f3d5f56c..ba523269 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -112,6 +112,7 @@ are listed below. \item{\ccode{SEXP_USE_RATIOS} - use exact ratios (enabled by default)} \item{\ccode{SEXP_USE_COMPLEX} - use complex numbers (enabled by default)} \item{\ccode{SEXP_USE_UTF8_STRINGS} - Unicode support (enabled by default)} +\item{\ccode{SEXP_USE_STRING_INDEX_TABLE} - precompute offsets for O(1) \scheme{string-ref}} \item{\ccode{SEXP_USE_NO_FEATURES} - disable almost all features} ] @@ -137,9 +138,10 @@ superset of \hyperlink["http://www.schemers.org/Documents/Standards/R5RS/HTML/"]{R5RS}. The reader defaults to case-sensitive, like R6RS and R7RS but unlike -R5RS. The default configuration includes the full numeric tower: -fixnums, flonums, bignums, exact rationals and complex numbers, though -this can be customized at compile time. +R5RS. You can specify the -f option on the command-line to enable +case-folding. The default configuration includes the full numeric +tower: fixnums, flonums, bignums, exact rationals and complex numbers, +though this can be customized at compile time. Full continuations are supported, but currently continuations don't take C code into account. This means that you can call from Scheme to @@ -179,11 +181,12 @@ other languages. \subsection{Module System} -Chibi uses the R7RS module system natively, which is a simple static -module system in the style of the -\hyperlink["http://s48.org/"]{Scheme48} module system. As with most -features this is optional, and can be ignored or completely disabled -at compile time. +Chibi supports the R7RS module system natively, which is a simple +static module system. The Chibi implementation is actually a +hierarchy of languages in the style of the +\hyperlink["http://s48.org/"]{Scheme48} module system, allowing easy +extension of the module system itself. As with most features this is +optional, and can be ignored or completely disabled at compile time. Modules names are hierarchical lists of symbols or numbers. A module definition uses the following form: @@ -202,6 +205,7 @@ where \var{} can be any of (include ...) ;; load one or more files (include-ci ...) ;; as include, with case-folding (include-shared ...) ;; dynamic load a library (non-R7RS) + (alias-for ) ;; a library alias (non-R7RS) } \var{} can either be a module name or any of @@ -286,23 +290,31 @@ constructors: \subsection{Unicode} -Chibi supports Unicode strings, encoding them as utf8. This provides easy -interoperability with many C libraries, but means that \scheme{string-ref} and -\scheme{string-set!} are O(n), so they should be avoided in -performance-sensitive code. +Chibi supports Unicode strings and I/O natively. Case mappings and +comparisons, character properties, formatting and regular expressions +are all Unicode aware, supporting the latest version 13.0 of the +Unicode standard. + +Internally strings are encoded as UTF-8. This provides easy +interoperability with many C libraries, but means that +\scheme{string-ref} and \scheme{string-set!} are O(n), so they should +be avoided in performance-sensitive code (unless you compile Chibi +with SEXP_USE_STRING_INDEX_TABLE). In general you should use high-level APIs such as \scheme{string-map} to ensure fast string iteration. String ports also provide a simple -way to efficiently iterate and construct strings, by looping over an -input string or accumulating characters in an output string. +and portable way to efficiently iterate and construct strings, by +looping over an input string or accumulating characters in an output +string. The \scheme{in-string} and \scheme{in-string-reverse} iterators in the \scheme{(chibi loop)} module will also iterate over strings efficiently while hiding the low-level details. In the event that you do need a low-level interface, such as when -writing your own iterator protocol, you should use the following -string cursor API instead of indexes. +writing your own iterator protocol, you should use string cursors. +\scheme{(srfi 130)} provides a portable API for this, or you can use +\scheme{(chibi string)} which builds on the following core procedures: \itemlist[ \item{\scheme{(string-cursor-start str)} @@ -338,9 +350,10 @@ To use Chibi-Scheme in a program you need to link against the \ccode{#include } -All definitions begin with a "sexp_" prefix, or "SEXP_" for constants. -In addition to the prototypes and utility macros, this includes the -following type definitions: +All definitions begin with a "sexp_" prefix, or "SEXP_" for constants +(deliberately chosen not to conflict with other Scheme implementations +which typically use "scm_"). In addition to the prototypes and +utility macros, this includes the following type definitions: \itemlist[ \item{\ctype{sexp} - an s-expression, used to represent all Scheme objects} @@ -673,6 +686,7 @@ need to check manually before applying the predicate. \item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number} \item{\ccode{sexp_charp(obj)} - \var{obj} is a character} \item{\ccode{sexp_stringp(obj)} - \var{obj} is a string} +\item{\ccode{sexp_string_cursorp(obj)} - \var{obj} is a string cursor} \item{\ccode{sexp_bytesp(obj)} - \var{obj} is a bytevector} \item{\ccode{sexp_symbolp(obj)} - \var{obj} is a symbol} \item{\ccode{sexp_idp(obj)} - \var{obj} is a symbol or hygienic identifier} @@ -730,7 +744,7 @@ check. The runtime does not prevent embedded NULLs inside strings, however data after the NULL may be ignored. By default (unless you compile with -DSEXP_USE_UTF8_STRING=0), strings -are interpreted as utf8 encoded on the Scheme side, as describe in +are interpreted as UTF-8 encoded on the Scheme side, as describe in section Unicode above. In many cases you can ignore this on the C side and just treat the string as an opaque sequence of bytes. However, if you need to you can use the following macros to safely @@ -748,7 +762,7 @@ compiled with: \item{\ccode{sexp sexp_substring_cursor(sexp ctx, sexp s, sexp i, sexp j)} - returns the substring between raw offsets \var{i} and \var{j}} ] -When UTF8 support is not compiled in the cursor and non-cursor +When UTF-8 support is not compiled in the cursor and non-cursor variants are equivalent. \subsubsection{Accessors} @@ -766,6 +780,8 @@ once. \item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer} \item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}} \item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char} +\item{\ccode{sexp sexp_make_string_cursor(int offset)} - creates a string cursor for the given byte offset} +\item{\ccode{int sexp_unbox_string_cursor(sexp sc)} - returns the offset for the given string cursor} \item{\ccode{sexp_car(pair)} - the car of \var{pair}} \item{\ccode{sexp_cdr(pair)} - the cdr of \var{pair}} \item{\ccode{sexp_ratio_numerator(q)} - the numerator of the ratio \var{q}} @@ -1245,13 +1261,18 @@ snow-fort): \item{\hyperlink["http://srfi.schemers.org/srfi-135/srfi-135.html"]{(srfi 135) - immutable texts}} \item{\hyperlink["http://srfi.schemers.org/srfi-139/srfi-139.html"]{(srfi 139) - syntax parameters}} \item{\hyperlink["http://srfi.schemers.org/srfi-141/srfi-141.html"]{(srfi 141) - integer division}} +\item{\hyperlink["http://srfi.schemers.org/srfi-143/srfi-142.html"]{(srfi 142) - bitwise operations}} \item{\hyperlink["http://srfi.schemers.org/srfi-143/srfi-143.html"]{(srfi 143) - fixnums}} \item{\hyperlink["http://srfi.schemers.org/srfi-144/srfi-144.html"]{(srfi 144) - flonums}} \item{\hyperlink["http://srfi.schemers.org/srfi-145/srfi-145.html"]{(srfi 145) - assumptions}} \item{\hyperlink["http://srfi.schemers.org/srfi-147/srfi-147.html"]{(srfi 147) - custom macro transformers}} \item{\hyperlink["http://srfi.schemers.org/srfi-151/srfi-151.html"]{(srfi 151) - bitwise operators}} \item{\hyperlink["http://srfi.schemers.org/srfi-154/srfi-154.html"]{(srfi 154) - first-class dynamic extents}} -\item{\hyperlink["http://srfi.schemers.org/srfi-159/srfi-159.html"]{(srfi 159) - combinator formatting}} +\item{\hyperlink["http://srfi.schemers.org/srfi-158/srfi-158.html"]{(srfi 158) - generators and accumulators}} +\item{\hyperlink["http://srfi.schemers.org/srfi-160/srfi-160.html"]{(srfi 160) - homogeneous numeric vector libraries}} +\item{\hyperlink["http://srfi.schemers.org/srfi-165/srfi-165.html"]{(srfi 165) - the environment Monad}} +\item{\hyperlink["http://srfi.schemers.org/srfi-166/srfi-166.html"]{(srfi 166) - monadic formatting}} +\item{\hyperlink["http://srfi.schemers.org/srfi-166/srfi-188.html"]{(srfi 188) - splicing binding constructs for syntactic keywords}} ] @@ -1264,12 +1285,24 @@ namespace. \item{\hyperlink["lib/chibi/ast.html"]{(chibi ast) - Abstract Syntax Tree and other internal data types}} +\item{\hyperlink["lib/chibi/base64.html"]{(chibi base64) - Base64 encoding and decoding}} + +\item{\hyperlink["lib/chibi/bytevector.html"]{(chibi bytevector) - Bytevector Utilities}} + \item{\hyperlink["lib/chibi/config.html"]{(chibi config) - General configuration management}} -\item{\hyperlink["lib/chibi/disasm.html"]{(chibi diff) - LCS Algorithm and diff utilities}} +\item{\hyperlink["lib/chibi/crypto/md5.html"]{(chibi crypto md5) - MD5 hash}} + +\item{\hyperlink["lib/chibi/crypto/rsa.html"]{(chibi crypto rsa) - RSA public key encryption}} + +\item{\hyperlink["lib/chibi/crypto/sha2.html"]{(chibi crypto sha2) - SHA-2 hash}} + +\item{\hyperlink["lib/chibi/diff.html"]{(chibi diff) - LCS Algorithm and diff utilities}} \item{\hyperlink["lib/chibi/disasm.html"]{(chibi disasm) - Disassembler for the virtual machine}} +\item{\hyperlink["lib/chibi/doc.html"]{(chibi doc) - Chibi documentation utilities}} + \item{\hyperlink["lib/chibi/equiv.html"]{(chibi equiv) - A version of \scheme{equal?} which is guaranteed to terminate}} \item{\hyperlink["lib/chibi/filesystem.html"]{(chibi filesystem) - Interface to the filesystem and file descriptor objects}} @@ -1280,10 +1313,22 @@ namespace. \item{\hyperlink["lib/chibi/io.html"]{(chibi io) - Various I/O extensions and custom ports}} +\item{\hyperlink["lib/chibi/iset/base.html"]{(chibi iset base) - Compact integer sets}} + +\item{\hyperlink["lib/chibi/iset/base.html"]{(chibi iset base) - Compact integer sets}} + +\item{\hyperlink["lib/chibi/iset/constructors.html"]{(chibi iset constructors) - Compact integer set construction}} + +\item{\hyperlink["lib/chibi/iset/iterators.html"]{(chibi iset iterators) - Iterating over compact integer sets}} + \item{\hyperlink["lib/chibi/loop.html"]{(chibi loop) - Fast and extensible loop syntax}} \item{\hyperlink["lib/chibi/match.html"]{(chibi match) - Intuitive and widely supported pattern matching syntax}} +\item{\hyperlink["lib/chibi/math/prime.html"]{(chibi math prime) - Prime number utilities}} + +\item{\hyperlink["lib/chibi/memoize.html"]{(chibi memoize) - Procedure memoization}} + \item{\hyperlink["lib/chibi/mime.html"]{(chibi mime) - Parse MIME files into SXML}} \item{\hyperlink["lib/chibi/modules.html"]{(chibi modules) - Introspection for the module system itself}} @@ -1292,6 +1337,8 @@ namespace. \item{\hyperlink["lib/chibi/net/http-server.html"]{(chibi net http-server) - Simple http-server with servlet support}} +\item{\hyperlink["lib/chibi/net/servlet.html"]{(chibi net servlet) - HTTP servlets for http-server or CGI}} + \item{\hyperlink["lib/chibi/parse.html"]{(chibi parse) - Parser combinators with convenient syntax}} \item{\hyperlink["lib/chibi/pathname.html"]{(chibi pathname) - Utilities to decompose and manipulate pathnames}} @@ -1302,12 +1349,16 @@ namespace. \item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}} -\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - A combinator formatting library}} +\item{\hyperlink["lib/chibi/string.html"]{(chibi string) - Cursor-based string library (predecessor to SRFI 130)}} \item{\hyperlink["lib/chibi/stty.html"]{(chibi stty) - A high-level interface to ioctl}} +\item{\hyperlink["lib/chibi/sxml.html"]{(chibi sxml) - SXML utilities}} + \item{\hyperlink["lib/chibi/system.html"]{(chibi system) - Access to the host system and current user information}} +\item{\hyperlink["lib/chibi/temp-file.html"]{(chibi temp-file) - Temporary file and directory creation}} + \item{\hyperlink["lib/chibi/test.html"]{(chibi test) - A simple unit testing framework}} \item{\hyperlink["lib/chibi/time.html"]{(chibi time) - An interface to the current system time}} @@ -1325,7 +1376,7 @@ namespace. \section{Snow Package Manager} Beyond the distributed modules, Chibi comes with a package manager -based on \hyperlink["http://trac.sacrideo.us/wg/wiki/Snow"]{Snow2} +based on \hyperlink["https://small.r7rs.org/wiki/Snow/"]{Snow2} which can be used to share R7RS libraries. Packages are distributed as tar gzipped files called "snowballs," and may contain multiple libraries. The program is installed as \scheme{snow-chibi}. The diff --git a/lib/chibi/doc.scm b/lib/chibi/doc.scm index 637b0b82..ca6a13fd 100644 --- a/lib/chibi/doc.scm +++ b/lib/chibi/doc.scm @@ -377,11 +377,15 @@ (err-str (get-output-string tmp-err))) `(,@(if (string-null? out-str) '() - `((div (@ (class . "output")) ,(ansi->sxml out-str)))) + `((div (@ (class . "output")) (pre ,(ansi->sxml out-str))))) ,@(if (string-null? err-str) '() - `((div (@ (class . "error")) ,(ansi->sxml err-str)))) - (div (@ (class . "result")) (code ,res-str)))))))) + `((div (@ (class . "error")) (pre ,(ansi->sxml err-str))))) + ,@(if (and (or (not (string-null? err-str)) + (not (string-null? out-str))) + (eq? res (if #f #f))) + '() + `((div (@ (class . "result")) (code ,res-str)))))))))) (define (expand-example-import x env) (eval `(import ,@(cdr x)) @@ -486,7 +490,7 @@ div#notes {position: relative; top: 2em; left: 570px; max-width: 200px; height: div#footer {padding-bottom: 50px} .result { color: #000; background-color: #FFEADF; width: 100%; padding: 3px} .output { color: #000; background-color: beige; width: 100%; padding: 3px} -.error { color: #000; background-color: #330000; width: 100%; padding: 3px} +.error { color: #000; background-color: #F0B0B0; width: 100%; padding: 3px} .command { color: #000; background-color: #FFEADF; width: 100%; padding: 5px} " ,(highlight-style)) diff --git a/lib/chibi/test.scm b/lib/chibi/test.scm index d19e9625..4be77896 100644 --- a/lib/chibi/test.scm +++ b/lib/chibi/test.scm @@ -42,21 +42,28 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; test interface +;;> \section{Testing} + ;;> \macro{(test [name] expect expr)} ;;> The primary interface to testing. Evaluate \var{expr} and check -;;> that it is \scheme{equal?} to \var{expect}. \var{name} is used -;;> in reporting, and defaults to a printed summary of \var{expr}. -;;> Returns the status of the test (one of the symbols \scheme{'PASS}, -;;> \scheme{'FAIL}, \scheme{'SKIP}, \scheme{'ERROR}). +;;> that it is equal to \var{expect}, and report the result, using +;;> \var{name} or a printed summary of \var{expr}. ;;> ;;> If used inside a group this will contribute to the overall group -;;> reporting, but can be used standalone. +;;> reporting, but can be used standalone: ;;> ;;> \example{(test 4 (+ 2 2))} ;;> \example{(test "add two and two" 4 (+ 2 2))} ;;> \example{(test 3 (+ 2 2))} ;;> \example{(test 4 (+ 2 "2"))} +;;> +;;> The equality comparison is made with +;;> \scheme{current-test-comparator}, defaulting to +;;> \scheme{test-equal?}, which is the same as \scheme{equal?} but +;;> more permissive on floating point comparisons). Returns the +;;> status of the test (one of the symbols \scheme{'PASS}, +;;> \scheme{'FAIL}, \scheme{'SKIP}, \scheme{'ERROR}). (define-syntax test (syntax-rules (quote) @@ -138,10 +145,12 @@ (test-syntax-error 'test-error "1 or 2 arguments required" (test a ...))))) -;; TODO: Extract interesting variables so we can show their values on -;; failure. +;;> Low-level macro to pass alist info to the underlying \var{test-run}. + (define-syntax test-propagate-info (syntax-rules () + ;; TODO: Extract interesting variables so we can show their values + ;; on failure. Vars are empty for now. ((test-propagate-info name expect expr info) (test-vars () name expect expr info)))) @@ -156,25 +165,64 @@ (var-values . ,(list vars ...)) (key . val) ...))))) -;;> Exits with a failure status if any tests have failed, -;;> and a successful status otherwise. +;;> The procedural interface to testing. \var{expect} and \var{expr} +;;> should be thunks, and \var{info} is an alist of properties used in +;;> test reporting. -(define (test-exit) - (exit (zero? (test-failure-count)))) +(define (test-run expect expr info) + (let ((info (test-expand-info info))) + (if (and (cond ((current-test-group) + => (lambda (g) (not (test-group-ref g 'skip-group?)))) + (else #t)) + (or (and (not (any (lambda (f) (f info)) (current-test-removers))) + (or (pair? (current-test-removers)) + (null? (current-test-filters)))) + (any (lambda (f) (f info)) (current-test-filters)))) + ((current-test-applier) expect expr info) + ((current-test-skipper) info)))) + +;;> Returns true if either \scheme{(equal? expect res)}, or +;;> \var{expect} is inexact and \var{res} is within +;;> \scheme{current-test-epsilon} of \var{expect}. + +(define (test-equal? expect res) + (or (equal? expect res) + (if (real? expect) + (and (inexact? expect) + (real? res) + ;; tests which expect an inexact value can + ;; accept an equivalent exact value + ;; (inexact? res) + (approx-equal? expect res (current-test-epsilon))) + (and (complex? res) + (complex? expect) + (test-equal? (real-part expect) (real-part res)) + (test-equal? (imag-part expect) (imag-part res)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; group interface +;;> \section{Test Groups} + +;;> Tests can be collected in groups for + ;;> Wraps \var{body} as a single test group, which can be filtered ;;> and summarized separately. +;;> \example{ +;;> (test-group "pi" +;;> (test 3.14159 (acos -1)) +;;> (test 3 (acos -1)) +;;> (test 3.14159 (acos "-1"))) +;;> } + (define-syntax test-group (syntax-rules () ((_ name-expr body ...) (let ((name name-expr) (old-group (current-test-group))) - (if (not (string? name)) - (error "a name is required, got " 'name-expr name)) + (when (not (string? name)) + (error "a name is required, got " 'name-expr name)) (test-begin name) (guard (exn @@ -188,6 +236,78 @@ (test-end name) (current-test-group old-group))))) +;;> Begin testing a new group until the closing \scheme{(test-end)}. + +(define (test-begin . o) + (let* ((name (if (pair? o) (car o) "")) + (parent (current-test-group)) + (group (make-test-group name parent))) + ;; include a newline if we are directly nested in a parent with no + ;; tests yet + (when (and parent + (zero? (test-group-ref parent 'subgroups-count 0)) + (not (test-group-ref parent 'verbose))) + (newline)) + ;; header + (cond + ((test-group-ref group 'skip-group?) + (display (make-string (or (test-group-indent-width group) 0) #\space)) + (display (strikethrough (bold (string-append name ":")))) + (display " SKIP")) + ((test-group-ref group 'verbose) + (display + (test-header-line + (string-append "testing " name) + (or (test-group-indent-width group) 0)))) + (else + (display + (string-append + (make-string (or (test-group-indent-width group) 0) + #\space) + (bold (string-append name ": ")))))) + ;; set the current test group + (current-test-group group))) + +;;> Ends testing group introduced with \scheme{(test-begin)}, and +;;> summarizes the results. The \var{name} is optional, but if +;;> present should match the corresponding \scheme{test-begin} name, +;;> or a warning is printed. + +(define (test-end . o) + (let ((name (and (pair? o) (car o)))) + (cond + ((current-test-group) + => (lambda (group) + (when (and name (not (equal? name (test-group-name group)))) + (warning "mismatched test-end:" name (test-group-name group))) + (let ((parent (test-group-ref group 'parent))) + (when (and (test-group-ref group 'skip-group?) + (zero? (test-group-ref group 'subgroups-count 0))) + (newline)) + ;; only report if there's something to say + ((current-test-group-reporter) group) + (when parent + (test-group-inc! parent 'subgroups-count) + (cond + ((test-group-ref group 'skip-group?) + (test-group-inc! parent 'subgroups-skip)) + ((and (zero? (test-group-ref group 'FAIL 0)) + (zero? (test-group-ref group 'ERROR 0)) + (= (test-group-ref group 'subgroups-pass 0) + (test-group-ref group 'subgroups-count 0))) + (test-group-inc! parent 'subgroups-pass)))) + (current-test-group parent) + group)))))) + +;;> Exits with a failure status if any tests have failed, +;;> and a successful status otherwise. + +(define (test-exit) + (when (current-test-group) + (warning "calling test-exit with unfinished test group:" + (test-group-name (current-test-group)))) + (exit (zero? (test-failure-count)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utilities @@ -198,6 +318,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; test-group representation +;;> \section{Accessors} + ;; (name (prop value) ...) (define (make-test-group name . o) (let ((parent (and (pair? o) (car o))) @@ -223,7 +345,7 @@ ;;> Returns the name of a test group info object. -(define test-group-name car) +(define (test-group-name group) (car group)) ;;> Returns the value of a \var{field} in a test var{group} info ;;> object. \var{field} should be a symbol, and predefined fields @@ -394,18 +516,6 @@ ,@info) info))) -(define (test-run expect expr info) - (let ((info (test-expand-info info))) - (if (and (cond ((current-test-group) - => (lambda (g) (not (test-group-ref g 'skip-group?)))) - (else #t)) - (or (and (not (any (lambda (f) (f info)) (current-test-removers))) - (or (pair? (current-test-removers)) - (null? (current-test-filters)))) - (any (lambda (f) (f info)) (current-test-filters)))) - ((current-test-applier) expect expr info) - ((current-test-skipper) info)))) - (define (test-default-applier expect expr info) (let* ((group (current-test-group)) (indent (and group (test-group-indent-width group)))) @@ -425,7 +535,7 @@ (guard (exn (else - ((current-test-handler) + ((current-test-reporter) (if (assq-ref info 'expect-error) 'PASS 'ERROR) (append `((exception . ,exn)) info)))) (let ((res (expr))) @@ -437,10 +547,10 @@ 'PASS 'FAIL)) (info `((result . ,res) (expected . ,expect-val) ,@info))) - ((current-test-handler) status info))))))) + ((current-test-reporter) status info))))))) (define (test-default-skipper info) - ((current-test-handler) 'SKIP info)) + ((current-test-reporter) 'SKIP info)) (define (test-status-color status) (case status @@ -454,6 +564,8 @@ (define (test-status-code status) ((test-status-color status) + ;; alternatively: ❗, ✗, ‒, ✓ + ;; unfortunately, these have ambiguous width (case status ((ERROR) "!") ((FAIL) "x") @@ -697,100 +809,62 @@ (test-group-inc! parent 'total-fail fail) (test-group-inc! parent 'total-error err)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (test-equal? expect res) - (or (equal? expect res) - (if (real? expect) - (and (inexact? expect) - (real? res) - ;; tests which expect an inexact value can - ;; accept an equivalent exact value - ;; (inexact? res) - (approx-equal? expect res (current-test-epsilon))) - (and (complex? res) - (complex? expect) - (test-equal? (real-part expect) (real-part res)) - (test-equal? (imag-part expect) (imag-part res)))))) - -;;> Begin testing a new group until the closing \scheme{(test-end)}. - -(define (test-begin . o) - (let* ((name (if (pair? o) (car o) "")) - (parent (current-test-group)) - (group (make-test-group name parent))) - ;; include a newline if we are directly nested in a parent with no - ;; tests yet - (cond - ((and parent - (zero? (test-group-ref parent 'subgroups-count 0)) - (not (test-group-ref parent 'verbose))) - (newline))) - ;; header - (cond - ((test-group-ref group 'skip-group?) - (display (make-string (or (test-group-indent-width group) 0) #\space)) - (display (strikethrough (bold (string-append name ":")))) - (display " SKIP")) - ((test-group-ref group 'verbose) - (display - (test-header-line - (string-append "testing " name) - (or (test-group-indent-width group) 0)))) - (else - (display - (string-append - (make-string (or (test-group-indent-width group) 0) - #\space) - (bold (string-append name ": ")))))) - ;; set the current test group - (current-test-group group))) - -;;> Ends testing group introduced with \scheme{(test-begin)}, and -;;> summarizes the results. - -(define (test-end . o) - (cond - ((current-test-group) - => (lambda (group) - (if (and (pair? o) (not (equal? (car o) (test-group-name group)))) - (warning "mismatched test-end:" (car o) (test-group-name group))) - (let ((parent (test-group-ref group 'parent))) - (if (and (test-group-ref group 'skip-group?) - (zero? (test-group-ref group 'subgroups-count 0))) - (newline)) - ;; only report if there's something to say - ((current-test-group-reporter) group) - (cond - (parent - (test-group-inc! parent 'subgroups-count) - (cond - ((test-group-ref group 'skip-group?) - (test-group-inc! parent 'subgroups-skip)) - ((and (zero? (test-group-ref group 'FAIL 0)) - (zero? (test-group-ref group 'ERROR 0)) - (= (test-group-ref group 'subgroups-pass 0) - (test-group-ref group 'subgroups-count 0))) - (test-group-inc! parent 'subgroups-pass))))) - (current-test-group parent) - group))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; parameters +;;> \section{Parameters} + +;;> The current test group as started by \scheme{test-group} or +;;> \scheme{test-begin}. + (define current-test-group (make-parameter #f)) + +;;> If true, show more verbose output per test. Inferred from the +;;> environment variable TEST_VERBOSE. + (define current-test-verbosity (make-parameter (cond ((get-environment-variable "TEST_VERBOSE") => (lambda (s) (not (member s '("" "0"))))) (else #f)))) + +;;> The epsilon used for floating point comparisons. + (define current-test-epsilon (make-parameter 1e-5)) + +;;> The underlying comparator used in testing, defaults to +;;> \scheme{test-equal?}. + (define current-test-comparator (make-parameter test-equal?)) + +;;> The test applier - what we do with non-skipped tests. Takes the +;;> same signature as \scheme{test-run}, should be responsible for +;;> evaluating the thunks, determining the status of the test, and +;;> passing this information to \scheme{current-test-reporter}. + (define current-test-applier (make-parameter test-default-applier)) -(define current-test-handler (make-parameter test-default-handler)) + +;;> The test skipper - what we do with non-skipped tests. This should +;;> not evaluate the thunks and simply pass off to +;;> \scheme{current-test-reporter}. + (define current-test-skipper (make-parameter test-default-skipper)) + +;;> Takes two arguments, the symbol status of the test and the info +;;> alist. Reports the result of the test and updates bookkeeping in +;;> the current test group for reporting. + +(define current-test-reporter (make-parameter test-default-handler)) + +;;> Takes one argument, a test group, and prints a summary of the test +;;> results for that group. + (define current-test-group-reporter (make-parameter test-default-group-reporter)) + +;;> A running count of all test failures and errors across all groups +;;> (and threads). Used by \scheme{test-exit}. + (define test-failure-count (make-parameter 0)) (define test-first-indentation diff --git a/lib/chibi/test.sld b/lib/chibi/test.sld index c242d044..3fed853a 100644 --- a/lib/chibi/test.sld +++ b/lib/chibi/test.sld @@ -5,13 +5,13 @@ test test-equal test-error test-assert test-not test-values test-group current-test-group test-begin test-end test-syntax-error test-propagate-info - test-vars test-run test-exit + test-run test-exit test-equal? ;; test and group data test-get-name! test-group-name test-group-ref test-group-set! test-group-inc! test-group-push! ;; parameters current-test-verbosity - current-test-applier current-test-handler current-test-skipper + current-test-applier current-test-skipper current-test-reporter current-test-group-reporter test-failure-count current-test-epsilon current-test-comparator current-test-filters current-test-removers diff --git a/lib/chibi/trace.scm b/lib/chibi/trace.scm index 6b0c30ff..d07e7a1b 100644 --- a/lib/chibi/trace.scm +++ b/lib/chibi/trace.scm @@ -34,11 +34,16 @@ (show-trace-result cell args res) res)))) +;;> Write a trace of all calls to the procedure \var{proc} to +;;> \scheme{(current-error-port)}. + (define-syntax trace (syntax-rules () ((trace id) (trace-cell (env-cell (interaction-environment) 'id))))) +;;> Remove any active traces on the procedure \var{proc}. + (define-syntax untrace (syntax-rules () ((untrace id) @@ -50,6 +55,8 @@ (for-each (lambda (x) (display x out)) args) (newline out))) +;;> Trace a specific environment cell. + (define (trace-cell cell) (let ((tab (all-traces))) (cond @@ -61,6 +68,8 @@ (hash-table-set! tab cell (cdr cell)) (set-cdr! cell (make-tracer cell)))))) +;;> Untrace an environment cell. + (define (untrace-cell cell) (let ((tab (all-traces))) (cond @@ -73,6 +82,8 @@ (hash-table-delete! tab cell) (set-cdr! cell proc)))))) +;;> Remove all active procedure traces. + (define (untrace-all) (hash-table-walk (all-traces) (lambda (cell proc) (set-cdr! cell proc))) (all-traces (make-hash-table eq?))) diff --git a/lib/chibi/trace.sld b/lib/chibi/trace.sld index ecb32a7d..8cf3e610 100644 --- a/lib/chibi/trace.sld +++ b/lib/chibi/trace.sld @@ -1,17 +1,4 @@ -;;> \subsubsubsection{(trace proc)} - -;;> Write a trace of all calls to the procedure \var{proc} to -;;> \scheme{(current-error-port)}. - -;;> \subsubsubsection{(untrace proc)} - -;;> Remove any active traces on the procedure \var{proc}. - -;;> \subsubsubsection{(untrace-all)} - -;;> Remove all active procedure traces. - (define-library (chibi trace) (export trace untrace untrace-all trace-cell untrace-cell) (import (chibi) (chibi ast) (srfi 38) (srfi 39) (srfi 69)) diff --git a/lib/chibi/weak.sld b/lib/chibi/weak.sld index ecac71bb..39329d7b 100644 --- a/lib/chibi/weak.sld +++ b/lib/chibi/weak.sld @@ -1,6 +1,24 @@ ;;> Library for weak data structures. +;;> \procedure{(make-ephemeron key value)} + +;;> Returns a new ephemeron. This ephemeron holds a weak reference to +;;> \var{key}, such that \var{value} will only be traced by the GC if +;;> \var{key} is referenced from an external object. + +;;> \procedure{(ephemeron? x)} +;;> Returns true iff \var{x} is an ephemeron. + +;;> \procedure{(ephemeron-broken? ephemeron)} +;;> Returns true iff \var{ephemeron}s \var{key} has been GCed. + +;;> \procedure{(ephemeron-key ephemeron)} +;;> Returns \var{ephemeron}s \var{key}, or \scheme{#f} if it has been GCed. + +;;> \procedure{(ephemeron-value ephemeron)} +;;> Returns \var{ephemeron}s \var{value}. + (define-library (chibi weak) (export make-ephemeron ephemeron? ephemeron-broken? ephemeron-key ephemeron-value