diff --git a/README.md b/README.md index 193badd..8ab48c9 100644 --- a/README.md +++ b/README.md @@ -111,11 +111,10 @@ Functional tests A bunch of high level tests are implemented in the functional-tests directory. These tests are written in Scheme. To run them you'll need to install -chezscheme (http://www.scheme.com/). In addition they make use of the -thunderchez (https://github.com/ovenpasta/thunderchez) library. +chezscheme (http://www.scheme.com/). There is no longer a dependency on +the ThunderChez library. -Make sure the tools that you wish to test are in your PATH, and the thunderchez -directory is in the CHEZSCHEMELIBDIRS environment variable. +Make sure the tools that you wish to test are in your PATH. Then, diff --git a/functional-tests/fmt/README b/functional-tests/fmt/README new file mode 100644 index 0000000..159df2d --- /dev/null +++ b/functional-tests/fmt/README @@ -0,0 +1,14 @@ + + fmt + --- + + Combinator Formatting Library + + http://synthcode.com/scheme/fmt/ + + +This directory contains a portable combinator-based formatting library +for Scheme. It has been tested on Chicken, Gauche, MzScheme 3.x and +Scheme48. + +Documentation is in the file fmt.html. diff --git a/functional-tests/fmt/VERSION b/functional-tests/fmt/VERSION new file mode 100644 index 0000000..b60d719 --- /dev/null +++ b/functional-tests/fmt/VERSION @@ -0,0 +1 @@ +0.8.4 diff --git a/functional-tests/fmt/c.sls b/functional-tests/fmt/c.sls new file mode 100644 index 0000000..95ceca9 --- /dev/null +++ b/functional-tests/fmt/c.sls @@ -0,0 +1,42 @@ +;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code +;; +;; Copyright (c) 2007 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +#!r6rs +(library + (fmt c) + (export + fmt-in-macro? fmt-expression? fmt-return? fmt-default-type + fmt-newline-before-brace? fmt-braceless-bodies? + fmt-indent-space fmt-switch-indent-space fmt-op fmt-gen + c-in-expr c-in-stmt c-in-test + c-paren c-maybe-paren c-type c-literal? c-literal char->c-char + c-struct c-union c-class c-enum c-typedef c-cast + c-expr c-expr/sexp c-apply c-op c-indent c-current-indent-string + c-wrap-stmt c-open-brace c-close-brace + c-block c-braced-block c-begin + c-fun c-var c-prototype c-param c-param-list + c-while c-for c-if c-switch + c-case c-case/fallthrough c-default + c-break c-continue c-return c-goto c-label + c-static c-const c-extern c-volatile c-auto c-restrict c-inline + c++ c-- c+ c- c* c/ c% c& c^ c~ c! c&& c<< c>> c== c!= ; |c\|| |c\|\|| + c< c> c<= c>= c= c+= c-= c*= c/= c%= c&= c^= c<<= c>>= ;++c --c ; |c\|=| + c++/post c--/post c. c-> + c-bit-or c-or c-bit-or= + cpp-if cpp-ifdef cpp-ifndef cpp-elif cpp-endif cpp-else cpp-undef + cpp-include cpp-define cpp-wrap-header cpp-pragma cpp-line + cpp-error cpp-warning cpp-stringify cpp-sym-cat + c-comment c-block-comment c-attribute + ) + + (import (chezscheme) + (fmt fmt) + (srfi private include) + (only (srfi s1 lists) every) + (only (srfi s13 strings) substring/shared string-index string-index-right)) + + (include/resolve ("fmt") "fmt-c.scm") + + ) diff --git a/functional-tests/fmt/fmt-c.scm b/functional-tests/fmt/fmt-c.scm new file mode 100644 index 0000000..723bbaa --- /dev/null +++ b/functional-tests/fmt/fmt-c.scm @@ -0,0 +1,874 @@ +;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code +;; +;; Copyright (c) 2007 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; additional state information + +(define (fmt-in-macro? st) (fmt-ref st 'in-macro?)) +(define (fmt-expression? st) (fmt-ref st 'expression?)) +(define (fmt-return? st) (fmt-ref st 'return?)) +(define (fmt-default-type st) (fmt-ref st 'default-type 'int)) +(define (fmt-newline-before-brace? st) (fmt-ref st 'newline-before-brace?)) +(define (fmt-braceless-bodies? st) (fmt-ref st 'braceless-bodies?)) +(define (fmt-non-spaced-ops? st) (fmt-ref st 'non-spaced-ops?)) +(define (fmt-no-wrap? st) (fmt-ref st 'no-wrap?)) +(define (fmt-indent-space st) (fmt-ref st 'indent-space)) +(define (fmt-switch-indent-space st) (fmt-ref st 'switch-indent-space)) +(define (fmt-op st) (fmt-ref st 'op 'stmt)) +(define (fmt-gen st) (fmt-ref st 'gen)) + +(define (c-in-expr proc) (fmt-let 'expression? #t proc)) +(define (c-in-stmt proc) (fmt-let 'expression? #f proc)) +(define (c-in-test proc) (fmt-let 'in-cond? #t (c-in-expr proc))) +(define (c-with-op op proc) (fmt-let 'op op proc)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; be smart about operator precedence + +(define (c-op-precedence x) + (if (string? x) + (cond + ((or (string=? x ".") (string=? x "->")) 10) + ((or (string=? x "++") (string=? x "--")) 20) + ((string=? x "|") 65) + ((string=? x "||") 75) + ((string=? x "|=") 85) + ((or (string=? x "+=") (string=? x "-=")) 85) + (else 95)) + (case x + ;;((|::|) 5) ; C++ + ((paren bracket) 5) + ((dot arrow post-decrement post-increment) 10) + ((**) 15) ; Perl + ((unary+ unary- ! ~ cast unary-* unary-& sizeof) 20) ; ++ -- + ((=~ !~) 25) ; Perl + ((* / %) 30) + ((+ -) 35) + ((<< >>) 40) + ((< > <= >=) 45) + ((lt gt le ge) 45) ; Perl + ((== !=) 50) + ((eq ne cmp) 50) ; Perl + ((&) 55) + ((^) 60) + ;;((|\||) 65) + ((&&) 70) + ;;((|\|\||) 75) + ;;((.. ...) 77) ; Perl + ((?) 80) + ((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ; += -= + ((comma) 90) + ((=>) 90) ; Perl + ((not) 92) ; Perl + ((and) 93) ; Perl + ((or xor) 94) ; Perl + (else 95)))) + +(define (c-op< x y) (< (c-op-precedence x) (c-op-precedence y))) + +(define (c-paren x) (cat "(" x ")")) + +(define (c-maybe-paren op x) + (lambda (st) + ((fmt-let 'op op + (if (or (fmt-in-macro? st) (c-op< (fmt-op st) op)) + (c-paren x) + x)) + st))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; default literals writer + +(define (c-control-operator? x) + (memq x '(if while switch repeat do for fun begin))) + +(define (c-literal? x) + (or (number? x) (string? x) (char? x) (boolean? x))) + +(define (char->c-char c) + (string-append "'" (c-escape-char c #\') "'")) + +(define (c-escape-char c quote-char) + (let ((n (char->integer c))) + (if (<= 32 n 126) + (if (or (eqv? c quote-char) (eqv? c #\\)) + (string #\\ c) + (string c)) + (case n + ((7) "\\a") ((8) "\\b") ((9) "\\t") ((10) "\\n") + ((11) "\\v") ((12) "\\f") ((13) "\\r") + (else (string-append "\\x" (number->string (char->integer c) 16))))))) + +(define (c-format-number x) + (if (and (integer? x) (exact? x)) + (lambda (st) + ((case (fmt-radix st) + ((16) (cat "0x" (string-upcase (number->string x 16)))) + ((8) (cat "0" (number->string x 8))) + (else (dsp (number->string x)))) + st)) + (dsp (number->string x)))) + +(define (c-format-string x) + (lambda (st) ((cat #\" (apply-cat (c-string-escaped x)) #\") st))) + +(define (c-string-escaped x) + (let loop ((parts '()) (idx (string-length x))) + (cond ((string-index-right x c-needs-string-escape? 0 idx) + => (lambda (special-idx) + (loop (cons (c-escape-char (string-ref x special-idx) #\") + (cons (substring/shared x (+ special-idx 1) idx) + parts)) + special-idx))) + (else + (cons (substring/shared x 0 idx) parts))))) + +(define (c-needs-string-escape? c) + (if (<= 32 (char->integer c) 127) (memv c '(#\" #\\)) #t)) + +(define (c-simple-literal x) + (c-wrap-stmt + (cond ((char? x) (dsp (char->c-char x))) + ((boolean? x) (dsp (if x "1" "0"))) + ((number? x) (c-format-number x)) + ((string? x) (c-format-string x)) + ((null? x) (dsp "NULL")) + ((eof-object? x) (dsp "EOF")) + (else (dsp (write-to-string x)))))) + +(define (c-literal x) + (lambda (st) + ((if (and (fmt-in-macro? st) (c-op< 'paren (fmt-op st)) + (not (c-literal? x))) + (c-paren (c-simple-literal x)) + (c-simple-literal x)) + st))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; default expression generator + +(define (c-expr/sexp x) + (if (procedure? x) + x + (lambda (st) + (cond + ((pair? x) + (case (car x) + ((if) ((apply c-if (cdr x)) st)) + ((for) ((apply c-for (cdr x)) st)) + ((while) ((apply c-while (cdr x)) st)) + ((switch) ((apply c-switch (cdr x)) st)) + ((case) ((apply c-case (cdr x)) st)) + ((case/fallthrough) ((apply c-case/fallthrough (cdr x)) st)) + ((default) ((apply c-default (cdr x)) st)) + ((break) (c-break st)) + ((continue) (c-continue st)) + ((return) ((apply c-return (cdr x)) st)) + ((goto) ((apply c-goto (cdr x)) st)) + ((typedef) ((apply c-typedef (cdr x)) st)) + ((struct union class) ((apply c-struct/aux x) st)) + ((enum) ((apply c-enum (cdr x)) st)) + ((inline auto restrict register volatile extern static) + ((cat (car x) " " (apply-cat (cdr x))) st)) + ;; non C-keywords must have some character invalid in a C + ;; identifier to avoid conflicts - by default we prefix % + ((vector-ref) + ((c-wrap-stmt + (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]")) + st)) + ((vector-set!) + ((c= (c-in-expr + (cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]")) + (c-expr (cadddr x))) + st)) + ((extern/C) ((apply c-extern/C (cdr x)) st)) + ((%apply) ((apply c-apply (cdr x)) st)) + ((%define) ((apply cpp-define (cdr x)) st)) + ((%include) ((apply cpp-include (cdr x)) st)) + ((%fun) ((apply c-fun (cdr x)) st)) + ((%cond) + (let lp ((ls (cdr x)) (res '())) + (if (null? ls) + ((apply c-if (reverse res)) st) + (lp (cdr ls) + (cons (if (pair? (cddar ls)) + (apply c-begin (cdar ls)) + (cadar ls)) + (cons (caar ls) res)))))) + ((%prototype) ((apply c-prototype (cdr x)) st)) + ((%var) ((apply c-var (cdr x)) st)) + ((%begin) ((apply c-begin (cdr x)) st)) + ((%attribute) ((apply c-attribute (cdr x)) st)) + ((%line) ((apply cpp-line (cdr x)) st)) + ((%pragma %error %warning) + ((apply cpp-generic (substring/shared (symbol->string (car x)) 1) + (cdr x)) st)) + ((%if %ifdef %ifndef %elif) + ((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1) + (cdr x)) st)) + ((%endif) ((apply cpp-endif (cdr x)) st)) + ((%block) ((apply c-braced-block (cdr x)) st)) + ((%comment) ((apply c-comment (cdr x)) st)) + ((:) ((apply c-label (cdr x)) st)) + ((%cast) ((apply c-cast (cdr x)) st)) + ((+ - & * / % ! ~ ^ && < > <= >= == != << >> + = *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=| + ((apply c-op x) st)) + ((bitwise-and bit-and) ((apply c-op '& (cdr x)) st)) + ((bitwise-ior bit-or) ((apply c-op "|" (cdr x)) st)) + ((bitwise-xor bit-xor) ((apply c-op '^ (cdr x)) st)) + ((bitwise-not bit-not) ((apply c-op '~ (cdr x)) st)) + ((arithmetic-shift) ((apply c-op '<< (cdr x)) st)) + ((bitwise-ior= bit-or=) ((apply c-op "|=" (cdr x)) st)) + ((%or) ((apply c-op "||" (cdr x)) st)) + ((%. %field) ((apply c-op "." (cdr x)) st)) + ((%->) ((apply c-op "->" (cdr x)) st)) + (else + (cond + ((eq? (car x) (string->symbol ".")) + ((apply c-op "." (cdr x)) st)) + ((eq? (car x) (string->symbol "->")) + ((apply c-op "->" (cdr x)) st)) + ((eq? (car x) (string->symbol "++")) + ((apply c-op "++" (cdr x)) st)) + ((eq? (car x) (string->symbol "--")) + ((apply c-op "--" (cdr x)) st)) + ((eq? (car x) (string->symbol "+=")) + ((apply c-op "+=" (cdr x)) st)) + ((eq? (car x) (string->symbol "-=")) + ((apply c-op "-=" (cdr x)) st)) + (else ((c-apply x) st)))))) + ((vector? x) + ((c-wrap-stmt + (fmt-try-fit + (fmt-let 'no-wrap? #t + (cat "{" (fmt-join c-expr (vector->list x) ", ") "}")) + (lambda (st) + (let* ((col (fmt-col st)) + (sep (string-append "," (make-nl-space col)))) + ((cat "{" (fmt-join c-expr (vector->list x) sep) + "}" nl) + st))))) + st)) + (else + ((c-literal x) st)))))) + +(define (c-apply ls) + (c-wrap-stmt + (c-with-op + 'paren + (cat (c-expr (car ls)) + (let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", ")))) + (fmt-if + fmt-no-wrap? + (c-paren flat) + (c-paren + (fmt-try-fit + flat + (lambda (st) + (let* ((col (fmt-col st)) + (sep (string-append "," (make-nl-space col)))) + ((fmt-join c-expr (cdr ls) sep) st))))))))))) + +(define (c-expr x) + (lambda (st) (((or (fmt-gen st) c-expr/sexp) x) st))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; comments, with Emacs-friendly escaping of nested comments + +(define (make-comment-writer st) + (let ((output (fmt-ref st 'writer))) + (lambda (str st) + (let ((lim (- (string-length str) 1))) + (let lp ((i 0) (st st)) + (let ((j (string-index str #\/ i))) + (if j + (let ((st (if (and (> j 0) + (eqv? #\* (string-ref str (- j 1)))) + (output + "\\/" + (output (substring/shared str i j) st)) + (output (substring/shared str i (+ j 1)) st)))) + (lp (+ j 1) + (if (and (< j lim) (eqv? #\* (string-ref str (+ j 1)))) + (output "\\" st) + st))) + (output (substring/shared str i) st)))))))) + +(define (c-comment . args) + (lambda (st) + ((cat "/*" (fmt-let 'writer (make-comment-writer st) + (apply-cat args)) + "*/") + st))) + +(define (make-block-comment-writer st) + (let ((output (make-comment-writer st)) + (indent (string-append (make-nl-space (+ (fmt-col st) 1)) "* "))) + (lambda (str st) + (let ((lim (string-length str))) + (let lp ((i 0) (st st)) + (let ((j (string-index str #\newline i))) + (if j + (lp (+ j 1) + (output indent (output (substring/shared str i j) st))) + (output (substring/shared str i) st)))))))) + +(define (c-block-comment . args) + (lambda (st) + (let ((col (fmt-col st)) + (row (fmt-row st)) + (indent (c-current-indent-string st))) + ((cat "/* " + (fmt-let 'writer (make-block-comment-writer st) (apply-cat args)) + (lambda (st) + (cond + ((= row (fmt-row st)) ((dsp " */") st)) + ;;((= (+ 3 col) (fmt-col st)) ((dsp "*/") st)) + (else ((cat fl indent " */") st))))) + st)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; preprocessor + +(define (make-cpp-writer st) + (let ((output (fmt-ref st 'writer))) + (lambda (str st) + (let lp ((i 0) (st st)) + (let ((j (string-index str #\newline i))) + (if j + (lp (+ j 1) + (output + nl-str + (output " \\" (output (substring/shared str i j) st)))) + (output (substring/shared str i) st))))))) + +(define (cpp-include file) + (if (string? file) + (cat fl "#include " (wrt file) fl) + (cat fl "#include <" file ">" fl))) + +(define (list-dot x) + (cond ((pair? x) (list-dot (cdr x))) + ((null? x) #f) + (else x))) + +(define (replace-tree from to x) + (let replace ((x x)) + (cond ((eq? x from) to) + ((pair? x) (cons (replace (car x)) (replace (cdr x)))) + (else x)))) + +(define (cpp-define x . body) + (define (name-of x) (c-expr (if (pair? x) (cadr x) x))) + (lambda (st) + (let* ((body (cond + ((and (pair? x) (list-dot x)) + => (lambda (dot) + (if (eq? dot '...) + body + (replace-tree dot '__VA_ARGS__ body)))) + (else body))) + (tail + (if (pair? body) + (cat " " + (fmt-let 'writer (make-cpp-writer st) + (fmt-let 'in-macro? (pair? x) + ((if (or (not (pair? x)) + (and (null? (cdr body)) + (c-literal? (car body)))) + (lambda (x) x) + c-paren) + (c-in-expr (apply c-begin body)))))) + (lambda (x) x)))) + ((c-in-expr + (if (pair? x) + (cat fl "#define " (name-of (car x)) + (c-paren + (fmt-join/dot name-of + (lambda (dot) (dsp "...")) + (cdr x) + ", ")) + tail fl) + (cat fl "#define " (c-expr x) tail fl))) + st)))) + +(define (cpp-expr x) + (if (or (symbol? x) (string? x)) (dsp x) (c-expr x))) + +(define (cpp-if/aux name check . o) + (let* ((pass (and (pair? o) (car o))) + (comment (if (member name '("ifdef" "ifndef")) + (cat " " + (c-comment + " " (if (equal? name "ifndef") "! " "") + check " ")) + "")) + (endif (if pass (cat fl "#endif" comment) "")) + (tail (cond + ((and (pair? o) (pair? (cdr o))) + (if (pair? (cddr o)) + (apply cpp-elif (cdr o)) + (cat (cpp-else) (cadr o) endif))) + (else endif)))) + (lambda (st) + (let ((indent (c-current-indent-string st))) + ((cat fl "#" name " " (cpp-expr check) fl + (if pass (cat indent pass) "") fl + tail fl) + st))))) + +(define (cpp-if check . o) + (apply cpp-if/aux "if" check o)) +(define (cpp-ifdef check . o) + (apply cpp-if/aux "ifdef" check o)) +(define (cpp-ifndef check . o) + (apply cpp-if/aux "ifndef" check o)) +(define (cpp-elif check . o) + (apply cpp-if/aux "elif" check o)) +(define (cpp-else . o) + (cat fl "#else " (if (pair? o) (c-comment (car o)) "") fl)) +(define (cpp-endif . o) + (cat fl "#endif " (if (pair? o) (c-comment (car o)) "") fl)) + +(define (cpp-wrap-header name . body) + (let ((name name)) ; consider auto-mangling + (cpp-ifndef name (c-begin (cpp-define name) nl (apply c-begin body) nl)))) + +(define (cpp-line num . o) + (cat fl "#line " num (if (pair? o) (cat " " (car o)) "") fl)) + +(define (cpp-generic name . ls) + (cat fl "#" name (apply-cat ls) fl)) + +(define (cpp-undef . args) (apply cpp-generic "undef" args)) +(define (cpp-pragma . args) (apply cpp-generic "pragma" args)) +(define (cpp-error . args) (apply cpp-generic "error" args)) +(define (cpp-warning . args) (apply cpp-generic "warning" args)) + +(define (cpp-stringify x) + (cat "#" x)) + +(define (cpp-sym-cat . args) + (fmt-join dsp args " ## ")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; general indentation and brace rules + +(define (c-current-indent-string st . o) + (make-space (max 0 (+ (fmt-col st) (if (pair? o) (car o) 0))))) + +(define (c-indent st . o) + (dsp (make-space (max 0 (+ (fmt-col st) (or (fmt-indent-space st) 4) + (if (pair? o) (car o) 0)))))) + +(define (c-indent/switch st) + (dsp (make-space (+ (fmt-col st) (or (fmt-switch-indent-space st) 4))))) + +(define (c-open-brace st) + (if (fmt-newline-before-brace? st) + (cat nl (c-current-indent-string st) "{" nl) + (cat " {" nl))) + +(define (c-close-brace st) + (dsp "}")) + +(define (c-wrap-stmt x) + (fmt-if fmt-expression? + (c-expr x) + (cat (fmt-if fmt-return? "return " "") + (c-in-expr (c-expr x)) ";" nl))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; code blocks + +(define (c-block . args) + (apply c-block/aux 0 args)) + +(define (c-block/aux offset header body0 . body) + (let ((inner (apply c-begin body0 body))) + (if (or (pair? body) + (not (or (c-literal? body0) + (and (pair? body0) + (not (c-control-operator? (car body0))))))) + (c-braced-block/aux offset header inner) + (lambda (st) + (if (fmt-braceless-bodies? st) + ((cat header fl (c-indent st offset) inner fl) st) + ((c-braced-block/aux offset header inner) st)))))) + +(define (c-braced-block . args) + (apply c-braced-block/aux 0 args)) + +(define (c-braced-block/aux offset header . body) + (lambda (st) + ((cat header (c-open-brace st) (c-indent st offset) + (apply c-begin body) fl + (c-current-indent-string st offset) (c-close-brace st)) + st))) + +(define (c-begin . args) + (apply c-begin/aux #f args)) + +(define (c-begin/aux ret? body0 . body) + (if (null? body) + (c-expr body0) + (lambda (st) + (if (fmt-expression? st) + ((fmt-try-fit + (fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", ")) + (lambda (st) + (let ((indent (c-current-indent-string st))) + ((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st)))) + st) + (let ((orig-ret? (fmt-return? st))) + ((fmt-join/last c-expr + (lambda (x) (fmt-let 'return? orig-ret? (c-expr x))) + (cons body0 body) + (cat fl (c-current-indent-string st))) + (fmt-set! st 'return? (and ret? orig-ret?)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; data structures + +(define (c-struct/aux type x . o) + (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x)) + (body (if name (car o) x)) + (o (if (null? o) o (cdr o)))) + (c-wrap-stmt + (cat + (c-braced-block + (cat type (if (and name (not (equal? name ""))) (cat " " name) "")) + (cat + (c-in-stmt + (if (list? body) + (apply c-begin (map c-wrap-stmt (map c-param body))) + (c-wrap-stmt (c-expr body)))))) + (if (pair? o) (cat " " (apply c-begin o)) (dsp "")))))) + +(define (c-struct . args) (apply c-struct/aux "struct" args)) +(define (c-union . args) (apply c-struct/aux "union" args)) +(define (c-class . args) (apply c-struct/aux "class" args)) + +(define (c-enum x . o) + (define (c-enum-one x) + (if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x))) + (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x)) + (vals (if name (car o) x))) + (c-wrap-stmt + (cat + (c-braced-block + (if name (cat "enum " name) (dsp "enum")) + (c-in-expr (apply c-begin (map c-enum-one vals)))))))) + +(define (c-attribute . args) + (cat "__attribute__ ((" (fmt-join c-expr args ", ") "))")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; basic control structures + +(define (c-while check . body) + (cat (c-block (cat "while (" (c-in-test (c-expr check)) ")") + (c-in-stmt (apply c-begin body))) + fl)) + +(define (c-for init check update . body) + (cat + (c-block + (c-in-expr + (cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; " + (c-expr update ) ")")) + (c-in-stmt (apply c-begin body))) + fl)) + +(define (c-param x) + (cond + ((procedure? x) x) + ((pair? x) (c-type (car x) (cadr x))) + (else (cat (lambda (st) ((c-type (fmt-default-type st)) st)) " " x)))) + +(define (c-param-list ls) + (c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", "))) + +(define (c-fun type name params . body) + (cat (c-block (c-in-expr (c-prototype type name params)) + (fmt-let 'return? (not (eq? 'void type)) + (c-in-stmt (apply c-begin body)))) + fl)) + +(define (c-prototype type name params . o) + (c-wrap-stmt + (cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")" + (fmt-join/prefix c-expr o " ")))) + +(define (c-static x) (cat "static " (c-expr x))) +(define (c-const x) (cat "const " (c-expr x))) +(define (c-restrict x) (cat "restrict " (c-expr x))) +(define (c-volatile x) (cat "volatile " (c-expr x))) +(define (c-auto x) (cat "auto " (c-expr x))) +(define (c-inline x) (cat "inline " (c-expr x))) +(define (c-extern x) (cat "extern " (c-expr x))) +(define (c-extern/C . body) + (cat "extern \"C\" {" nl (apply c-begin body) nl "}" nl)) + +(define (c-type type . o) + (let ((name (and (pair? o) (car o)))) + (cond + ((pair? type) + (case (car type) + ((%fun) + (cat (c-type (cadr type) #f) + " (*" (or name "") ")(" + (fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")")) + ((%array) + (let ((name (cat name "[" (if (pair? (cddr type)) + (c-expr (caddr type)) + "") + "]"))) + (c-type (cadr type) name))) + ((%pointer *) + (let ((name (cat "*" (if name (c-expr name) "")))) + (c-type (cadr type) + (if (and (pair? (cadr type)) (eq? '%array (caadr type))) + (c-paren name) + name)))) + ((enum) (apply c-enum name (cdr type))) + ((struct union class) + (cat (apply c-struct/aux (car type) (cdr type)) " " name)) + (else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " ")))) + ((not type) + (lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st))) + (else + (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) "")))))) + +(define (c-var type name . init) + (c-wrap-stmt + (if (pair? init) + (cat (c-type type name) " = " (c-expr (car init))) + (c-type type (if (pair? name) + (fmt-join c-expr name ", ") + (c-expr name)))))) + +(define (c-cast type expr) + (cat "(" (c-type type) ")" (c-expr expr))) + +(define (c-typedef type alias . o) + (c-wrap-stmt + (cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " ")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Generalized IF: allows multiple tail forms for if/else if/.../else +;; blocks. A final ELSE can be signified with a test of #t or 'else, +;; or by simply using an odd number of expressions (by which the +;; normal 2 or 3 clause IF forms are special cases). + +(define (c-if/stmt c p . rest) + (lambda (st) + (let ((indent (c-current-indent-string st))) + ((let lp ((c c) (p p) (ls rest)) + (if (or (eq? c 'else) (eq? c #t)) + (if (not (null? ls)) + (error "forms after else clause in IF" c p ls) + (cat (c-block/aux -1 " else" p) fl)) + (let ((tail (if (pair? ls) + (if (pair? (cdr ls)) + (lp (car ls) (cadr ls) (cddr ls)) + (lp 'else (car ls) '())) + fl))) + (cat (c-block/aux + (if (eq? ls rest) 0 -1) + (cat (if (eq? ls rest) (lambda (x) x) " else ") + "if (" (c-in-test (c-expr c)) ")") p) + tail)))) + st)))) + +(define (c-if/expr c p . rest) + (let lp ((c c) (p p) (ls rest)) + (cond + ((or (eq? c 'else) (eq? c #t)) + (if (not (null? ls)) + (error "forms after else clause in IF" c p ls) + (c-expr p))) + ((pair? ls) + (cat (c-in-test (c-expr c)) " ? " (c-expr p) " : " + (if (pair? (cdr ls)) + (lp (car ls) (cadr ls) (cddr ls)) + (lp 'else (car ls) '())))) + (else + (c-or (c-in-test (c-expr c)) (c-expr p)))))) + +(define (c-if . args) + (fmt-if fmt-expression? + (apply c-if/expr args) + (apply c-if/stmt args))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; switch statements, automatic break handling + +(define (c-label name) + (lambda (st) + (let ((indent (make-space (max 0 (- (fmt-col st) 2))))) + ((cat fl indent name ":" fl) st)))) + +(define c-break + (c-wrap-stmt (dsp "break"))) +(define c-continue + (c-wrap-stmt (dsp "continue"))) +(define (c-return . result) + (if (pair? result) + (c-wrap-stmt (cat "return " (c-expr (car result)))) + (c-wrap-stmt (dsp "return")))) +(define (c-goto label) + (c-wrap-stmt (cat "goto " (c-expr label)))) + +(define (c-switch val . clauses) + (lambda (st) + ((cat "switch (" (c-in-expr val) ")" (c-open-brace st) + (c-indent/switch st) + (c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl + (c-current-indent-string st) (c-close-brace st) fl) + st))) + +(define (c-switch-clause/breaks x) + (lambda (st) + (let* ((break? + (and (car x) + (not (member (cadr x) '(case/fallthrough + default/fallthrough + else/fallthrough))))) + (explicit-case? (member (cadr x) '(case case/fallthrough))) + (indent (c-current-indent-string st)) + (indent-body (c-indent st)) + (sep (string-append ":" nl-str indent))) + ((cat (c-in-expr + (fmt-join/suffix + dsp + (cond + ((pair? (cadr x)) + (map (lambda (y) (cat (dsp "case ") (c-expr y))) + (cadr x))) + (explicit-case? + (map (lambda (y) (cat (dsp "case ") (c-expr y))) + (if (list? (caddr x)) + (caddr x) + (list (caddr x))))) + ((member (cadr x) + '(default else default/fallthrough else/fallthrough)) + (list (dsp "default"))) + (else + (error + "unknown switch clause, expected a list or default but got" + (cadr x)))) + sep)) + (make-space (or (fmt-indent-space st) 4)) + (fmt-join c-expr + (if explicit-case? (cdddr x) (cddr x)) + indent-body) + (if (and break? (not (fmt-return? st))) + (cat fl indent-body c-break) + "")) + st)))) + +(define (c-switch-clause x) + (if (procedure? x) x (c-switch-clause/breaks (cons #t x)))) +(define (c-switch-clause/no-break x) + (if (procedure? x) x (c-switch-clause/breaks (cons #f x)))) + +(define (c-case x . body) + (c-switch-clause (cons (if (pair? x) x (list x)) body))) +(define (c-case/fallthrough x . body) + (c-switch-clause/no-break (cons (if (pair? x) x (list x)) body))) +(define (c-default . body) + (c-switch-clause/breaks (cons #t (cons 'else body)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; operators + +(define (c-op op first . rest) + (if (null? rest) + (c-unary-op op first) + (apply c-binary-op op first rest))) + +(define (c-binary-op op . ls) + (define (lit-op? x) (or (c-literal? x) (symbol? x))) + (let ((str (display-to-string op))) + (c-wrap-stmt + (c-maybe-paren + op + (if (or (equal? str ".") (equal? str "->")) + (fmt-join c-expr ls str) + (let ((flat + (fmt-let 'no-wrap? #t + (lambda (st) + ((fmt-join c-expr + ls + (if (and (fmt-non-spaced-ops? st) + (every lit-op? ls)) + str + (string-append " " str " "))) + st))))) + (fmt-if + fmt-no-wrap? + flat + (fmt-try-fit + flat + (lambda (st) + ((fmt-join c-expr + ls + (cat nl (make-space (+ 2 (fmt-col st))) str " ")) + st)))))))))) + +(define (c-unary-op op x) + (c-wrap-stmt + (cat (display-to-string op) (c-maybe-paren op (c-expr x))))) + +;; some convenience definitions + +(define (c++ . args) (apply c-op "++" args)) +(define (c-- . args) (apply c-op "--" args)) +(define (c+ . args) (apply c-op '+ args)) +(define (c- . args) (apply c-op '- args)) +(define (c* . args) (apply c-op '* args)) +(define (c/ . args) (apply c-op '/ args)) +(define (c% . args) (apply c-op '% args)) +(define (c& . args) (apply c-op '& args)) +;; (define (|c\|| . args) (apply c-op '|\|| args)) +(define (c^ . args) (apply c-op '^ args)) +(define (c~ . args) (apply c-op '~ args)) +(define (c! . args) (apply c-op '! args)) +(define (c&& . args) (apply c-op '&& args)) +;; (define (|c\|\|| . args) (apply c-op '|\|\|| args)) +(define (c<< . args) (apply c-op '<< args)) +(define (c>> . args) (apply c-op '>> args)) +(define (c== . args) (apply c-op '== args)) +(define (c!= . args) (apply c-op '!= args)) +(define (c< . args) (apply c-op '< args)) +(define (c> . args) (apply c-op '> args)) +(define (c<= . args) (apply c-op '<= args)) +(define (c>= . args) (apply c-op '>= args)) +(define (c= . args) (apply c-op '= args)) +(define (c+= . args) (apply c-op "+=" args)) +(define (c-= . args) (apply c-op "-=" args)) +(define (c*= . args) (apply c-op '*= args)) +(define (c/= . args) (apply c-op '/= args)) +(define (c%= . args) (apply c-op '%= args)) +(define (c&= . args) (apply c-op '&= args)) +;; (define (|c\|=| . args) (apply c-op '|\|=| args)) +(define (c^= . args) (apply c-op '^= args)) +(define (c<<= . args) (apply c-op '<<= args)) +(define (c>>= . args) (apply c-op '>>= args)) + +(define (c. . args) (apply c-op "." args)) +(define (c-> . args) (apply c-op "->" args)) + +(define (c-bit-or . args) (apply c-op "|" args)) +(define (c-or . args) (apply c-op "||" args)) +(define (c-bit-or= . args) (apply c-op "|=" args)) + +(define (c++/post x) + (cat (c-maybe-paren 'post-increment (c-expr x)) "++")) +(define (c--/post x) + (cat (c-maybe-paren 'post-decrement (c-expr x)) "--")) + diff --git a/functional-tests/fmt/fmt-color.scm b/functional-tests/fmt/fmt-color.scm new file mode 100644 index 0000000..57191f1 --- /dev/null +++ b/functional-tests/fmt/fmt-color.scm @@ -0,0 +1,77 @@ +;;;; fmt-color.scm -- colored output +;; +;; Copyright (c) 2006-2007 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define (fmt-color st) (fmt-ref st 'color)) +(define (fmt-in-html? st) (fmt-ref st 'in-html?)) +(define (fmt-use-html-font? st) (fmt-ref st 'use-html-font?)) + +(define (color->ansi x) + (if (number? x) + (let ((r (arithmetic-shift x -16)) + (g (bitwise-and (arithmetic-shift x -8) #xFF)) + (b (bitwise-and x #xFF))) + ;; just picks the highest color value - need to detect blends + (color->ansi + (cond + ((> r g) (if (> r b) 'red 'blue)) + ((> g b) 'green) + (else 'blue)))) + (case x + ((bold) "1") + ((dark) "2") + ((underline) "4") + ((black) "30") + ((red) "31") + ((green) "32") + ((yellow) "33") + ((blue) "34") + ((magenta) "35") + ((cyan) "36") + ((white) "37") + (else "0")))) + +(define (ansi-escape color) + (cat (integer->char 27) "[" (color->ansi color) "m")) + +(define (fmt-in-html . args) + (fmt-let 'in-html? #t (apply-cat args))) + +(define (fmt-colored color . args) + (fmt-if fmt-in-html? + (cond + ((eq? color 'bold) + (cat "" (apply-cat args) "")) + ((eq? color 'underline) + (cat "" (apply-cat args) "")) + (else + (let ((cname (if (number? color) (cat "#" color) color))) + (fmt-if fmt-use-html-font? + (cat "" (apply-cat args) + "") + (cat "" + (apply-cat args) ""))))) + (lambda (st) + (let ((old-color (fmt-color st))) + ((fmt-let 'color color + (cat (ansi-escape color) + (apply-cat args) + (if (or (memv color '(bold underline)) + (memv old-color '(bold underline))) + (ansi-escape 'reset) + (lambda (st) st)) + (ansi-escape old-color))) + st))))) + +(define (fmt-red . args) (fmt-colored 'red (apply-cat args))) +(define (fmt-blue . args) (fmt-colored 'blue (apply-cat args))) +(define (fmt-green . args) (fmt-colored 'green (apply-cat args))) +(define (fmt-cyan . args) (fmt-colored 'cyan (apply-cat args))) +(define (fmt-yellow . args) (fmt-colored 'yellow (apply-cat args))) +(define (fmt-magenta . args) (fmt-colored 'magenta (apply-cat args))) +(define (fmt-white . args) (fmt-colored 'white (apply-cat args))) +(define (fmt-black . args) (fmt-colored 'black (apply-cat args))) +(define (fmt-bold . args) (fmt-colored 'bold (apply-cat args))) +(define (fmt-underline . args) (fmt-colored 'underline (apply-cat args))) + diff --git a/functional-tests/fmt/fmt-column.scm b/functional-tests/fmt/fmt-column.scm new file mode 100644 index 0000000..9ec4865 --- /dev/null +++ b/functional-tests/fmt/fmt-column.scm @@ -0,0 +1,417 @@ +;;;; fmt-block.scm -- columnar formatting +;; +;; Copyright (c) 2006-2011 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Columnar formatting +;; +;; A line-oriented formatter. Takes a list of +;; (line-fmt1 gen-fmt1 line-fmt2 gen-fmt2 ...) +;; and formats each of the gen-fmt1 formats as columns, printed +;; side-by-side, each line allowing post-processing done by line-fmt1 +;; (just use dsp if you want to display the lines verbatim). + +;; Continuations come to the rescue to make this work properly, +;; letting us weave the output between different columns without +;; needing to build up intermediate strings. + +(define (fmt-columns . ls) + (lambda (orig-st) + (call-with-current-continuation + (lambda (return) + (define (infinite? x) + (and (pair? x) (pair? (cdr x)) (pair? (cddr x)) (caddr x))) + (let ((q1 '()) + (q2 '()) + (remaining (length (remove infinite? ls)))) + (define (enq! proc) (set! q2 (cons proc q2))) + (define (deq!) (let ((proc (car q1))) (set! q1 (cdr q1)) proc)) + (define (line-init!) (set! q1 (reverse q2)) (set! q2 '())) + (define (line-done?) (null? q1)) + (define line-buf '()) + (define line-non-empty? #f) + (define (write-column fmt str finite?) + (set! line-buf (cons (cons fmt str) line-buf)) + (if finite? (set! line-non-empty? #t))) + (define (write-line) + (cond + (line-non-empty? + (for-each + (lambda (x) (set! orig-st (((car x) (cdr x)) orig-st))) + (reverse line-buf)) + (set! orig-st (nl orig-st)))) + (set! line-buf '()) + (set! line-non-empty? #f) + (line-init!)) + (define (next cont) + (enq! cont) + (cond + ((line-done?) + (write-line) + (if (not (positive? remaining)) (finish) ((deq!) #f))) + (else ((deq!) #f)))) + (define (finish) + (write-line) + (return orig-st)) + (define (make-empty-col fmt) + (define (blank *ignored*) + (write-column fmt "" #f) + (next blank)) ; infinite loop, next terminates for us + blank) + (define (make-col st fmt gen finite?) + (let ((acc '())) ; buffer incomplete lines + (lambda (*ignored*) + (define (output* str st) + (let lp ((i 0)) + (let ((nli (string-index str #\newline i))) + (cond + (nli + (let ((line + (string-concatenate-reverse + (cons (substring/shared str i nli) acc)))) + (set! acc '()) + (write-column fmt line finite?) + (call-with-current-continuation next) + (lp (+ nli 1)))) + (else + (set! acc (cons (substring/shared str i) acc)))))) + ;; update - don't output or the string port will fill up + (fmt-update str st)) + ;; gen threads through it's own state, ignore result + (gen (fmt-set-writer! (copy-fmt-state st) output*)) + ;; reduce # of remaining finite columns + (set! remaining (- remaining 1)) + ;; write any remaining accumulated output + (if (pair? acc) + (let ((s (string-concatenate-reverse acc))) + (write-column fmt s (and finite? (not (equal? s "")))))) + ;; (maybe) loop with an empty column in place + (if (not (positive? remaining)) + (finish) + (next (make-empty-col fmt)))))) + ;; queue up the initial formatters + (for-each + (lambda (col) + (let ((st (fmt-set-port! (copy-fmt-state orig-st) + (open-output-string)))) + (enq! (make-col st (car col) (dsp (cadr col)) + (not (infinite? col)))))) + ls) + (line-init!) + ;; start + ((deq!) #f)))))) + +(define (columnar . ls) + (define (proportional-width? w) + (and (number? w) + (or (< 0 w 1) + (and (inexact? w) (= w 1.0))))) + (define (whitespace-pad? st) + (char-whitespace? (or (fmt-pad-char st) #\space))) + (define (build-column ls) + (let-optionals* ls ((fixed-width #f) + (width #f) + (last? #t) + (tail '()) + (gen #f) + (prefix '()) + (align 'left) + (infinite? #f)) + (define (scale-width st) + (max 1 (inexact->exact + (truncate (* width (- (fmt-width st) fixed-width)))))) + (define (padder) + (if (proportional-width? width) + (case align + ((right) + (lambda (str) (lambda (st) ((pad/left (scale-width st) str) st)))) + ((center) + (lambda (str) (lambda (st) ((pad/both (scale-width st) str) st)))) + (else + (lambda (str) (lambda (st) ((pad/right (scale-width st) str) st))))) + (case align + ((right) (lambda (str) (pad/left width str))) + ((center) (lambda (str) (pad/both width str))) + (else (lambda (str) (pad/right width str)))))) + (define (affix x) + (cond + ((pair? tail) + (lambda (str) + (cat (string-concatenate prefix) + (x str) + (string-concatenate tail)))) + ((pair? prefix) + (lambda (str) (cat (string-concatenate prefix) (x str)))) + (else x))) + (list + ;; line formatter + (affix + (let ((pad (padder))) + (if (and last? (not (pair? tail)) (eq? align 'left)) + (lambda (str) + (lambda (st) + (((if (whitespace-pad? st) dsp pad) str) st))) + pad))) + ;; generator + (if (proportional-width? width) + (lambda (st) ((with-width (scale-width st) gen) st)) + (with-width width gen)) + infinite? + ))) + (define (adjust-widths ls border-width) + (let* ((fixed-ls + (filter (lambda (x) (and (number? (car x)) (>= (car x) 1))) ls)) + (fixed-total (fold + border-width (map car fixed-ls))) + (scaled-ls (filter (lambda (x) (proportional-width? (car x))) ls)) + (denom (- (length ls) (+ (length fixed-ls) (length scaled-ls)))) + (rest (if (zero? denom) + 0 + (exact->inexact + (/ (- 1 (fold + 0 (map car scaled-ls))) denom))))) + (if (negative? rest) + (error 'columnar "fractional widths must sum to less than 1" + (map car scaled-ls))) + (map + (lambda (col) + (cons fixed-total + (if (not (number? (car col))) (cons rest (cdr col)) col))) + ls))) + (define (finish ls border-width) + (apply fmt-columns + (map build-column (adjust-widths (reverse ls) border-width)))) + (let lp ((ls ls) (strs '()) (align 'left) (infinite? #f) + (width #t) (border-width 0) (res '())) + (cond + ((null? ls) + (if (pair? strs) + (finish (cons (cons (caar res) + (cons #t (cons (append (reverse strs) + (caddar res)) + (cdddar res)))) + (cdr res)) + border-width) + (finish (cons (cons (caar res) (cons #t (cddar res))) (cdr res)) + border-width))) + ((string? (car ls)) + (if (string-index (car ls) #\newline) + (error 'columnar "column string literals can't contain newlines") + (lp (cdr ls) (cons (car ls) strs) align infinite? + width (+ border-width (string-length (car ls))) res))) + ((number? (car ls)) + (lp (cdr ls) strs align infinite? (car ls) border-width res)) + ((eq? (car ls) 'infinite) + (lp (cdr ls) strs align #t width border-width res)) + ((symbol? (car ls)) + (lp (cdr ls) strs (car ls) infinite? width border-width res)) + ((procedure? (car ls)) + (lp (cdr ls) '() 'left #f #t border-width + (cons (list width #f '() (car ls) (reverse strs) align infinite?) + res))) + (else + (error 'columnar "invalid column" (car ls)))))) + +(define (max-line-width string-width str) + (let lp ((i 0) (hi 0)) + (let ((j (string-index str #\newline i))) + (if j + (lp (+ j 1) (max hi (string-width (substring str i j)))) + (max hi (string-width (substring str i (string-length str)))))))) + +(define (pad-finite st proc width) + (let* ((str ((fmt-to-string proc) (copy-fmt-state st))) + (w (max-line-width (or (fmt-string-width st) string-length) str))) + (list (cat str) + (if (and (integer? width) (exact? width)) + (max width w) + w)))) + +(define (tabular . ls) + (lambda (st) + (let lp ((ls ls) (infinite? #f) (width #t) (res '())) + (cond + ((null? ls) + ((apply columnar (reverse res)) st)) + ((number? (car ls)) + (lp (cdr ls) infinite? (car ls) res)) + ((eq? 'infinite (car ls)) + (lp (cdr ls) #t width (cons (car ls) res))) + ((procedure? (car ls)) + (if infinite? + (if width + (lp (cdr ls) #f #t (cons (car ls) (cons width res))) + (lp (cdr ls) #f #t (cons (car ls) res))) + (let ((gen+width (pad-finite st (car ls) width))) + (lp (cdr ls) #f #t (append gen+width res))))) + (else + (lp (cdr ls) infinite? width (cons (car ls) res))))))) + +;; break lines only, don't fmt-join short lines or justify +(define (fold-lines . ls) + (lambda (st) + (define output (fmt-writer st)) + (define (kons-in-line str st) + (let ((len ((or (fmt-string-width st) string-length) str)) + (space (- (fmt-width st) (fmt-col st)))) + (cond + ((or (<= len space) (not (positive? space))) + (output str st)) + (else + (kons-in-line + (substring/shared str space len) + (output nl-str + (output (substring/shared str 0 space) st))))))) + ((fmt-let + 'writer + (lambda (str st) + (let lp ((str str) (st st)) + (let ((nli (string-index str #\newline))) + (cond + ((not nli) + (kons-in-line str st)) + (else + (lp (substring/shared str (+ nli 1)) + (output nl-str + (kons-in-line + (substring/shared str 0 nli) + st)))))))) + (apply-cat ls)) + st))) + +(define (wrap-fold-words seq knil max-width get-width line . o) + (let* ((last-line (if (pair? o) (car o) line)) + (vec (if (list? seq) (list->vector seq) seq)) + (len (vector-length vec)) + (len-1 (- len 1)) + (breaks (make-vector len #f)) + (penalties (make-vector len #f)) + (widths + (list->vector + (map get-width (if (list? seq) seq (vector->list vec)))))) + (define (largest-fit i) + (let lp ((j (+ i 1)) (width (vector-ref widths i))) + (let ((width (+ width 1 (vector-ref widths j)))) + (cond + ((>= width max-width) (- j 1)) + ((>= j len-1) len-1) + (else (lp (+ j 1) width)))))) + (define (min-penalty! i) + (cond + ((>= i len-1) 0) + ((vector-ref penalties i)) + (else + (vector-set! penalties i (expt (+ max-width 1) 3)) + (vector-set! breaks i i) + (let ((k (largest-fit i))) + (let lp ((j i) (width 0)) + (if (<= j k) + (let* ((width (+ width (vector-ref widths j))) + (break-penalty + (+ (max 0 (expt (- max-width (+ width (- j i))) 3)) + (min-penalty! (+ j 1))))) + (cond + ((< break-penalty (vector-ref penalties i)) + (vector-set! breaks i j) + (vector-set! penalties i break-penalty))) + (lp (+ j 1) width))))) + (if (>= (vector-ref breaks i) len-1) + (vector-set! penalties i 0)) + (vector-ref penalties i)))) + (define (sub-list i j) + (let lp ((i i) (res '())) + (if (> i j) + (reverse res) + (lp (+ i 1) (cons (vector-ref vec i) res))))) + (cond + ((zero? len) + ;; degenerate case + (last-line '() knil)) + (else + ;; compute optimum breaks + (vector-set! breaks len-1 len-1) + (vector-set! penalties len-1 0) + (min-penalty! 0) + ;; fold + (let lp ((i 0) (acc knil)) + (let ((break (vector-ref breaks i))) + (if (>= break len-1) + (last-line (sub-list i len-1) acc) + (lp (+ break 1) (line (sub-list i break) acc))))))))) + +;; XXXX don't split, traverse the string manually and keep track of +;; sentence endings so we can insert two spaces +(define (wrap-fold str . o) + (apply wrap-fold-words (string-tokenize str) o)) + +(define (wrap-lines . ls) + (define (print-line ls st) + (nl ((fmt-join dsp ls " ") st))) + (define buffer '()) + (lambda (st) + ((fmt-let + 'writer + (lambda (str st) (set! buffer (cons str buffer)) st) + (apply-cat ls)) + st) + (wrap-fold (string-concatenate-reverse buffer) + st (fmt-width st) + (or (fmt-string-width st) string-length) + print-line))) + +(define (justify . ls) + (lambda (st) + (let ((width (fmt-width st)) + (string-width (or (fmt-string-width st) string-length)) + (output (fmt-writer st)) + (buffer '())) + (define (justify-line ls st) + (if (null? ls) + (nl st) + (let* ((sum (fold (lambda (s n) (+ n (string-width s))) 0 ls)) + (len (length ls)) + (diff (max 0 (- width sum))) + (sep (make-string (if (= len 1) + 0 + (quotient diff (- len 1))) + #\space)) + (rem (if (= len 1) + diff + (remainder diff (- len 1))))) + (output + (call-with-output-string + (lambda (p) + (display (car ls) p) + (let lp ((ls (cdr ls)) (i 1)) + (cond + ((pair? ls) + (display sep p) + (if (<= i rem) (write-char #\space p)) + (display (car ls) p) + (lp (cdr ls) (+ i 1))))) + (newline p))) + st)))) + (define (justify-last ls st) + (nl ((fmt-join dsp ls " ") st))) + ((fmt-let + 'writer + (lambda (str st) (set! buffer (cons str buffer)) st) + (apply-cat ls)) + st) + (wrap-fold (string-concatenate-reverse buffer) + st width string-width justify-line justify-last)))) + +(define (fmt-file path) + (lambda (st) + (call-with-input-file path + (lambda (p) + (let lp ((st st)) + (let ((line (read-line p))) + (if (eof-object? line) + st + (lp (nl ((dsp line) st)))))))))) + +(define (line-numbers . o) + (let ((start (if (pair? o) (car o) 1))) + (fmt-join/range dsp start #f nl-str))) + diff --git a/functional-tests/fmt/fmt-gauche.scm b/functional-tests/fmt/fmt-gauche.scm new file mode 100644 index 0000000..5f67162 --- /dev/null +++ b/functional-tests/fmt/fmt-gauche.scm @@ -0,0 +1,46 @@ +;;;; fmt-gauche.scm -- Gauche fmt extension +;; +;; Copyright (c) 2006-2011 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +(define-module text.fmt + (use srfi-1) + (use srfi-6) + (use srfi-13) + (export + new-fmt-state + fmt fmt-start fmt-if fmt-capture fmt-let fmt-bind fmt-null + fmt-ref fmt-set! fmt-add-properties! fmt-set-property! + fmt-col fmt-set-col! fmt-row fmt-set-row! + fmt-radix fmt-set-radix! fmt-precision fmt-set-precision! + fmt-properties fmt-set-properties! fmt-width fmt-set-width! + fmt-writer fmt-set-writer! fmt-port fmt-set-port! + fmt-decimal-sep fmt-set-decimal-sep! + fmt-file fmt-try-fit cat apply-cat nl fl nl-str + fmt-join fmt-join/last fmt-join/dot + fmt-join/prefix fmt-join/suffix fmt-join/range + pad pad/right pad/left pad/both trim trim/left trim/both trim/length + fit fit/left fit/both tab-to space-to wrt wrt/unshared dsp + pretty pretty/unshared slashified maybe-slashified + num num/si num/fit num/comma radix fix decimal-align ellipses + upcase downcase titlecase pad-char comma-char decimal-char + with-width wrap-lines fold-lines justify + make-string-fmt-transformer + make-space make-nl-space display-to-string write-to-string + fmt-columns columnar tabular line-numbers + )) +(select-module text.fmt) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SRFI-69 compatible hashtables + +(define (make-eq?-table) + (make-hash-table 'eq?)) +(define hash-table-ref/default hash-table-get) +(define hash-table-set! hash-table-put!) +(define (hash-table-walk tab proc) (hash-table-for-each tab proc)) + +(define (mantissa+exponent num) + (let ((vec (decode-float num))) + (list (vector-ref vec 0) (vector-ref vec 1)))) + diff --git a/functional-tests/fmt/fmt-js.scm b/functional-tests/fmt/fmt-js.scm new file mode 100644 index 0000000..00a44f0 --- /dev/null +++ b/functional-tests/fmt/fmt-js.scm @@ -0,0 +1,74 @@ +;;;; fmt-js.scm -- javascript formatting utilities +;; +;; Copyright (c) 2011-2012 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (js-expr x) + (fmt-let 'gen js-expr/sexp + (lambda (st) (((or (fmt-gen st) js-expr/sexp) x) st)))) + +(define (js-expr/sexp x) + (cond + ((procedure? x) + x) + ((pair? x) + (case (car x) + ((%fun function) (apply js-function (cdr x))) + ((%var var) (apply js-var (cdr x))) + ((eq? ===) (apply js=== (cdr x))) + ((>>>) (apply js>>> (cdr x))) + ((%array) (js-array x)) + ((%object) (js-object (cdr x))) + ((%comment) (js-comment x)) + (else (c-expr/sexp x)))) + ((vector? x) (js-array x)) + ((boolean? x) (cat (if x "true" "false"))) + ((char? x) (js-expr/sexp (string x))) + (else (c-expr/sexp x)))) + +(define (js-function . x) + (let* ((name (and (symbol? (car x)) (car x))) + (params (if name (cadr x) (car x))) + (body (if name (cddr x) (cdr x)))) + (c-block + (cat "function " (dsp (or name "")) "(" + (fmt-join dsp params ", ") ")") + (fmt-let 'return? #t (c-in-stmt (apply c-begin body)))))) + +(define (js-var . args) + (apply c-var 'var args)) + +(define (js=== . args) + (apply c-op "===" args)) + +(define (js>>> . args) + (apply c-op ">>>" args)) + +(define (js-comment . args) + (columnar "// " (apply-cat args))) + +(define (js-array x) + (let ((ls (vector->list x))) + (c-wrap-stmt + (fmt-try-fit + (fmt-let 'no-wrap? #t (cat "[" (fmt-join js-expr ls ", ") "]")) + (lambda (st) + (let* ((col (fmt-col st)) + (sep (string-append "," (make-nl-space col)))) + ((cat "[" (fmt-join js-expr ls sep) "]" nl) st))))))) + +(define (js-pair x) + (cat (js-expr (car x)) ": " (js-expr (cdr x)))) + +(define (js-object ls) + (c-in-expr + (fmt-try-fit + (fmt-let 'no-wrap? #t (cat "{" (fmt-join js-pair ls ", ") "}")) + (lambda (st) + (let* ((col (fmt-col st)) + (sep (string-append "," (make-nl-space col)))) + ((cat "{" (fmt-join js-pair ls sep) "}" nl) st)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/functional-tests/fmt/fmt-pretty.scm b/functional-tests/fmt/fmt-pretty.scm new file mode 100644 index 0000000..3992084 --- /dev/null +++ b/functional-tests/fmt/fmt-pretty.scm @@ -0,0 +1,263 @@ +;;;; fmt-pretty.scm -- pretty printing format combinator +;; +;; Copyright (c) 2006-2007 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; additional settings + +(define (fmt-shares st) (fmt-ref st 'shares)) +(define (fmt-set-shares! st x) (fmt-set! st 'shares x)) +(define (fmt-copy-shares st) + (fmt-set-shares! (copy-fmt-state st) (copy-shares (fmt-shares st)))) + +(define (copy-shares shares) + (let ((tab (make-eq?-table))) + (hash-table-walk + (car shares) + (lambda (obj x) (eq?-table-set! tab obj (cons (car x) (cdr x))))) + (cons tab (cdr shares)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; utilities + +(define (fmt-shared-write obj proc) + (lambda (st) + (let* ((shares (fmt-shares st)) + (cell (and shares (eq?-table-ref (car shares) obj)))) + (if (pair? cell) + (cond + ((cdr cell) + ((fmt-writer st) (gen-shared-ref (car cell) "#") st)) + (else + (set-car! cell (cdr shares)) + (set-cdr! cell #t) + (set-cdr! shares (+ (cdr shares) 1)) + (proc ((fmt-writer st) (gen-shared-ref (car cell) "=") st)))) + (proc st))))) + +(define (fmt-join/shares fmt ls . o) + (let ((sep (dsp (if (pair? o) (car o) " ")))) + (lambda (st) + (if (null? ls) + st + (let* ((shares (fmt-shares st)) + (tab (car shares)) + (output (fmt-writer st))) + (let lp ((ls ls) (st st)) + (let ((st ((fmt (car ls)) st)) + (rest (cdr ls))) + (cond + ((null? rest) st) + ((pair? rest) + (call-with-shared-ref/cdr rest st shares + (lambda (st) (lp rest st)) + sep)) + (else ((fmt rest) (output ". " (sep st)))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pretty printing + +(define (non-app? x) + (if (pair? x) + (or (not (or (null? (cdr x)) (pair? (cdr x)))) + (non-app? (car x))) + (not (symbol? x)))) + +(define syntax-abbrevs + '((quote . "'") (quasiquote . "`") (unquote . ",") (unquote-splicing . ",@") + )) + +(define (pp-let ls) + (if (and (pair? (cdr ls)) (symbol? (cadr ls))) + (pp-with-indent 2 ls) + (pp-with-indent 1 ls))) + +(define indent-rules + `((lambda . 1) (define . 1) + (let . ,pp-let) (loop . ,pp-let) + (let* . 1) (letrec . 1) (letrec* . 1) (and-let* . 1) (let1 . 2) + (let-values . 1) (let*-values . 1) (receive . 2) (parameterize . 1) + (let-syntax . 1) (letrec-syntax . 1) (syntax-rules . 1) (syntax-case . 2) + (match . 1) (match-let . 1) (match-let* . 1) + (if . 3) (when . 1) (unless . 1) (case . 1) (while . 1) (until . 1) + (do . 2) (dotimes . 1) (dolist . 1) (test . 1) + (condition-case . 1) (guard . 1) (rec . 1) + (call-with-current-continuation . 0) + )) + +(define indent-prefix-rules + `(("with-" . -1) ("call-with-" . -1) ("define-" . 1)) + ) + +(define indent-suffix-rules + `(("-case" . 1)) + ) + +(define (pp-indentation form) + (let ((indent + (cond + ((assq (car form) indent-rules) => cdr) + ((and (symbol? (car form)) + (let ((str (symbol->string (car form)))) + (or (find (lambda (rx) (string-prefix? (car rx) str)) + indent-prefix-rules) + (find (lambda (rx) (string-suffix? (car rx) str)) + indent-suffix-rules)))) + => cdr) + (else #f)))) + (if (and (number? indent) (negative? indent)) + (max 0 (- (+ (length+ form) indent) 1)) + indent))) + +(define (pp-with-indent indent-rule ls) + (lambda (st) + (let* ((col1 (fmt-col st)) + (st ((cat "(" (pp-object (car ls))) st)) + (col2 (fmt-col st)) + (fixed (take* (cdr ls) (or indent-rule 1))) + (tail (drop* (cdr ls) (or indent-rule 1))) + (st2 (fmt-copy-shares st)) + (first-line + ((fmt-to-string (cat " " (fmt-join/shares pp-flat fixed " "))) st2)) + (default + (let ((sep (make-nl-space (+ col1 1)))) + (cat sep (fmt-join/shares pp-object (cdr ls) sep) ")")))) + (cond + ((< (+ col2 (string-length first-line)) (fmt-width st2)) + ;; fixed values on first line + (let ((sep (make-nl-space + (if indent-rule (+ col1 2) (+ col2 1))))) + ((cat first-line + (cond + ((not (or (null? tail) (pair? tail))) + (cat ". " (pp-object tail))) + ((> (length+ (cdr ls)) (or indent-rule 1)) + (cat sep (fmt-join/shares pp-object tail sep))) + (else + fmt-null)) + ")") + st2))) + (indent-rule ;;(and indent-rule (not (pair? (car ls)))) + ;; fixed values lined up, body indented two spaces + ((fmt-try-fit + (lambda (st) + ((cat + " " + (fmt-join/shares pp-object fixed (make-nl-space (+ col2 1))) + (if (pair? tail) + (let ((sep (make-nl-space (+ col1 2)))) + (cat sep (fmt-join/shares pp-object tail sep))) + "") + ")") + (fmt-copy-shares st))) + default) + st)) + (else + ;; all on separate lines + (default st)))))) + +(define (pp-app ls) + (let ((indent-rule (pp-indentation ls))) + (if (procedure? indent-rule) + (indent-rule ls) + (pp-with-indent indent-rule ls)))) + +;; the elements may be shared, just checking the top level list +;; structure +(define (proper-non-shared-list? ls shares) + (let ((tab (car shares))) + (let lp ((ls ls)) + (or (null? ls) + (and (pair? ls) + (not (eq?-table-ref tab ls)) + (lp (cdr ls))))))) + +(define (pp-flat x) + (cond + ((pair? x) + (fmt-shared-write + x + (cond + ((and (pair? (cdr x)) (null? (cddr x)) + (assq (car x) syntax-abbrevs)) + => (lambda (abbrev) + (cat (cdr abbrev) (pp-flat (cadr x))))) + (else + (cat "(" (fmt-join/shares pp-flat x " ") ")"))))) + ((vector? x) + (fmt-shared-write + x + (cat "#(" (fmt-join/shares pp-flat (vector->list x) " ") ")"))) + (else + (lambda (st) ((write-with-shares x (fmt-shares st)) st))))) + +(define (pp-pair ls) + (fmt-shared-write + ls + (cond + ;; one element list, no lines to break + ((null? (cdr ls)) + (cat "(" (pp-object (car ls)) ")")) + ;; quote or other abbrev + ((and (pair? (cdr ls)) (null? (cddr ls)) + (assq (car ls) syntax-abbrevs)) + => (lambda (abbrev) + (cat (cdr abbrev) (pp-object (cadr ls))))) + (else + (fmt-try-fit + (lambda (st) ((pp-flat ls) (fmt-copy-shares st))) + (lambda (st) + (if (and (non-app? ls) + (proper-non-shared-list? ls (fmt-shares st))) + ((pp-data-list ls) st) + ((pp-app ls) st)))))))) + +(define (pp-data-list ls) + (lambda (st) + (let* ((output (fmt-writer st)) + (st (output "(" st)) + (col (fmt-col st)) + (width (- (fmt-width st) col)) + (st2 (fmt-copy-shares st))) + (cond + ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdddr ls)) + ((fits-in-columns ls pp-flat width) st2)) + => (lambda (ls) + ;; at least four elements which can be broken into columns + (let* ((prefix (make-nl-space (+ col 1))) + (widest (+ 1 (car ls))) + (columns (quotient width widest))) ; always >= 2 + (let lp ((ls (cdr ls)) (st st2) (i 1)) + (cond + ((null? ls) + (output ")" st)) + ((null? (cdr ls)) + (output ")" (output (car ls) st))) + (else + (let ((st (output (car ls) st))) + (if (>= i columns) + (lp (cdr ls) (output prefix st) 1) + (let* ((pad (- widest (string-length (car ls)))) + (st (output (make-space pad) st))) + (lp (cdr ls) st (+ i 1))))))))))) + (else + ;; no room, print one per line + ((cat (fmt-join pp-object ls (make-nl-space col)) ")") st)))))) + +(define (pp-vector vec) + (fmt-shared-write vec (cat "#" (pp-data-list (vector->list vec))))) + +(define (pp-object obj) + (cond + ((pair? obj) (pp-pair obj)) + ((vector? obj) (pp-vector obj)) + (else (lambda (st) ((write-with-shares obj (fmt-shares st)) st))))) + +(define (pretty obj) + (fmt-bind 'shares (cons (make-shared-ref-table obj) 0) + (cat (pp-object obj) fl))) + +(define (pretty/unshared obj) + (fmt-bind 'shares (cons (make-eq?-table) 0) (cat (pp-object obj) fl))) + diff --git a/functional-tests/fmt/fmt-unicode.scm b/functional-tests/fmt/fmt-unicode.scm new file mode 100644 index 0000000..b3e9f91 --- /dev/null +++ b/functional-tests/fmt/fmt-unicode.scm @@ -0,0 +1,135 @@ +;;;; fmt-unicode.scm -- Unicode character width and ANSI escape support +;; +;; Copyright (c) 2006-2007 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; a condensed non-spacing mark range from UnicodeData.txt (chars with +;; the Mn property) - generated partially by hand, should automate +;; this better + +(define low-non-spacing-chars + (bytevector +#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +#x78 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 #xfe #xff #xff #xff #xff #xff #x1f 0 0 0 0 0 0 0 + 0 0 #x3f 0 0 0 0 0 0 #xf8 #xff #x01 0 0 #x01 0 + 0 0 0 0 0 0 0 0 0 0 #xc0 #xff #xff #x3f 0 0 + 0 0 #x02 0 0 0 #xff #xff #xff #x07 0 0 0 0 0 0 + 0 0 0 0 #xc0 #xff #x01 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +#x06 0 0 0 0 0 0 #x10 #xfe #x21 #x1e 0 #x0c 0 0 0 +#x02 0 0 0 0 0 0 #x10 #x1e #x20 0 0 #x0c 0 0 0 +#x06 0 0 0 0 0 0 #x10 #xfe #x3f 0 0 0 0 #x03 0 +#x06 0 0 0 0 0 0 #x30 #xfe #x21 0 0 #x0c 0 0 0 +#x02 0 0 0 0 0 0 #x90 #x0e #x20 #x40 0 0 0 0 0 +#x04 0 0 0 0 0 0 0 0 #x20 0 0 0 0 0 0 + 0 0 0 0 0 0 0 #xc0 #xc1 #xff #x7f 0 0 0 0 0 + 0 0 0 0 0 0 0 #x10 #x40 #x30 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 #x0e #x20 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 #x04 #x7c 0 0 0 0 0 + 0 0 0 0 0 0 #xf2 #x07 #x80 #x7f 0 0 0 0 0 0 + 0 0 0 0 0 0 #xf2 #x1f 0 #x3f 0 0 0 0 0 0 + 0 0 0 #x03 0 0 #xa0 #x02 0 0 0 0 0 0 #xfe #x7f +#xdf 0 #xff #xff #xff #xff #xff #x1f #x40 0 0 0 0 0 0 0 + 0 0 0 0 0 #xe0 #xfd #x02 0 0 0 #x03 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 #x1c 0 0 0 #x1c 0 0 0 #x0c 0 0 0 #x0c 0 + 0 0 0 0 0 0 #x80 #x3f #x40 #xfe #x0f #x20 0 0 0 0 + 0 #x38 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 #x02 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 #x87 #x01 #x04 #x0e 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 #xff #x1f #xe2 #x07 + )) + +(define (unicode-char-width c) + (let ((ci (char->integer c))) + (cond + ;; hand-checked ranges from EastAsianWidth.txt + ((<= #x1100 ci #x115F) 2) ; Hangul + ((<= #x2E80 ci #x4DB5) 2) ; CJK + ((<= #x4E00 ci #xA4C6) 2) + ((<= #xAC00 ci #xD7A3) 2) ; Hangul + ((<= #xF900 ci #xFAD9) 2) ; CJK compat + ((<= #xFE10 ci #xFE6B) 2) + ((<= #xFF01 ci #xFF60) 2) + ((<= #xFFE0 ci #xFFE6) 2) + ((<= #x20000 ci #x30000) 2) + ;; non-spacing mark (Mn) ranges from UnicodeData.txt + ((<= #x0300 ci #x3029) + ;; inlined bit-vector-ref for portability + (let* ((i (- ci #x0300)) + (byte (quotient i 8)) + (off (remainder i 8))) + (if (zero? (bitwise-and (bytevector-u8-ref low-non-spacing-chars byte) + (bitwise-arithmetic-shift 1 off))) + 1 + 0))) + ((<= #x302A ci #x302F) 0) + ((<= #x3099 ci #x309A) 0) + ((= #xFB1E ci) 0) + ((<= #xFE00 ci #xFE23) 0) + ((<= #x1D167 ci #x1D169) 0) + ((<= #x1D17B ci #x1D182) 0) + ((<= #x1D185 ci #x1D18B) 0) + ((<= #x1D1AA ci #x1D1AD) 0) + ((<= #xE0100 ci #xE01EF) 0) + (else 1)))) + +(define (unicode-string-width str . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (string-length str)))) + (let lp1 ((i start) (width 0)) + (if (>= i end) + width + (let ((c (string-ref str i))) + (cond + ;; ANSI escapes + ((and (= 27 (char->integer c)) ; esc + (< (+ i 1) end) + (eqv? #\[ (string-ref str (+ i 1)))) + (let lp2 ((i (+ i 2))) + (cond ((>= i end) width) + ((memv (string-ref str i) '(#\m #\newline)) + (lp1 (+ i 1) width)) + (else (lp2 (+ i 1)))))) + ;; unicode characters + ((>= (char->integer c) #x80) + (lp1 (+ i 1) (+ width (unicode-char-width c)))) + ;; normal ASCII + (else (lp1 (+ i 1) (+ width 1))))))))) + +(define (fmt-unicode . args) + (fmt-let 'string-width unicode-string-width (apply-cat args))) + diff --git a/functional-tests/fmt/fmt.css b/functional-tests/fmt/fmt.css new file mode 100644 index 0000000..616c419 --- /dev/null +++ b/functional-tests/fmt/fmt.css @@ -0,0 +1,69 @@ +body { +color: black; +background-color: white; +margin-top: 2em; +margin-left: 10%; +width: 400pt; +} + +pre { + background-color: beige; +} + +pre.scheme { + background-color: white; +} + +.subject { +} + +h1 { +margin-left: -5%; +margin-top: 2em; +font-size: large; +} + +h2 { +margin-left: -4%; +margin-top: 1em; +font-size: large; +} + +h3,h4,h5,h6 { +margin-left: -3%; +margin-top: .5em; +font-size: small; +} + +.navigation { +color: red; +background-color: beige; +text-align: right; +font-style: italic; +} + + +.scheme { +color: brown; +} + +.scheme .keyword { +color: #cc0000; +font-weight: bold; +} + +.scheme .variable { +color: navy; +} + +.scheme .global { +color: purple; +} + +.scheme .constant,.number,.char,.string,.boolean { +color: green; +} + +.scheme .comment { +color: teal; +} diff --git a/functional-tests/fmt/fmt.doc b/functional-tests/fmt/fmt.doc new file mode 100644 index 0000000..a821f2b --- /dev/null +++ b/functional-tests/fmt/fmt.doc @@ -0,0 +1,1349 @@ + +\title{Combinator Formatting} + +\eval +(begin + (display "\n")) + +\flushright{\urlh{http://synthcode.com/}{Alex Shinn}} +\flushright{\urlh{http://synthcode.com/scheme/fmt/fmt-0.8.4.tar.gz}{Download Version 0.8.4}} + +\eval(display "

\n\n") + +A library of procedures for formatting Scheme objects to text in +various ways, and for easily concatenating, composing and extending +these formatters efficiently without resorting to capturing and +manipulating intermediate strings. + +\eval(display "

\n\n") + +\section{Table of Contents} + +\eval(display "\n\n\n\n") + +\eval(display "

\n\n") + +\section{Installation} + +Available for Chicken as the \p{fmt} egg, providing the \q{fmt}, +\q{fmt-c}, \q{fmt-color} and \q{fmt-unicode} extensions. To install +manually for Chicken just run \p{"chicken-setup"} in the fmt +directory. + +For Gauche run \p{"make gauche && make install-gauche"}. The modules +are installed as \q{text.fmt}, \q{text.fmt.c}, \q{text.fmt.color} and +\q{text.fmt.unicode}. + +For MzScheme you can download and install the latest \p{fmt.plt} yourself +from: + + \urlh{http://synthcode.com/scheme/fmt/fmt.plt}{http://synthcode.com/scheme/fmt/fmt.plt} + +To build the \p{fmt.plt} for yourself you can run \p{"make mzscheme"}. + +For Scheme48 the package descriptions are in \p{fmt-scheme48.scm}: + +\q{ +> ,config ,load fmt-scheme48.scm +> ,open fmt +} + +For other implementations you'll need to load SRFI's 1, 6, 13, 33 +(sample provided) and 69 (also provided), and then load the following +files: + +\q{ + (load "let-optionals.scm") ; if you don't have LET-OPTIONALS* + (load "read-line.scm") ; if you don't have READ-LINE + (load "string-ports.scm") ; if you don't have CALL-WITH-OUTPUT-STRING + (load "make-eq-table.scm") + (load "mantissa.scm") + (load "fmt.scm") + (load "fmt-pretty.scm") ; optional pretty printing + (load "fmt-column.scm") ; optional columnar output + (load "fmt-c.scm") ; optional C formatting utilities + (load "fmt-color.scm") ; optional color utilities + (load "fmt-unicode.scm") ; optional Unicode-aware formatting, + ; also requires SRFI-4 or SRFI-66 +} + +\section{Background} + +There are several approaches to text formatting. Building strings to +\q{display} is not acceptable, since it doesn't scale to very large +output. The simplest realistic idea, and what people resort to in +typical portable Scheme, is to interleave \q{display} and \q{write} +and manual loops, but this is both extremely verbose and doesn't +compose well. A simple concept such as padding space can't be +achieved directly without somehow capturing intermediate output. + +The traditional approach is to use templates - typically strings, +though in theory any object could be used and indeed Emacs' mode-line +format templates allow arbitrary sexps. Templates can use either +escape sequences (as in C's \q{printf} and \urlh{#BIBITEM_2}{CL's} +\q{format}) or pattern matching (as in Visual Basic's \q{Format}, +\urlh{#BIBITEM_6}{Perl6's} \q{form}, and SQL date formats). The +primary disadvantage of templates is the relative difficulty (usually +impossibility) of extending them, their opaqueness, and the +unreadability that arises with complex formats. Templates are not +without their advantages, but they are already addressed by other +libraries such as \urlh{#BIBITEM_3}{SRFI-28} and +\urlh{#BIBITEM_4}{SRFI-48}. + +This library takes a combinator approach. Formats are nested chains +of closures, which are called to produce their output as needed. +The primary goal of this library is to have, first and foremost, a +maximally expressive and extensible formatting library. The next +most important goal is scalability - to be able to handle +arbitrarily large output and not build intermediate results except +where necessary. The third goal is brevity and ease of use. + +\section{Usage} + +The primary interface is the \q{fmt} procedure: + + \q{(fmt ...)} + +where \q{} has the same semantics as with \q{format} - +specifically it can be an output-port, \q{#t} to indicate the current +output port, or \q{#f} to accumulate output into a string. + +Each \q{} should be a format closure as discussed below. As a +convenience, non-procedure arguments are also allowed and are +formatted similar to \q{display}, so that + + \q{(fmt #f "Result: " res nl)} + +would return the string \q{"Result: 42\n"}, assuming \q{RES} is bound +to \q{42}. + +\q{nl} is the newline format combinator. + +\section{Specification} + +The procedure names have gone through several variations, and I'm +still open to new suggestions. The current approach is to use +abbreviated forms of standard output procedures when defining an +equivalent format combinator (thus \q{display} becomes \q{dsp} and +\q{write} becomes \q{wrt}), and to use an \q{fmt-} prefix for +utilities and less common combinators. Variants of the same formatter +get a \q{/} suffix. + +\subsection{Formatting Objects} + +\subsubsection*{(dsp )} + +Outputs \q{} using \q{display} semantics. Specifically, strings +are output without surrounding quotes or escaping and characters are +written as if by \q{write-char}. Other objects are written as with +\q{write} (including nested strings and chars inside \q{}). This +is the default behavior for top-level formats in \q{fmt}, \q{cat} and +most other higher-order combinators. + +\subsubsection*{(wrt )} + +Outputs \q{} using \q{write} semantics. Handles shared +structures as in \urlh{#BIBITEM_5}{SRFI-38}. + +\subsubsection*{(wrt/unshared )} + +As above, but doesn't handle shared structures. Infinite loops can +still be avoided if used inside a combinator that truncates data (see +\q{trim} and \q{fit} below). + +\subsubsection*{(pretty )} + +Pretty-prints \q{}. Also handles shared structures. Unlike many +other pretty printers, vectors and data lists (lists that don't begin +with a (nested) symbol), are printed in tabular format when there's +room, greatly saving vertical space. + +\subsubsection*{(pretty/unshared )} + +As above but without sharing. + +\subsubsection*{(slashified [ ])} + +Outputs the string \q{}, escaping any quote or escape characters. +If \q{} is \q{#f} escapes only the \q{} by +doubling it, as in SQL strings and CSV values. If \q{} is +provided, it should be a procedure of one character which maps that +character to its escape value, e.g. \q{#\newline => #\n}, or \q{#f} if +there is no escape value. + + \q{(fmt #f (slashified "hi, \"bob!\""))} + + \q{=> "hi, \"bob!\""} + +\subsubsection*{(maybe-slashified [ ])} + +Like \q{slashified}, but first checks if any quoting is required (by +the existence of either any quote or escape characters, or any +character matching \q{}), and if so outputs the string in quotes +and with escapes. Otherwise outputs the string as is. + + \q{(fmt #f (maybe-slashified "foo" char-whitespace? #\"))} + + \q{=> "foo"} + + \q{(fmt #f (maybe-slashified "foo bar" char-whitespace? #\"))} + + \q{=> "\"foo bar\""} + + \q{(fmt #f (maybe-slashified "foo\"bar\"baz" char-whitespace? #\"))} + + \q{=> "\"foo\"bar\"baz\""} + +\subsection{Formatting Numbers} + +\subsubsection*{(num [ ])} + +Formats a single number \q{}. You can optionally specify any +\q{} from 2 to 36 (even if \q{} isn't an integer). +\q{} forces a fixed-point format. + +A \q{} of \q{#t} indicates to output a plus sign (+) for positive +integers. However, if \q{} is a character, it means to wrap the +number with that character and its mirror opposite if the number is +negative. For example, \q{#\(} prints negative numbers in parenthesis, +financial style: \q{-3.14 => (3.14)} + +\q{} is an integer specifying the number of digits between +commas. Variable length, as in subcontinental-style, is not yet +supported. + +\q{} is the character to use for commas, defaulting to \q{#\,}. + +\q{} is the character to use for decimals, defaulting to +\q{#\.}, or to \q{#\,} (European style) if \q{} is already +\q{#\.}. + +These parameters may seem unwieldy, but they can also take their +defaults from state variables, described below. + +\subsubsection*{(num/comma [ ])} + +Shortcut for \q{num} to print with commas. + + \q{(fmt #f (num/comma 1234567))} + + \q{=> "1,234,567"} + +\subsubsection*{(num/si [ ])} + +Abbreviates \q{} with an SI suffix as in the -h or --si option to +many GNU commands. The base defaults to 1024, using suffix names +like Ki, Mi, Gi, etc. Other bases (e.g. the standard 1000) have the +suffixes k, M, G, etc. + +The \q{} argument is appended only if an abbreviation is used. + + \q{(fmt #f (num/si 608))} + + \q{=> "608"} + + \q{(fmt #f (num/si 3986))} + + \q{=> "3.9Ki"} + + \q{(fmt #f (num/si 3986 1000 "B"))} + + \q{=> "4kB"} + +See \urlh{http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html}{http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html}. + +\subsubsection*{(num/fit . )} + +Like \q{num}, but if the result doesn't fit in \q{}, output +instead a string of hashes (with the current \q{}) rather +than showing an incorrectly truncated number. For example + + \q{(fmt #f (fix 2 (num/fit 4 12.345)))} + \q{=> "#.##"} + +\subsubsection*{(num/roman )} + +Formats the number as a Roman numeral: + + \q{(fmt #f (num/roman 1989))} + \q{=> "MCMLXXXIX"} + +\subsubsection*{(num/old-roman )} + +Formats the number as an old-style Roman numeral, without the +subtraction abbreviation rule: + + \q{(fmt #f (num/old-roman 1989))} + \q{=> "MDCCCCLXXXVIIII"} + + +\subsection{Formatting Space} + +\subsubsection*{nl} + +Outputs a newline. + +\subsubsection*{fl} + +Short for "fresh line," outputs a newline only if we're not already +at the start of a line. + +\subsubsection*{(space-to )} + +Outputs spaces up to the given \q{}. If the current column is +already >= \q{}, does nothing. + +\subsubsection*{(tab-to [])} + +Outputs spaces up to the next tab stop, using tab stops of width +\q{}, which defaults to 8. If already on a tab stop, does +nothing. If you want to ensure you always tab at least one space, you +can use \q{(cat " " (tab-to width))}. + +\subsubsection*{fmt-null} + +Outputs nothing (useful in combinators and as a default noop in +conditionals). + + +\subsection{Concatenation} + +\subsubsection*{(cat ...)} + +Concatenates the output of each \q{}. + +\subsubsection*{(apply-cat )} + +Equivalent to \q{(apply cat )} but may be more efficient. + +\subsubsection*{(fmt-join [])} + +Formats each element \q{} of \q{} with \q{( +)}, inserting \q{} in between. \q{} defaults to the +empty string, but can be any format. + + \q{(fmt #f (fmt-join dsp '(a b c) ", "))} + + \q{=> "a, b, c"} + +\subsubsection*{(fmt-join/prefix [])} +\subsubsection*{(fmt-join/suffix [])} + + \q{(fmt #f (fmt-join/prefix dsp '(usr local bin) "/"))} + + \q{=> "/usr/local/bin"} + +As \q{fmt-join}, but inserts \q{} before/after every element. + +\subsubsection*{(fmt-join/last [])} + +As \q{fmt-join}, but the last element of the list is formatted with +\q{} instead. + +\subsubsection*{(fmt-join/dot [])} + +As \q{fmt-join}, but if the list is a dotted list, then formats the dotted +value with \q{} instead. + + +\subsection{Padding and Trimming} + +\subsubsection*{(pad ...)} +\subsubsection*{(pad/left ...)} +\subsubsection*{(pad/both ...)} + +Analogs of SRFI-13 \q{string-pad}, these add extra space to the left, +right or both sides of the output generated by the \q{}s to +pad it to \q{}. If \q{} is exceeded has no effect. +\q{pad/both} will include an extra space on the right side of the +output if the difference is odd. + +\q{pad} does not accumulate any intermediate data. + +Note these are column-oriented padders, so won't necessarily work +with multi-line output (padding doesn't seem a likely operation for +multi-line output). + +\subsubsection*{(trim ...)} +\subsubsection*{(trim/left ...)} +\subsubsection*{(trim/both ...)} + +Analogs of SRFI-13 \q{string-trim}, truncates the output of the +\q{}s to force it in under \q{} columns. As soon as +any of the \q{}s exceed \q{}, stop formatting and +truncate the result, returning control to whoever called \q{trim}. If +\q{} is not exceeded has no effect. + +If a truncation ellipse is set (e.g. with the \q{ellipses} procedure +below), then when any truncation occurs \q{trim} and \q{trim/left} +will append and prepend the ellipse, respectively. \q{trim/both} will +both prepend and append. The length of the ellipse will be considered +when truncating the original string, so that the total width will +never be longer than \q{}. + + \q{(fmt #f (ellipses "..." (trim 5 "abcde")))} + + \q{=> "abcde"} + + \q{(fmt #f (ellipses "..." (trim 5 "abcdef")))} + + \q{=> "ab..."} + +\subsubsection*{(trim/length ...)} + +A variant of \q{trim} which acts on the actual character count rather +than columns, useful for truncating potentially cyclic data. + +\subsubsection*{(fit ...)} +\subsubsection*{(fit/left ...)} +\subsubsection*{(fit/both ...)} + +A combination of \q{pad} and \q{trunc}, ensures the output width is +exactly \q{}, truncating if it goes over and padding if it goes +under. + + +\subsection{Format Variables} + +You may have noticed many of the formatters are aware of the current +column. This is because each combinator is actually a procedure of +one argument, the current format state, which holds basic +information such as the row, column, and any other information that +a format combinator may want to keep track of. The basic interface +is: + +\subsubsection*{(fmt-let ...)} +\subsubsection*{(fmt-bind ...)} + +\q{fmt-let} sets the name for the duration of the \q{}s, and +restores it on return. \q{fmt-bind} sets it without restoring it. + +A convenience control structure can be useful in combination with +these states: + +\subsubsection*{(fmt-if [])} + +\q{} takes one argument (the format state) and returns a boolean +result. If true, the \q{} format is applied to the state, +otherwise \q{} (defaulting to the identity) is applied. + +Many of the previously mentioned combinators have behavior which can +be altered with state variables. Although \q{fmt-let} and \q{fmt-bind} +could be used, these common variables have shortcuts: + +\subsubsection*{(radix ...)} +\subsubsection*{(fix ...)} + +These alter the radix and fixed point precision of numbers output with +\q{dsp}, \q{wrt}, \q{pretty} or \q{num}. These settings apply +recursively to all output data structures, so that + + \q{(fmt #f (radix 16 '(70 80 90)))} + +will return the string \q{"(#x46 #x50 #x5a)"}. Note that read/write +invariance is essential, so for \q{dsp}, \q{wrt} and \q{pretty} the +radix prefix is always included when not decimal. Use \q{num} if you +want to format numbers in alternate bases without this prefix. For +example, + + \q{(fmt #f (radix 16 "(" (fmt-join num '(70 80 90) " ") ")"))} + +would return \q{"(46 50 5a)"}, the same output as above without the +"#x" radix prefix. + +Note that fixed point formatting supports arbitrary precision in +implementations with exact non-integral rationals. When trying to +print inexact numbers more than the machine precision you will +typically get results like + + \q{(fmt #f (fix 30 #i2/3))} + + \q{=> "0.666666666666666600000000000000"} + +but with an exact rational it will give you as many digits as you +request: + + \q{(fmt #f (fix 30 2/3))} + + \q{=> "0.666666666666666666666666666667"} + +\subsubsection*{(decimal-align ...)} + +Specifies an alignment for the decimal place when formatting numbers, +useful for outputting tables of numbers. + +\q{ + (define (print-angles x) + (fmt-join num (list x (sin x) (cos x) (tan x)) " ")) + + (fmt #t (decimal-align 5 (fix 3 (fmt-join/suffix print-angles (iota 5) nl)))) +} + +would output + +\p{ + 0.000 0.000 1.000 0.000 + 1.000 0.842 0.540 1.557 + 2.000 0.909 -0.416 -2.185 + 3.000 0.141 -0.990 -0.142 + 4.000 -0.757 -0.654 1.158 +} + +\subsubsection*{(comma-char ...)} +\subsubsection*{(decimal-char ...)} + +\q{comma-char} and \q{decimal-char} set the defaults for number +formatting. + +\subsubsection*{(pad-char ...)} + +The \q{pad-char} sets the character used by \q{space-to}, \q{tab-to}, +\q{pad/*}, and \q{fit/*}, and defaults to \q{#\space}. + +\q{ + (define (print-table-of-contents alist) + (define (print-line x) + (cat (car x) (space-to 72) (pad/left 3 (cdr x)))) + (fmt #t (pad-char #\. (fmt-join/suffix print-line alist nl)))) + + (print-table-of-contents + '(("An Unexpected Party" . 29) + ("Roast Mutton" . 60) + ("A Short Rest" . 87) + ("Over Hill and Under Hill" . 100) + ("Riddles in the Dark" . 115))) +} + +would output + +\p{ + An Unexpected Party.....................................................29 + Roast Mutton............................................................60 + A Short Rest............................................................87 + Over Hill and Under Hill...............................................100 + Riddles in the Dark....................................................115 +} + +\subsubsection*{(ellipse ...)} + +Sets the truncation ellipse to \q{}, would should be a string or +character. + +\subsubsection*{(with-width ...)} + +Sets the maximum column width used by some formatters. The default +is 78. + + +\subsection{Columnar Formatting} + +Although \q{tab-to}, \q{space-to} and padding can be used to manually +align columns to produce table-like output, these can be awkward to +use. The optional extensions in this section make this easier. + +\subsubsection*{(columnar ...)} + +Formats each \q{} side-by-side, i.e. as though each were +formatted separately and then the individual lines concatenated +together. The current column width is divided evenly among the +columns, and all but the last column are right-padded. For example + + \q{(fmt #t (columnar (dsp "abc\\ndef\\n") (dsp "123\\n456\\n")))} + +outputs + +\p{ + abc 123 + def 456 +} + +assuming a 16-char width (the left side gets half the width, or 8 +spaces, and is left aligned). Note that we explicitly use DSP instead +of the strings directly. This is because \q{columnar} treats raw +strings as literals inserted into the given location on every line, to +be used as borders, for example: + +\q{ + (fmt #t (columnar "/* " (dsp "abc\\ndef\\n") + " | " (dsp "123\\n456\\n") + " */")) +} + +would output + +\p{ + /* abc | 123 */ + /* def | 456 */ +} + +You may also prefix any column with any of the symbols \q{'left}, +\q{'right} or \q{'center} to control the justification. The symbol +\q{'infinite} can be used to indicate the column generates an infinite +stream of output. + +You can further prefix any column with a width modifier. Any +positive integer is treated as a fixed width, ignoring the available +width. Any real number between 0 and 1 indicates a fraction of the +available width (after subtracting out any fixed widths). Columns +with unspecified width divide up the remaining width evenly. + +Note that \q{columnar} builds its output incrementally, interleaving +calls to the generators until each has produced a line, then +concatenating that line together and outputting it. This is important +because as noted above, some columns may produce an infinite stream of +output, and in general you may want to format data larger than can fit +into memory. Thus columnar would be suitable for line numbering a +file of arbitrary size, or implementing the Unix \q{yes(1)} command, +etc. + +As an implementation detail, \q{columnar} uses first-class +continuations to interleave the column output. The core \q{fmt} +itself has no knowledge of or special support for \q{columnar}, which +could complicate and potentially slow down simpler \q{fmt} operations. +This is a testament to the power of \q{call/cc} - it can be used to +implement coroutines or arbitrary control structures even where they +were not planned for. + +\subsubsection*{(tabular ...)} + +Equivalent to \q{columnar} except that each column is padded at least +to the minimum width required on any of its lines. Thus + + \q{(fmt #t (tabular "|" (dsp "a\\nbc\\ndef\\n") "|" (dsp "123\\n45\\n6\\n") "|"))} + +outputs + +\p{ +|a |123| +|bc |45 | +|def|6 | +} + +This makes it easier to generate tables without knowing widths in +advance. However, because it requires generating the entire output in +advance to determine the correct column widths, \q{tabular} cannot +format a table larger than would fit in memory. + +\subsubsection*{(fmt-columns ...)} + +The low-level formatter on which \q{columnar} is based. Each \q{} +must be a list of 2-3 elements: + + \q{( [])} + +where \q{} is the column generator as above, and the +\q{} is how each line is formatted. Raw concatenation +of each line is performed, without any spacing or width adjustment. +\q{}, if true, indicates this generator produces an +infinite number of lines and termination should be determined without +it. + +\subsubsection*{(wrap-lines ...)} + +Behaves like \q{cat}, except text is accumulated and lines are optimally +wrapped to fit in the current width as in the Unix \p{fmt(1)} command. + +\subsubsection*{(justify ...)} + +Like \q{wrap-lines} except the lines are full-justified. + +\q{ + (define func + '(define (fold kons knil ls) + (let lp ((ls ls) (acc knil)) + (if (null? ls) acc (lp (cdr ls) (kons (car ls) acc)))))) + + (define doc + (string-append + "The fundamental list iterator. Applies KONS to each element " + "of LS and the result of the previous application, beginning " + "with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE.")) + + (fmt #t (columnar (pretty func) " ; " (justify doc))) +} + +outputs + +\p{ + (define (fold kons knil ls) ; The fundamental list iterator. + (let lp ((ls ls) (acc knil)) ; Applies KONS to each element of + (if (null? ls) ; LS and the result of the previous + acc ; application, beginning with KNIL. + (lp (cdr ls) ; With KONS as CONS and KNIL as '(), + (kons (car ls) acc))))) ; equivalent to REVERSE. +} + +\subsubsection*{(fmt-file )} + +Simply displayes the contents of the file \q{} a line at a +time, so that in typical formatters such as \q{columnar} only constant +memory is consumed, making this suitable for formatting files of +arbitrary size. + +\subsubsection*{(line-numbers [])} + +A convenience utility, just formats an infinite stream of numbers (in +the current radix) beginning with \q{}, which defaults to \q{1}. + +The Unix \q{nl(1)} utility could be implemented as: + +\q{ + (fmt #t (columnar 6 'right 'infinite (line-numbers) + " " (fmt-file "read-line.scm"))) +} + +\p{ + 1 + 2 (define (read-line . o) + 3 (let ((port (if (pair? o) (car o) (current-input-port)))) + 4 (let lp ((res '())) + 5 (let ((c (read-char port))) + 6 (if (or (eof-object? c) (eqv? c #\newline)) + 7 (list->string (reverse res)) + 8 (lp (cons c res))))))) +} + +\section{C Formatting} + +\subsection{C Formatting Basics} + +For purposes such as writing wrappers, code-generators, compilers or +other language tools, people often need to generate or emit C code. +Without a decent library framework it's difficult to maintain proper +indentation. In addition, for the Scheme programmer it's tedious to +work with all the context sensitivities of C, such as the expression +vs. statement distinction, special rules for writing preprocessor +macros, and when precedence rules require parenthesis. Fortunately, +context is one thing this formatting library is good at keeping +track of. The C formatting interface tries to make it as easy as +possible to generate C code without getting in your way. + +There are two approaches to using the C formatting extensions - +procedural and sexp-oriented (described in \ref{csexprs}). In the +procedural interface, C operators are made available as formatters +with a "c-" prefix, literals are converted to their C equivalents and +symbols are output as-is (you're responsible for making sure they are +valid C identifiers). Indentation is handled automatically. + + \q{(fmt #t (c-if 1 2 3))} + +outputs + +\p{ + if (1) { + 2; + } else { + 3; + } +} + +In addition, the formatter knows when you're in an expression and +when you're in a statement, and behaves accordingly, so that + + \q{(fmt #t (c-if (c-if 1 2 3) 4 5))} + +outputs + +\p{ + if (1 ? 2 : 3) { + 4; + } else { + 5; + } +} + +Similary, \q{c-begin}, used for sequencing, will separate with +semi-colons in a statement and commas in an expression. + +Moreover, we also keep track of the final expression in a function +and insert returns for you: + + \q{(fmt #t (c-fun 'int 'foo '() (c-if (c-if 1 2 3) 4 5)))} + +outputs + +\p{ + int foo () { + if (1 ? 2 : 3) { + return 4; + } else { + return 5; + } + } +} + +although it knows that void functions don't return. + +Switch statements insert breaks by default if they don't return: + +\q{ + (fmt #t (c-switch 'y + (c-case 1 (c+= 'x 1)) + (c-default (c+= 'x 2)))) +} + +\p{ + switch (y) { + case 1: + x += 1; + break; + default: + x += 2; + break; + } +} + +though you can explicitly fallthrough if you want: + +\q{ + (fmt #t (c-switch 'y + (c-case/fallthrough 1 (c+= 'x 1)) + (c-default (c+= 'x 2)))) +} + +\p{ + switch (y) { + case 1: + x += 1; + default: + x += 2; + break; + } +} + +Operators are available with just a "c" prefix, e.g. c+, c-, c*, c/, +etc. \q{c++} is a prefix operator, \q{c++/post} is postfix. ||, | and +|= are written as \q{c-or}, \q{c-bit-or} and \q{c-bit-or=} respectively. + +Function applications are written with \q{c-apply}. Other control +structures such as \q{c-for} and \q{c-while} work as expected. The full +list is in the procedure index below. + +When a C formatter encounters an object it doesn't know how to write +(including lists and records), it outputs them according to the +format state's current \q{'gen} variable. This allows you to specify +generators for your own types, e.g. if you are using your own AST +records in a compiler. + +If the \q{'gen} variable isn't set it defaults to the \q{c-expr/sexp} +procedure, which formats an s-expression as if it were C code. Thus +instead of \q{c-apply} you can just use a list. The full API is +available via normal s-expressions - formatters that aren't keywords +in C are prefixed with a % or otherwise made invalid C identifiers so +that they can't be confused with function application. + + +\subsection{C Preprocessor Formatting} + +C preprocessor formatters also properly handle their surrounding +context, so you can safely intermix them in the normal flow of C +code. + +\q{ + (fmt #t (c-switch 'y + (c-case 1 (c= 'x 1)) + (cpp-ifdef 'H_TWO (c-case 2 (c= 'x 4))) + (c-default (c= 'x 5)))) +} + +\p{ + switch (y) { + case 1: + x = 1; + break; + + #ifdef H_TWO + case 2: + x = 4; + break; + #endif /* H_TWO */ + default: + x = 5; + break; + } +} + +Macros can be handled with \q{cpp-define}, which knows to wrap +individual variable references in parenthesis: + + \q{(fmt #t (cpp-define '(min x y) (c-if (c< 'x 'y) 'x 'y)))} + +\p{ + #define min(x, y) (((x) < (y)) ? (x) : (y)) +} + +As with all C formatters, the CPP output is pretty printed as +needed, and if it wraps over several lines the lines are terminated +with a backslash. + +To write a C header file that is included at most once, you can wrap +the entire body in \q{cpp-wrap-header}: + +\q{ + (fmt #t (cpp-wrap-header "FOO_H" + (c-extern (c-prototype 'int 'foo '())))) +} + +\p{ + #ifndef FOO_H + #define FOO_H + + extern int foo (); + + #endif /* ! FOO_H */ +} + + +\subsection{Customizing C Style} + +The output uses a simplified K&R style with 4 spaces for indentation +by default. The following state variables let you override the +style: + +\subsubsection*{'indent-space} + +how many spaces to indent bodies, default \q{4} + +\subsubsection*{'switch-indent-space} + +how many spaces to indent switch clauses, also defaults to \q{4} + +\subsubsection*{'newline-before-brace?} + +insert a newline before an open brace (non-K&R), defaults to \q{#f} + +\subsubsection*{'braceless-bodies?} + +omit braces when we can prove they aren't needed + +\subsubsection*{'non-spaced-ops?} + +omit spaces between operators and operands for groups of variables and +literals (e.g. "a+b+3" instead of "a + b + 3"} + +\subsubsection*{'no-wrap?} + +Don't wrap function calls and long operator groups over mulitple +lines. Functions and control structures will still use multiple +lines. + +The C formatters also respect the \q{'radix} and \q{'precision} settings. + + +\subsection{C Formatter Index} + +\subsubsection*{(c-if [ [ ...]])} + +Print a chain of if/else conditions. Use a final condition of \q{'else} +for a final else clause. + +\subsubsection*{(c-for ...)} +\subsubsection*{(c-while ...)} + +Basic loop constructs. + +\subsubsection*{(c-fun ...)} +\subsubsection*{(c-prototype )} + +Output a function or function prototype. The parameters should be a +list 2-element lists of the form \q{( )}, +which are output with DSP. A parameter can be abbreviated as just the +symbol name, or \q{#f} can be passed as the type, in which case the +\q{'default-type} state variable is used. The parameters may be a +dotted list, in which case ellipses for a C variadic are inserted - +the actual name of the dotted value is ignored. + +Types are just typically just symbols, or lists of symbols such as +\q{'(const char)}. A complete description is given below in section +\ref{ctypes}. + +These can also accessed as %fun and %prototype at the head of a list. + +\subsubsection*{(c-var [])} + +Declares and optionally initializes a variable. Also accessed as %var +at the head of a list. + +\subsubsection*{(c-begin ...)} + +Outputs each of the s, separated by semi-colons if in a +statement or commas if in an expression. + +\subsubsection*{(c-switch ...)} +\subsubsection*{(c-case ...)} +\subsubsection*{(c-case/fallthrough ...)} +\subsubsection*{(c-default ...)} + +Switch statements. In addition to using the clause formatters, +clauses inside a switch may be handled with a Scheme CASE-like list, +with the car a list of case values and the cdr the body. + +\subsubsection*{(c-label )} +\subsubsection*{(c-goto )} +\subsubsection*{(c-return [])} +\subsubsection*{c-break} +\subsubsection*{c-continue} + +Manual labels and jumps. Labels can also be accessed as a list +beginning with a colon, e.g. \q{'(: label1)}. + +\subsubsection*{(c-const )} +\subsubsection*{(c-static )} +\subsubsection*{(c-volatile )} +\subsubsection*{(c-restrict )} +\subsubsection*{(c-register )} +\subsubsection*{(c-auto )} +\subsubsection*{(c-inline )} +\subsubsection*{(c-extern )} + +Declaration modifiers. May be nested. + +\subsubsection*{(c-extern/C ...)} + +Wraps body in an extern "C" { ... } for use with C++. + +\subsubsection*{(c-cast )} + +Casts an expression to a type. Also %cast at the head of a list. + +\subsubsection*{(c-typedef ...)} + +Creates a new type definition with one or more names. + +\subsubsection*{(c-struct [] [])} +\subsubsection*{(c-union [] [])} +\subsubsection*{(c-class [] [])} +\subsubsection*{(c-attribute ...)} + +Composite type constructors. Attributes may be accessed as +%attribute at the head of a list. + +\q{ + (fmt #f (c-struct 'employee + '((short age) + ((char *) name) + ((struct (year month day)) dob)) + (c-attribute 'packed))) +} + +\p{ + struct employee { + short age; + char* name; + struct { + int year; + int month; + int day; + } dob; + } __attribute__ ((packed)); +} + +\subsubsection*{(c-enum [] )} + +Enumerated types. \q{} may be strings, symbols, or lists of +string or symbol followed by the enum's value. + +\subsubsection*{(c-comment ...)} + +Outputs the \q{}s wrapped in C's /* ... */ comment. Properly +escapes nested comments inside in an Emacs-friendly style. + +\subsection{C Preprocessor Formatter Index} + +\subsubsection*{(cpp-include )} + +If file is a string, outputs in it "quotes", otherwise (as a symbol +or arbitrary formatter) it outputs it in brackets. + + \q{(fmt #f (cpp-include 'stdio.h))} + + \q{=> "#include \n"} + + \q{(fmt #f (cpp-include "config.h"))} + + \q{=> "#include \"config.h\"\n"} + +\subsubsection*{(cpp-define [])} + +Defines a preprocessor macro, which may be just a name or a list of +name and parameters. Properly wraps the value in parenthesis and +escapes newlines. A dotted parameter list will use the C99 variadic +macro syntax, and will also substitute any references to the dotted +name with \p{__VA_ARGS__}: + + \q{(fmt #t (cpp-define '(eprintf . args) '(fprintf stderr args)))} + +\p{ + #define eprintf(...) (fprintf(stderr, __VA_ARGS__)) +} + +\subsubsection*{(cpp-if [ ...])} +\subsubsection*{(cpp-ifdef [ ...])} +\subsubsection*{(cpp-ifndef [ ...])} +\subsubsection*{(cpp-elif [ ...])} +\subsubsection*{(cpp-else ...)} + +Conditional compilation. + +\subsubsection*{(cpp-line [])} + +Line number information. + +\subsubsection*{(cpp-pragma ...)} +\subsubsection*{(cpp-error ...)} +\subsubsection*{(cpp-warning ...)} + +Additional preprocessor directives. + +\subsubsection*{(cpp-stringify )} + +Stringifies \q{} by prefixing the # operator. + +\subsubsection*{(cpp-sym-cat ...)} + +Joins the \q{} into a single preprocessor token with the ## +operator. + +\subsubsection*{(cpp-wrap-header ...)} + +Wrap an entire header to only be included once. + +\subsubsection*{Operators:} + +\q{ +c++ c-- c+ c- c* c/ c% c& c^ c~ c! c&& c<< c>> c== c!= +c< c> c<= c>= c= c+= c-= c*= c/= c%= c&= c^= c<<= c>>= +c++/post c--/post c-or c-bit-or c-bit-or= +} + +\subsection{C Types} +\label{ctypes} + +Typically a type is just a symbol such as \q{'char} or \q{'int}. You +can wrap types with modifiers such as \q{c-const}, but as a +convenience you can just use a list such as in \q{'(const unsignedchar *)}. +You can also nest these lists, so the previous example is +equivalent to \q{'(* (const (unsigned char)))}. + +Pointers may be written as \q{'(%pointer )} for readability - +\q{%pointer} is exactly equivalent to \q{*} in types. + +Unamed structs, classes, unions and enums may be used directly as +types, using their respective keywords at the head of a list. + +Two special types are the %array type and function pointer type. An +array is written: + + \q{(%array [])} + +where \q{} is any other type (including another array or +function pointer), and \q{}, if given, will print the array +size. For example: + + \q{(c-var '(%array (unsigned long) SIZE) 'table '#(1 2 3 4))} + +\p{ +unsigned long table[SIZE] = {1, 2, 3, 4}; +} + +A function pointer is written: + + \q{(%fun ( ...))} + +For example: + + \q{(c-typedef '(%fun double (double double int)) 'f)} + +\p{ +typedef double (*f)(double, double, int); +} + +Wherever a type is expected but not given, the value of the +\q{'default-type} formatting state variable is used. By default this +is just \q{'int}. + +Type declarations work uniformly for variables and parameters, as well +for casts and typedefs. + +\subsection{C as S-Expressions} +\label{csexprs} + +Rather than building formatting closures by hand, it can be more +convenient to just build a normal s-expression and ask for it to be +formatted as C code. This can be thought of as a simple Scheme->C +compiler without any runtime support. + +In a s-expression, strings and characters are printed as C strings and +characters, booleans are printed as 0 or 1, symbols are displayed +as-is, and numbers are printed as C numbers (using the current +formatting radix if specified). Vectors are printed as +comma-separated lists wrapped in braces, which can be used for +initializing arrays or structs. + +A list indicates a C expression or statement. Any of the existing C +keywords can be used to pretty-print the expression as described with +the c-keyword formatters above. Thus, the example above + + \q{(fmt #t (c-if (c-if 1 2 3) 4 5))} + +could also be written + + \q{(fmt #t (c-expr '(if (if 1 2 3) 4 5)))} + +C constructs that are dependent on the underlying syntax and have no +keyword are written with a % prefix (\q{%fun}, \q{%var}, \q{%pointer}, +\q{%array}, \q{%cast}), including C preprocessor constructs +(\q{%include}, \q{%define}, \q{%pragma}, \q{%error}, \q{%warning}, +\q{%if}, \q{%ifdef}, \q{%ifndef}, \q{%elif}). Labels are written as +\q{(: )}. You can write a sequence as \q{(%begin +...)}. + +For example, the following definition of the fibonacci sequence, which +apart from the return type of \q{#f} looks like a Lisp definition: + + \q{(fmt #t (c-expr '(%fun #f fib (n) + (if (<= n 1) + 1 + (+ (fib (- n 1)) (fib (- n 2)))))))} + +prints the working C definition: + +\p{ +int fib (int n) { + if (n <= 1) { + return 1; + } else { + return fib((n - 1)) + fib((n - 2)); + } +} +} + +\section{JavaScript Formatting} + +The experimental fmt-js library extends the fmt-c library with +functionality for formatting JavaScript code. + +\subsubsection*{(js-expr x)} + +Formats a JavaScript expression similarly to \q{c-expr}. Inside a +\q{js-expr} formatter, you can use the normal \q{c-} prefixed +formatters described in the previous section, and they will format +appropriately for JavaScript. + +Currently expressions will all be terminated with a semi-colon, but +that will be made optional in a later release. + +\subsubsection*{(js-function [] () ...)} + +Defines a function (anonymously if no name is provided). + +\subsubsection*{(js-var [])} + +Declares a JavaScript variable, optionally with an initial value. + +\subsubsection*{(js-comment ...)} + +Formats a comment prefixing lines with \q{"// "}. + +\section{Formatting with Color} + +The fmt-color library provides the following utilities: + +\q{ + (fmt-red ...) + (fmt-blue ...) + (fmt-green ...) + (fmt-cyan ...) + (fmt-yellow ...) + (fmt-magenta ...) + (fmt-white ...) + (fmt-black ...) + (fmt-bold ...) + (fmt-underline ...) +} + +and more generally + + \q{(fmt-color ...)} + +where color can be a symbol name or \q{#xRRGGBB} numeric value. +Outputs the formatters colored with ANSI escapes. In addition + + \q{(fmt-in-html ...)} + +can be used to mark the format state as being inside HTML, which the +above color formats will understand and output HTML \q{} tags with +the appropriate style colors, instead of ANSI escapes. + + +\section{Unicode} + +The fmt-unicode library provides the \q{fmt-unicode} formatter, which +just takes a list of formatters and overrides the string-length for +padding and trimming, such that Unicode double or full width +characters are considered 2 characters wide (as they typically are in +fixed-width terminals), while treating combining and non-spacing +characters as 0 characters wide. + +It also recognizes and ignores ANSI escapes, in particular useful if +you want to combine this with the fmt-color utilities. + + +\section{Optimizing} + +The library is designed for scalability and flexibility, not speed, +and I'm not going to think about any fine tuning until it's more +stabilised. One aspect of the design, however, was influenced for the +sake of future optimizations, which is that none of the default format +variables are initialized by global parameters, which leaves room for +inlining and subsequent simplification of format calls. + +If you don't have an aggressively optimizing compiler, you can easily +achieve large speedups on common cases with CL-style compiler macros. + +\section{Common Lisp Format Cheat Sheet} + +A quick reference for those of you switching over from Common Lisp's +format. + +\table{ +\b{format} | \b{fmt} +~a | \q{dsp} +~c | \q{dsp} +~s | \q{wrt/unshared} +~w | \q{wrt} +~y | \q{pretty} +~x | \q{(radix 16 ...)} or \q{(num 16)} +~o | \q{(radix 8 ...)} or \q{(num 8)} +~b | \q{(radix 2 ...)} or \q{(num 2)} +~f | \q{(fix ...)} or \q{(num )} +~% | \q{nl} +~& | \q{fl} +~[...~] | normal \q{if} or \q{fmt-if} (delayed test) +~{...~} | \q{(fmt-join ... [])} +} + +\section{References} + +\bibitem{R5RS} R. Kelsey, W. Clinger, J. Rees (eds.) +\urlh{http://www.schemers.org/Documents/Standards/R5RS/}{Revised^5 Report on the Algorithmic Language Scheme} + +\bibitem{CommonLisp} Guy L. Steele Jr. (editor) +\urlh{http://www.harlequin.com/education/books/HyperSpec/}{Common Lisp Hyperspec} + +\bibitem{SRFI-28} Scott G. Miller +\urlh{http://srfi.schemers.org/srfi-28/}{SRFI-28 Basic Format Strings} + +\bibitem{SRFI-48} Ken Dickey +\urlh{http://srfi.schemers.org/srfi-48/}{SRFI-48 Intermediate Format Strings} + +\bibitem{SRFI-38} Ray Dillinger +\urlh{http://srfi.schemers.org/srfi-38/}{SRFI-38 External Representation for Data With Shared Structure} + +\bibitem{Perl6} Damian Conway +\urlh{http://www.perl.com/lpt/a/819}{Perl6 Exegesis 7 - formatting} + +\eval(display "



\n") + diff --git a/functional-tests/fmt/fmt.html b/functional-tests/fmt/fmt.html new file mode 100644 index 0000000..d7a4f0c --- /dev/null +++ b/functional-tests/fmt/fmt.html @@ -0,0 +1,1751 @@ +Combinator Formatting + + +

Combinator Formatting

+ + + + +

+ +

+ +A library of procedures for formatting Scheme objects to text in +various ways, and for easily concatenating, composing and extending +these formatters efficiently without resorting to capturing and +manipulating intermediate strings. +

+ +

+ +

1  Table of Contents

+ + + +
    +
  1. Table of Contents +
  2. Installation +
  3. Background +
  4. Usage +
  5. Specification +
      +
    1. Formatting Objects +
    2. Formatting Numbers +
    3. Formatting Space +
    4. Concatenation +
    5. Padding and Trimming +
    6. Format Variables +
    7. Columnar Formatting +
    +
  6. C Formatting +
      +
    1. C Formatting Basics +
    2. C Preprocessor Formatting +
    3. Customizing C Style +
    4. C Formatter Index +
    5. C Preprocessor Formatter Index +
    6. C Types +
    7. C as S-Expressions +
    +
  7. JavaScript Formatting +
  8. Formatting with Color +
  9. Unicode +
  10. Optimizing +
  11. Common Lisp Format Cheat Sheet +
  12. References +
+ +

+ +

2  Installation

+ +Available for Chicken as the fmt egg, providing the fmt, +fmt-c, fmt-color and fmt-unicode extensions. To install +manually for Chicken just run "chicken-setup" in the fmt +directory. +

+ +For Gauche run "make gauche && make install-gauche". The modules +are installed as text.fmt, text.fmt.c, text.fmt.color and +text.fmt.unicode. +

+ +For MzScheme you can download and install the latest fmt.plt yourself +from: +

+ +http://synthcode.com/scheme/fmt/fmt.plt +

+ +To build the fmt.plt for yourself you can run "make mzscheme". +

+ +For Scheme48 the package descriptions are in fmt-scheme48.scm: +

+ +

+> ,config ,load fmt-scheme48.scm
+> ,open fmt
+
+

+ +For other implementations you'll need to load SRFI's 1, 6, 13, 33 +(sample provided) and 69 (also provided), and then load the following +files: +

+ +

+  (load "let-optionals.scm")  ; if you don't have LET-OPTIONALS*
+  (load "read-line.scm")      ; if you don't have READ-LINE
+  (load "string-ports.scm")   ; if you don't have CALL-WITH-OUTPUT-STRING
+  (load "make-eq-table.scm")
+  (load "mantissa.scm")
+  (load "fmt.scm")
+  (load "fmt-pretty.scm")     ; optional pretty printing
+  (load "fmt-column.scm")     ; optional columnar output
+  (load "fmt-c.scm")          ; optional C formatting utilities
+  (load "fmt-color.scm")      ; optional color utilities
+  (load "fmt-unicode.scm")    ; optional Unicode-aware formatting,
+                              ;   also requires SRFI-4 or SRFI-66
+
+

+ +

3  Background

+ +There are several approaches to text formatting. Building strings to +display is not acceptable, since it doesn't scale to very large +output. The simplest realistic idea, and what people resort to in +typical portable Scheme, is to interleave display and write +and manual loops, but this is both extremely verbose and doesn't +compose well. A simple concept such as padding space can't be +achieved directly without somehow capturing intermediate output. +

+ +The traditional approach is to use templates - typically strings, +though in theory any object could be used and indeed Emacs' mode-line +format templates allow arbitrary sexps. Templates can use either +escape sequences (as in C's printf and CL's +format) or pattern matching (as in Visual Basic's Format, +Perl6's form, and SQL date formats). The +primary disadvantage of templates is the relative difficulty (usually +impossibility) of extending them, their opaqueness, and the +unreadability that arises with complex formats. Templates are not +without their advantages, but they are already addressed by other +libraries such as SRFI-28 and +SRFI-48. +

+ +This library takes a combinator approach. Formats are nested chains +of closures, which are called to produce their output as needed. +The primary goal of this library is to have, first and foremost, a +maximally expressive and extensible formatting library. The next +most important goal is scalability - to be able to handle +arbitrarily large output and not build intermediate results except +where necessary. The third goal is brevity and ease of use. +

+ +

4  Usage

+ +The primary interface is the fmt procedure: +

+ +(fmt <output-dest> <format> ...) +

+ +where <output-dest> has the same semantics as with format - +specifically it can be an output-port, #t to indicate the current +output port, or #f to accumulate output into a string. +

+ +Each <format> should be a format closure as discussed below. As a +convenience, non-procedure arguments are also allowed and are +formatted similar to display, so that +

+ +(fmt #f "Result: " res nl) +

+ +would return the string "Result: 42n", assuming RES is bound +to 42. +

+ +nl is the newline format combinator. +

+ +

5  Specification

+ +The procedure names have gone through several variations, and I'm +still open to new suggestions. The current approach is to use +abbreviated forms of standard output procedures when defining an +equivalent format combinator (thus display becomes dsp and +write becomes wrt), and to use an fmt- prefix for +utilities and less common combinators. Variants of the same formatter +get a /<variant> suffix. +

+ +

5.1  Formatting Objects

+ +

(dsp <obj>)

+ +Outputs <obj> using display semantics. Specifically, strings +are output without surrounding quotes or escaping and characters are +written as if by write-char. Other objects are written as with +write (including nested strings and chars inside <obj>). This +is the default behavior for top-level formats in fmt, cat and +most other higher-order combinators. +

+ +

(wrt <obj>)

+ +Outputs <obj> using write semantics. Handles shared +structures as in SRFI-38. +

+ +

(wrt/unshared <obj>)

+ +As above, but doesn't handle shared structures. Infinite loops can +still be avoided if used inside a combinator that truncates data (see +trim and fit below). +

+ +

(pretty <obj>)

+ +Pretty-prints <obj>. Also handles shared structures. Unlike many +other pretty printers, vectors and data lists (lists that don't begin +with a (nested) symbol), are printed in tabular format when there's +room, greatly saving vertical space. +

+ +

(pretty/unshared <obj>)

+ +As above but without sharing. +

+ +

(slashified <str> [<quote-ch> <esc-ch> <renamer>])

+ +Outputs the string <str>, escaping any quote or escape characters. +If <esc-ch> is #f escapes only the <quote-ch> by +doubling it, as in SQL strings and CSV values. If <renamer> is +provided, it should be a procedure of one character which maps that +character to its escape value, e.g. #\newline => #\n, or #f if +there is no escape value. +

+ +(fmt #f (slashified "hi, "bob!"")) +

+ +=> "hi, "bob!"" +

+ +

(maybe-slashified <str> <pred> [<quote-ch> <esc-ch> <renamer>])

+ +Like slashified, but first checks if any quoting is required (by +the existence of either any quote or escape characters, or any +character matching <pred>), and if so outputs the string in quotes +and with escapes. Otherwise outputs the string as is. +

+ +(fmt #f (maybe-slashified "foo" char-whitespace? #\")) +

+ +=> "foo" +

+ +(fmt #f (maybe-slashified "foo bar" char-whitespace? #\")) +

+ +=> ""foo bar"" +

+ +(fmt #f (maybe-slashified "foo"bar"baz" char-whitespace? #\")) +

+ +=> ""foo"bar"baz"" +

+ +

5.2  Formatting Numbers

+ +

(num <n> [<radix> <precision> <sign> <comma> <comma-sep> <decimal-sep>])

+ +Formats a single number <n>. You can optionally specify any +<radix> from 2 to 36 (even if <n> isn't an integer). +<precision> forces a fixed-point format. +

+ +A <sign> of #t indicates to output a plus sign (+) for positive +integers. However, if <sign> is a character, it means to wrap the +number with that character and its mirror opposite if the number is +negative. For example, #\( prints negative numbers in parenthesis, +financial style: -3.14 => (3.14) +

+ +<comma> is an integer specifying the number of digits between +commas. Variable length, as in subcontinental-style, is not yet +supported. +

+ +<comma-sep> is the character to use for commas, defaulting to #\,. +

+ +<decimal-sep> is the character to use for decimals, defaulting to +#\., or to #\, (European style) if <comma-sep> is already +#\.. +

+ +These parameters may seem unwieldy, but they can also take their +defaults from state variables, described below. +

+ +

(num/comma <n> [<base> <precision> <sign>])

+ +Shortcut for num to print with commas. +

+ +(fmt #f (num/comma 1234567)) +

+ +=> "1,234,567" +

+ +

(num/si <n> [<base> <suffix>])

+ +Abbreviates <n> with an SI suffix as in the -h or --si option to +many GNU commands. The base defaults to 1024, using suffix names +like Ki, Mi, Gi, etc. Other bases (e.g. the standard 1000) have the +suffixes k, M, G, etc. +

+ +The <suffix> argument is appended only if an abbreviation is used. +

+ +(fmt #f (num/si 608)) +

+ +=> "608" +

+ +(fmt #f (num/si 3986)) +

+ +=> "3.9Ki" +

+ +(fmt #f (num/si 3986 1000 "B")) +

+ +=> "4kB" +

+ +See http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html. +

+ +

(num/fit <width> <n> . <ARGS>)

+ +Like num, but if the result doesn't fit in <width>, output +instead a string of hashes (with the current <precision>) rather +than showing an incorrectly truncated number. For example +

+ +(fmt #f (fix 2 (num/fit 4 12.345))) + => "#.##" +

+ +

(num/roman <n>)

+ +Formats the number as a Roman numeral: +

+ +(fmt #f (num/roman 1989)) + => "MCMLXXXIX" +

+ +

(num/old-roman <n>)

+ +Formats the number as an old-style Roman numeral, without the +subtraction abbreviation rule: +

+ +(fmt #f (num/old-roman 1989)) + => "MDCCCCLXXXVIIII" +

+ +

5.3  Formatting Space

+ +

nl

+ +Outputs a newline. +

+ +

fl

+ +Short for "fresh line," outputs a newline only if we're not already +at the start of a line. +

+ +

(space-to <column>)

+ +Outputs spaces up to the given <column>. If the current column is +already >= <column>, does nothing. +

+ +

(tab-to [<tab-width>])

+ +Outputs spaces up to the next tab stop, using tab stops of width +<tab-width>, which defaults to 8. If already on a tab stop, does +nothing. If you want to ensure you always tab at least one space, you +can use (cat " " (tab-to width)). +

+ +

fmt-null

+ +Outputs nothing (useful in combinators and as a default noop in +conditionals). +

+ +

5.4  Concatenation

+ +

(cat <format> ...)

+ +Concatenates the output of each <format>. +

+ +

(apply-cat <list>)

+ +Equivalent to (apply cat <list>) but may be more efficient. +

+ +

(fmt-join <formatter> <list> [<sep>])

+ +Formats each element <elt> of <list> with (<formatter> +<elt>), inserting <sep> in between. <sep> defaults to the +empty string, but can be any format. +

+ +(fmt #f (fmt-join dsp '(a b c) ", ")) +

+ +=> "a, b, c" +

+ +

(fmt-join/prefix <formatter> <list> [<sep>])

+ +

(fmt-join/suffix <formatter> <list> [<sep>])

+ +(fmt #f (fmt-join/prefix dsp '(usr local bin) "/")) +

+ +=> "/usr/local/bin" +

+ +As fmt-join, but inserts <sep> before/after every element. +

+ +

(fmt-join/last <formatter> <last-formatter> <list> [<sep>])

+ +As fmt-join, but the last element of the list is formatted with +<last-formatter> instead. +

+ +

(fmt-join/dot <formatter> <dot-formatter> <list> [<sep>])

+ +As fmt-join, but if the list is a dotted list, then formats the dotted +value with <dot-formatter> instead. +

+ +

5.5  Padding and Trimming

+ +

(pad <width> <format> ...)

+ +

(pad/left <width> <format> ...)

+ +

(pad/both <width> <format> ...)

+ +Analogs of SRFI-13 string-pad, these add extra space to the left, +right or both sides of the output generated by the <format>s to +pad it to <width>. If <width> is exceeded has no effect. +pad/both will include an extra space on the right side of the +output if the difference is odd. +

+ +pad does not accumulate any intermediate data. +

+ +Note these are column-oriented padders, so won't necessarily work +with multi-line output (padding doesn't seem a likely operation for +multi-line output). +

+ +

(trim <width> <format> ...)

+ +

(trim/left <width> <format> ...)

+ +

(trim/both <width> <format> ...)

+ +Analogs of SRFI-13 string-trim, truncates the output of the +<format>s to force it in under <width> columns. As soon as +any of the <format>s exceed <width>, stop formatting and +truncate the result, returning control to whoever called trim. If +<width> is not exceeded has no effect. +

+ +If a truncation ellipse is set (e.g. with the ellipses procedure +below), then when any truncation occurs trim and trim/left +will append and prepend the ellipse, respectively. trim/both will +both prepend and append. The length of the ellipse will be considered +when truncating the original string, so that the total width will +never be longer than <width>. +

+ +(fmt #f (ellipses "..." (trim 5 "abcde"))) +

+ +=> "abcde" +

+ +(fmt #f (ellipses "..." (trim 5 "abcdef"))) +

+ +=> "ab..." +

+ +

(trim/length <width> <format> ...)

+ +A variant of trim which acts on the actual character count rather +than columns, useful for truncating potentially cyclic data. +

+ +

(fit <width> <format> ...)

+ +

(fit/left <width> <format> ...)

+ +

(fit/both <width> <format> ...)

+ +A combination of pad and trunc, ensures the output width is +exactly <width>, truncating if it goes over and padding if it goes +under. +

+ +

5.6  Format Variables

+ +You may have noticed many of the formatters are aware of the current +column. This is because each combinator is actually a procedure of +one argument, the current format state, which holds basic +information such as the row, column, and any other information that +a format combinator may want to keep track of. The basic interface +is: +

+ +

(fmt-let <name> <value> <format> ...)

+ +

(fmt-bind <name> <value> <format> ...)

+ +fmt-let sets the name for the duration of the <format>s, and +restores it on return. fmt-bind sets it without restoring it. +

+ +A convenience control structure can be useful in combination with +these states: +

+ +

(fmt-if <pred> <pass> [<fail>])

+ +<pred> takes one argument (the format state) and returns a boolean +result. If true, the <pass> format is applied to the state, +otherwise <fail> (defaulting to the identity) is applied. +

+ +Many of the previously mentioned combinators have behavior which can +be altered with state variables. Although fmt-let and fmt-bind +could be used, these common variables have shortcuts: +

+ +

(radix <k> <format> ...)

+ +

(fix <k> <format> ...)

+ +These alter the radix and fixed point precision of numbers output with +dsp, wrt, pretty or num. These settings apply +recursively to all output data structures, so that +

+ +(fmt #f (radix 16 '(70 80 90))) +

+ +will return the string "(#x46 #x50 #x5a)". Note that read/write +invariance is essential, so for dsp, wrt and pretty the +radix prefix is always included when not decimal. Use num if you +want to format numbers in alternate bases without this prefix. For +example, +

+ +(fmt #f (radix 16 "(" (fmt-join num '(70 80 90) " ") ")")) +

+ +would return "(46 50 5a)", the same output as above without the +"#x" radix prefix. +

+ +Note that fixed point formatting supports arbitrary precision in +implementations with exact non-integral rationals. When trying to +print inexact numbers more than the machine precision you will +typically get results like +

+ +(fmt #f (fix 30 #i2/3)) +

+ +=> "0.666666666666666600000000000000" +

+ +but with an exact rational it will give you as many digits as you +request: +

+ +(fmt #f (fix 30 2/3)) +

+ +=> "0.666666666666666666666666666667" +

+ +

(decimal-align <k> <format> ...)

+ +Specifies an alignment for the decimal place when formatting numbers, +useful for outputting tables of numbers. +

+ +

+  (define (print-angles x)
+     (fmt-join num (list x (sin x) (cos x) (tan x)) " "))
+
+  (fmt #t (decimal-align 5 (fix 3 (fmt-join/suffix print-angles (iota 5) nl))))
+
+

+ +would output +

+ +

+   0.000    0.000    1.000    0.000
+   1.000    0.842    0.540    1.557
+   2.000    0.909   -0.416   -2.185
+   3.000    0.141   -0.990   -0.142
+   4.000   -0.757   -0.654    1.158
+
+

+ +

(comma-char <k> <format> ...)

+ +

(decimal-char <k> <format> ...)

+ +comma-char and decimal-char set the defaults for number +formatting. +

+ +

(pad-char <k> <format> ...)

+ +The pad-char sets the character used by space-to, tab-to, +pad/*, and fit/*, and defaults to #\space. +

+ +

+  (define (print-table-of-contents alist)
+    (define (print-line x)
+      (cat (car x) (space-to 72) (pad/left 3 (cdr x))))
+    (fmt #t (pad-char #\. (fmt-join/suffix print-line alist nl))))
+
+  (print-table-of-contents
+   '(("An Unexpected Party" . 29)
+     ("Roast Mutton" . 60)
+     ("A Short Rest" . 87)
+     ("Over Hill and Under Hill" . 100)
+     ("Riddles in the Dark" . 115)))
+
+

+ +would output +

+ +

+  An Unexpected Party.....................................................29
+  Roast Mutton............................................................60
+  A Short Rest............................................................87
+  Over Hill and Under Hill...............................................100
+  Riddles in the Dark....................................................115
+
+

+ +

(ellipse <ell> <format> ...)

+ +Sets the truncation ellipse to <ell>, would should be a string or +character. +

+ +

(with-width <width> <format> ...)

+ +Sets the maximum column width used by some formatters. The default +is 78. +

+ +

5.7  Columnar Formatting

+ +Although tab-to, space-to and padding can be used to manually +align columns to produce table-like output, these can be awkward to +use. The optional extensions in this section make this easier. +

+ +

(columnar <column> ...)

+ +Formats each <column> side-by-side, i.e. as though each were +formatted separately and then the individual lines concatenated +together. The current column width is divided evenly among the +columns, and all but the last column are right-padded. For example +

+ +(fmt #t (columnar (dsp "abcndefn") (dsp "123n456n"))) +

+ +outputs +

+ +

+     abc     123
+     def     456
+
+

+ +assuming a 16-char width (the left side gets half the width, or 8 +spaces, and is left aligned). Note that we explicitly use DSP instead +of the strings directly. This is because columnar treats raw +strings as literals inserted into the given location on every line, to +be used as borders, for example: +

+ +

+  (fmt #t (columnar "/* " (dsp "abcndefn")
+                    " | " (dsp "123n456n")
+                    " */"))
+
+

+ +would output +

+ +

+  /* abc | 123 */
+  /* def | 456 */
+
+

+ +You may also prefix any column with any of the symbols 'left, +'right or 'center to control the justification. The symbol +'infinite can be used to indicate the column generates an infinite +stream of output. +

+ +You can further prefix any column with a width modifier. Any +positive integer is treated as a fixed width, ignoring the available +width. Any real number between 0 and 1 indicates a fraction of the +available width (after subtracting out any fixed widths). Columns +with unspecified width divide up the remaining width evenly. +

+ +Note that columnar builds its output incrementally, interleaving +calls to the generators until each has produced a line, then +concatenating that line together and outputting it. This is important +because as noted above, some columns may produce an infinite stream of +output, and in general you may want to format data larger than can fit +into memory. Thus columnar would be suitable for line numbering a +file of arbitrary size, or implementing the Unix yes(1) command, +etc. +

+ +As an implementation detail, columnar uses first-class +continuations to interleave the column output. The core fmt +itself has no knowledge of or special support for columnar, which +could complicate and potentially slow down simpler fmt operations. +This is a testament to the power of call/cc - it can be used to +implement coroutines or arbitrary control structures even where they +were not planned for. +

+ +

(tabular <column> ...)

+ +Equivalent to columnar except that each column is padded at least +to the minimum width required on any of its lines. Thus +

+ +(fmt #t (tabular "|" (dsp "a\\nbc\\ndef\\n") "|" (dsp "123n45n6n") "|")) +

+ +outputs +

+ +

+|a  |123|
+|bc |45 |
+|def|6  |
+
+

+ +This makes it easier to generate tables without knowing widths in +advance. However, because it requires generating the entire output in +advance to determine the correct column widths, tabular cannot +format a table larger than would fit in memory. +

+ +

(fmt-columns <column> ...)

+ +The low-level formatter on which columnar is based. Each <column> +must be a list of 2-3 elements: +

+ +(<line-formatter> <line-generator> [<infinite?>]) +

+ +where <line-generator> is the column generator as above, and the +<line-formatter> is how each line is formatted. Raw concatenation +of each line is performed, without any spacing or width adjustment. +<infinite?>, if true, indicates this generator produces an +infinite number of lines and termination should be determined without +it. +

+ +

(wrap-lines <format> ...)

+ +Behaves like cat, except text is accumulated and lines are optimally +wrapped to fit in the current width as in the Unix fmt(1) command. +

+ +

(justify <format> ...)

+ +Like wrap-lines except the lines are full-justified. +

+ +

+  (define func
+    '(define (fold kons knil ls)
+       (let lp ((ls ls) (acc knil))
+         (if (null? ls) acc (lp (cdr ls) (kons (car ls) acc))))))
+
+  (define doc
+    (string-append
+      "The fundamental list iterator.  Applies KONS to each element "
+      "of LS and the result of the previous application, beginning "
+      "with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))
+
+  (fmt #t (columnar (pretty func) " ; " (justify doc)))
+
+

+ +outputs +

+ +

+  (define (fold kons knil ls)          ; The   fundamental   list   iterator.
+    (let lp ((ls ls) (acc knil))       ; Applies  KONS  to  each  element  of
+      (if (null? ls)                   ; LS  and  the  result of the previous
+          acc                          ; application,  beginning  with  KNIL.
+          (lp (cdr ls)                 ; With  KONS  as CONS and KNIL as '(),
+              (kons (car ls) acc)))))  ; equivalent to REVERSE.
+
+

+ +

(fmt-file <pathname>)

+ +Simply displayes the contents of the file <pathname> a line at a +time, so that in typical formatters such as columnar only constant +memory is consumed, making this suitable for formatting files of +arbitrary size. +

+ +

(line-numbers [<start>])

+ +A convenience utility, just formats an infinite stream of numbers (in +the current radix) beginning with <start>, which defaults to 1. +

+ +The Unix nl(1) utility could be implemented as: +

+ +

+  (fmt #t (columnar 6 'right 'infinite (line-numbers)
+                    " " (fmt-file "read-line.scm")))
+
+

+ +

+     1 
+     2 (define (read-line . o)
+     3   (let ((port (if (pair? o) (car o) (current-input-port))))
+     4     (let lp ((res '()))
+     5       (let ((c (read-char port)))
+     6         (if (or (eof-object? c) (eqv? c #\newline))
+     7             (list->string (reverse res))
+     8             (lp (cons c res)))))))
+
+

+ +

6  C Formatting

+ +

6.1  C Formatting Basics

+ +For purposes such as writing wrappers, code-generators, compilers or +other language tools, people often need to generate or emit C code. +Without a decent library framework it's difficult to maintain proper +indentation. In addition, for the Scheme programmer it's tedious to +work with all the context sensitivities of C, such as the expression +vs. statement distinction, special rules for writing preprocessor +macros, and when precedence rules require parenthesis. Fortunately, +context is one thing this formatting library is good at keeping +track of. The C formatting interface tries to make it as easy as +possible to generate C code without getting in your way. +

+ +There are two approaches to using the C formatting extensions - +procedural and sexp-oriented (described in 6.7). In the +procedural interface, C operators are made available as formatters +with a "c-" prefix, literals are converted to their C equivalents and +symbols are output as-is (you're responsible for making sure they are +valid C identifiers). Indentation is handled automatically. +

+ +(fmt #t (c-if 1 2 3)) +

+ +outputs +

+ +

+  if (1) {
+      2;
+  } else {
+      3;
+  }
+
+

+ +In addition, the formatter knows when you're in an expression and +when you're in a statement, and behaves accordingly, so that +

+ +(fmt #t (c-if (c-if 1 2 3) 4 5)) +

+ +outputs +

+ +

+  if (1 ? 2 : 3) {
+      4;
+  } else {
+      5;
+  }
+
+

+ +Similary, c-begin, used for sequencing, will separate with +semi-colons in a statement and commas in an expression. +

+ +Moreover, we also keep track of the final expression in a function +and insert returns for you: +

+ +(fmt #t (c-fun 'int 'foo '() (c-if (c-if 1 2 3) 4 5))) +

+ +outputs +

+ +

+  int foo () {
+      if (1 ? 2 : 3) {
+          return 4;
+      } else {
+          return 5;
+      }
+  }
+
+

+ +although it knows that void functions don't return. +

+ +Switch statements insert breaks by default if they don't return: +

+ +

+  (fmt #t (c-switch 'y
+            (c-case 1 (c+= 'x 1))
+            (c-default (c+= 'x 2))))
+
+

+ +

+  switch (y) {
+      case 1:
+          x += 1;
+          break;
+      default:
+          x += 2;
+          break;
+  }
+
+

+ +though you can explicitly fallthrough if you want: +

+ +

+  (fmt #t (c-switch 'y
+            (c-case/fallthrough 1 (c+= 'x 1))
+            (c-default (c+= 'x 2))))
+
+

+ +

+  switch (y) {
+      case 1:
+          x += 1;
+      default:
+          x += 2;
+          break;
+  }
+
+

+ +Operators are available with just a "c" prefix, e.g. c+, c-, c*, c/, +etc. c++ is a prefix operator, c++/post is postfix. ||, | and +|= are written as c-or, c-bit-or and c-bit-or= respectively. +

+ +Function applications are written with c-apply. Other control +structures such as c-for and c-while work as expected. The full +list is in the procedure index below. +

+ +When a C formatter encounters an object it doesn't know how to write +(including lists and records), it outputs them according to the +format state's current 'gen variable. This allows you to specify +generators for your own types, e.g. if you are using your own AST +records in a compiler. +

+ +If the 'gen variable isn't set it defaults to the c-expr/sexp +procedure, which formats an s-expression as if it were C code. Thus +instead of c-apply you can just use a list. The full API is +available via normal s-expressions - formatters that aren't keywords +in C are prefixed with a % or otherwise made invalid C identifiers so +that they can't be confused with function application. +

+ +

6.2  C Preprocessor Formatting

+ +C preprocessor formatters also properly handle their surrounding +context, so you can safely intermix them in the normal flow of C +code. +

+ +

+  (fmt #t (c-switch 'y
+            (c-case 1 (c= 'x 1))
+            (cpp-ifdef 'H_TWO (c-case 2 (c= 'x 4)))
+            (c-default (c= 'x 5))))
+
+

+ +

+  switch (y) {
+      case 1:
+          x = 1;
+          break;
+
+  #ifdef H_TWO
+      case 2:
+          x = 4;
+          break;
+  #endif /* H_TWO */
+      default:
+          x = 5;
+          break;
+  }
+
+

+ +Macros can be handled with cpp-define, which knows to wrap +individual variable references in parenthesis: +

+ +(fmt #t (cpp-define '(min x y) (c-if (c< 'x 'y) 'x 'y))) +

+ +

+  #define min(x, y) (((x) < (y)) ? (x) : (y))
+
+

+ +As with all C formatters, the CPP output is pretty printed as +needed, and if it wraps over several lines the lines are terminated +with a backslash. +

+ +To write a C header file that is included at most once, you can wrap +the entire body in cpp-wrap-header: +

+ +

+  (fmt #t (cpp-wrap-header "FOO_H"
+            (c-extern (c-prototype 'int 'foo '()))))
+
+

+ +

+  #ifndef FOO_H
+  #define FOO_H
+
+  extern int foo ();
+
+  #endif /* ! FOO_H */
+
+

+ +

6.3  Customizing C Style

+ +The output uses a simplified K&R style with 4 spaces for indentation +by default. The following state variables let you override the +style: +

+ +

'indent-space

+ +how many spaces to indent bodies, default 4 +

+ +

'switch-indent-space

+ +how many spaces to indent switch clauses, also defaults to 4 +

+ +

'newline-before-brace?

+ +insert a newline before an open brace (non-K&R), defaults to #f +

+ +

'braceless-bodies?

+ +omit braces when we can prove they aren't needed +

+ +

'non-spaced-ops?

+ +omit spaces between operators and operands for groups of variables and +literals (e.g. "a+b+3" instead of "a + b + 3"} +

+ +

'no-wrap?

+ +Don't wrap function calls and long operator groups over mulitple +lines. Functions and control structures will still use multiple +lines. +

+ +The C formatters also respect the 'radix and 'precision settings. +

+ +

6.4  C Formatter Index

+ +

(c-if <condition> <pass> [<fail> [<condition2> <pass2> ...]])

+ +Print a chain of if/else conditions. Use a final condition of 'else +for a final else clause. +

+ +

(c-for <init> <condition> <update> <body> ...)

+ +

(c-while <condition> <body> ...)

+ +Basic loop constructs. +

+ +

(c-fun <type> <name> <params> <body> ...)

+ +

(c-prototype <type> <name> <params>)

+ +Output a function or function prototype. The parameters should be a +list 2-element lists of the form (<param-type> <param-name>), +which are output with DSP. A parameter can be abbreviated as just the +symbol name, or #f can be passed as the type, in which case the +'default-type state variable is used. The parameters may be a +dotted list, in which case ellipses for a C variadic are inserted - +the actual name of the dotted value is ignored. +

+ +Types are just typically just symbols, or lists of symbols such as +'(const char). A complete description is given below in section +6.6. +

+ +These can also accessed as %fun and %prototype at the head of a list. +

+ +

(c-var <type> <name> [<init-value>])

+ +Declares and optionally initializes a variable. Also accessed as %var +at the head of a list. +

+ +

(c-begin <expr> ...)

+ +Outputs each of the <expr>s, separated by semi-colons if in a +statement or commas if in an expression. +

+ +

(c-switch <clause> ...)

+ +

(c-case <values> <body> ...)

+ +

(c-case/fallthrough <values> <body> ...)

+ +

(c-default <body> ...)

+ +Switch statements. In addition to using the clause formatters, +clauses inside a switch may be handled with a Scheme CASE-like list, +with the car a list of case values and the cdr the body. +

+ +

(c-label <name>)

+ +

(c-goto <name>)

+ +

(c-return [<result>])

+ +

c-break

+ +

c-continue

+ +Manual labels and jumps. Labels can also be accessed as a list +beginning with a colon, e.g. '(: label1). +

+ +

(c-const <expr>)

+ +

(c-static <expr>)

+ +

(c-volatile <expr>)

+ +

(c-restrict <expr>)

+ +

(c-register <expr>)

+ +

(c-auto <expr>)

+ +

(c-inline <expr>)

+ +

(c-extern <expr>)

+ +Declaration modifiers. May be nested. +

+ +

(c-extern/C <body> ...)

+ +Wraps body in an extern "C" { ... } for use with C++. +

+ +

(c-cast <type> <expr>)

+ +Casts an expression to a type. Also %cast at the head of a list. +

+ +

(c-typedef <type> <new-name> ...)

+ +Creates a new type definition with one or more names. +

+ +

(c-struct [<name>] <field-list> [<attributes>])

+ +

(c-union [<name>] <field-list> [<attributes>])

+ +

(c-class [<name>] <field-list> [<attributes>])

+ +

(c-attribute <values> ...)

+ +Composite type constructors. Attributes may be accessed as +%attribute at the head of a list. +

+ +

+  (fmt #f (c-struct 'employee
+                      '((short age)
+                        ((char *) name)
+                        ((struct (year month day)) dob))
+                      (c-attribute 'packed)))
+
+

+ +

+  struct employee {
+      short age;
+      char* name;
+      struct {
+          int year;
+          int month;
+          int day;
+      } dob;
+  } __attribute__ ((packed));
+
+

+ +

(c-enum [<name>] <enum-list>)

+ +Enumerated types. <enum-list> may be strings, symbols, or lists of +string or symbol followed by the enum's value. +

+ +

(c-comment <formatter> ...)

+ +Outputs the <formatter>s wrapped in C's /* ... */ comment. Properly +escapes nested comments inside in an Emacs-friendly style. +

+ +

6.5  C Preprocessor Formatter Index

+ +

(cpp-include <file>)

+ +If file is a string, outputs in it "quotes", otherwise (as a symbol +or arbitrary formatter) it outputs it in brackets. +

+ +(fmt #f (cpp-include 'stdio.h)) +

+ +=> "#include <stdio.h>n" +

+ +(fmt #f (cpp-include "config.h")) +

+ +=> "#include "config.h"n" +

+ +

(cpp-define <macro> [<value>])

+ +Defines a preprocessor macro, which may be just a name or a list of +name and parameters. Properly wraps the value in parenthesis and +escapes newlines. A dotted parameter list will use the C99 variadic +macro syntax, and will also substitute any references to the dotted +name with __VA_ARGS__: +

+ +(fmt #t (cpp-define '(eprintf . args) '(fprintf stderr args))) +

+ +

+  #define eprintf(...) (fprintf(stderr, __VA_ARGS__))
+
+

+ +

(cpp-if <condition> <pass> [<fail> ...])

+ +

(cpp-ifdef <condition> <pass> [<fail> ...])

+ +

(cpp-ifndef <condition> <pass> [<fail> ...])

+ +

(cpp-elif <condition> <pass> [<fail> ...])

+ +

(cpp-else <body> ...)

+ +Conditional compilation. +

+ +

(cpp-line <num> [<file>])

+ +Line number information. +

+ +

(cpp-pragma <args> ...)

+ +

(cpp-error <args> ...)

+ +

(cpp-warning <args> ...)

+ +Additional preprocessor directives. +

+ +

(cpp-stringify <expr>)

+ +Stringifies <expr> by prefixing the # operator. +

+ +

(cpp-sym-cat <args> ...)

+ +Joins the <args> into a single preprocessor token with the ## +operator. +

+ +

(cpp-wrap-header <name> <body> ...)

+ +Wrap an entire header to only be included once. +

+ +

Operators:

+ +
+c++ c-- c+ c- c* c/ c% c& c^ c~ c! c&& c<< c>> c== c!=
+c< c> c<= c>= c= c+= c-= c*= c/= c%= c&= c^= c<<= c>>=
+c++/post c--/post c-or c-bit-or c-bit-or=
+
+

+ +

6.6  C Types

+ + +

+ +Typically a type is just a symbol such as 'char or 'int. You +can wrap types with modifiers such as c-const, but as a +convenience you can just use a list such as in '(const unsignedchar *). +You can also nest these lists, so the previous example is +equivalent to '(* (const (unsigned char))). +

+ +Pointers may be written as '(%pointer <type>) for readability - +%pointer is exactly equivalent to * in types. +

+ +Unamed structs, classes, unions and enums may be used directly as +types, using their respective keywords at the head of a list. +

+ +Two special types are the %array type and function pointer type. An +array is written: +

+ +(%array <type> [<size>]) +

+ +where <type> is any other type (including another array or +function pointer), and <size>, if given, will print the array +size. For example: +

+ +(c-var '(%array (unsigned long) SIZE) 'table '#(1 2 3 4)) +

+ +

+unsigned long table[SIZE] = {1, 2, 3, 4};
+
+

+ +A function pointer is written: +

+ +(%fun <return-type> (<param-types> ...)) +

+ +For example: +

+ +(c-typedef '(%fun double (double double int)) 'f) +

+ +

+typedef double (*f)(double, double, int);
+
+

+ +Wherever a type is expected but not given, the value of the +'default-type formatting state variable is used. By default this +is just 'int. +

+ +Type declarations work uniformly for variables and parameters, as well +for casts and typedefs. +

+ +

6.7  C as S-Expressions

+ + +

+ +Rather than building formatting closures by hand, it can be more +convenient to just build a normal s-expression and ask for it to be +formatted as C code. This can be thought of as a simple Scheme->C +compiler without any runtime support. +

+ +In a s-expression, strings and characters are printed as C strings and +characters, booleans are printed as 0 or 1, symbols are displayed +as-is, and numbers are printed as C numbers (using the current +formatting radix if specified). Vectors are printed as +comma-separated lists wrapped in braces, which can be used for +initializing arrays or structs. +

+ +A list indicates a C expression or statement. Any of the existing C +keywords can be used to pretty-print the expression as described with +the c-keyword formatters above. Thus, the example above +

+ +(fmt #t (c-if (c-if 1 2 3) 4 5)) +

+ +could also be written +

+ +(fmt #t (c-expr '(if (if 1 2 3) 4 5))) +

+ +C constructs that are dependent on the underlying syntax and have no +keyword are written with a % prefix (%fun, %var, %pointer, +%array, %cast), including C preprocessor constructs +(%include, %define, %pragma, %error, %warning, +%if, %ifdef, %ifndef, %elif). Labels are written as +(: <label-name>). You can write a sequence as (%begin <expr> +...). +

+ +For example, the following definition of the fibonacci sequence, which +apart from the return type of #f looks like a Lisp definition: +

+ +(fmt #t (c-expr '(%fun #f fib (n) + (if (<= n 1) + 1 + (+ (fib (- n 1)) (fib (- n 2))))))) +

+ +prints the working C definition: +

+ +

+int fib (int n) {
+    if (n <= 1) {
+        return 1;
+    } else {
+        return fib((n - 1)) + fib((n - 2));
+    }
+}
+
+

+ +

7  JavaScript Formatting

+ +The experimental fmt-js library extends the fmt-c library with +functionality for formatting JavaScript code. +

+ +

(js-expr x)

+ +Formats a JavaScript expression similarly to c-expr. Inside a +js-expr formatter, you can use the normal c- prefixed +formatters described in the previous section, and they will format +appropriately for JavaScript. +

+ +Currently expressions will all be terminated with a semi-colon, but +that will be made optional in a later release. +

+ +

(js-function [<name>] (<params>) <body> ...)

+ +Defines a function (anonymously if no name is provided). +

+ +

(js-var <name> [<init-value>])

+ +Declares a JavaScript variable, optionally with an initial value. +

+ +

(js-comment <formatter> ...)

+ +Formats a comment prefixing lines with "// ". +

+ +

8  Formatting with Color

+ +The fmt-color library provides the following utilities: +

+ +

+  (fmt-red <formatter> ...)
+  (fmt-blue <formatter> ...)
+  (fmt-green <formatter> ...)
+  (fmt-cyan <formatter> ...)
+  (fmt-yellow <formatter> ...)
+  (fmt-magenta <formatter> ...)
+  (fmt-white <formatter> ...)
+  (fmt-black <formatter> ...)
+  (fmt-bold <formatter> ...)
+  (fmt-underline <formatter> ...)
+
+

+ +and more generally +

+ +(fmt-color <color> <formatter> ...) +

+ +where color can be a symbol name or #xRRGGBB numeric value. +Outputs the formatters colored with ANSI escapes. In addition +

+ +(fmt-in-html <formatter> ...) +

+ +can be used to mark the format state as being inside HTML, which the +above color formats will understand and output HTML <span> tags with +the appropriate style colors, instead of ANSI escapes. +

+ +

9  Unicode

+ +The fmt-unicode library provides the fmt-unicode formatter, which +just takes a list of formatters and overrides the string-length for +padding and trimming, such that Unicode double or full width +characters are considered 2 characters wide (as they typically are in +fixed-width terminals), while treating combining and non-spacing +characters as 0 characters wide. +

+ +It also recognizes and ignores ANSI escapes, in particular useful if +you want to combine this with the fmt-color utilities. +

+ +

10  Optimizing

+ +The library is designed for scalability and flexibility, not speed, +and I'm not going to think about any fine tuning until it's more +stabilised. One aspect of the design, however, was influenced for the +sake of future optimizations, which is that none of the default format +variables are initialized by global parameters, which leaves room for +inlining and subsequent simplification of format calls. +

+ +If you don't have an aggressively optimizing compiler, you can easily +achieve large speedups on common cases with CL-style compiler macros. +

+ +

11  Common Lisp Format Cheat Sheet

+ +A quick reference for those of you switching over from Common Lisp's +format. +

+ + + + + + + + + + + + + + + + +
format fmt
~a dsp
~c dsp
~s wrt/unshared
~w wrt
~y pretty
~x (radix 16 ...) or (num <n> 16)
~o (radix 8 ...) or (num <n> 8)
~b (radix 2 ...) or (num <n> 2)
~f (fix <digits> ...) or (num <n> <radix> <digits>)
~% nl
~& fl
~[...~] normal if or fmt-if (delayed test)
~{...~} (fmt-join ... <list> [<sep>])
+

+ +

12  References

+ +[1]  R. Kelsey, W. Clinger, J. Rees (eds.) +Revised^5 Report on the Algorithmic Language Scheme +

+ +[2]  Guy L. Steele Jr. (editor) +Common Lisp Hyperspec +

+ +[3]  Scott G. Miller +SRFI-28 Basic Format Strings +

+ +[4]  Ken Dickey +SRFI-48 Intermediate Format Strings +

+ +[5]  Ray Dillinger +SRFI-38 External Representation for Data With Shared Structure +

+ +[6]  Damian Conway +Perl6 Exegesis 7 - formatting +

+ +



+ + diff --git a/functional-tests/fmt/fmt.scm b/functional-tests/fmt/fmt.scm new file mode 100644 index 0000000..8de7ee7 --- /dev/null +++ b/functional-tests/fmt/fmt.scm @@ -0,0 +1,1211 @@ +;;;; fmt.scm -- extensible formatting library +;; +;; Copyright (c) 2006-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;; (require-extension (srfi 1 6 13 23 69)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; string utilities + +(define (write-to-string x) + (call-with-output-string (lambda (p) (write x p)))) + +(define (display-to-string x) + (if (string? x) + x + (call-with-output-string (lambda (p) (display x p))))) + +(define nl-str + (call-with-output-string newline)) + +(define (make-space n) (make-string n #\space)) +(define (make-nl-space n) (string-append nl-str (make-string n #\space))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; list utilities + +(define (take* ls n) ; handles dotted lists and n > length + (cond ((zero? n) '()) + ((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1)))) + (else '()))) + +(define (drop* ls n) ; may return the dot + (cond ((zero? n) ls) + ((pair? ls) (drop* (cdr ls) (- n 1))) + (else ls))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; format state representation + +;; Use a flexible representation optimized for common cases - +;; frequently accessed values are in fixed vector slots, with a +;; `properties' slot holding an alist for all other values. + +(define *default-fmt-state* + (vector 0 0 10 '() #\space #f 78 #f #f #f #f #f #f)) + +(define fmt-state? vector?) + +(define (new-fmt-state . o) + (let ((st (if (pair? o) (car o) (current-output-port)))) + (if (vector? st) + st + (fmt-set-writer! + (fmt-set-port! (copy-fmt-state *default-fmt-state*) st) + fmt-write)))) + +(define (copy-fmt-state st) + (let* ((len (vector-length st)) + (res (make-vector len))) + (do ((i 0 (+ i 1))) + ((= i len)) + (vector-set! res i (vector-ref st i))) + (fmt-set-properties! res (map (lambda (x) (cons (car x) (cdr x))) + (fmt-properties res))) + res)) + +(define (fmt-row st) (vector-ref st 0)) +(define (fmt-col st) (vector-ref st 1)) +(define (fmt-radix st) (vector-ref st 2)) +(define (fmt-properties st) (vector-ref st 3)) +(define (fmt-pad-char st) (vector-ref st 4)) +(define (fmt-precision st) (vector-ref st 5)) +(define (fmt-width st) (vector-ref st 6)) +(define (fmt-writer st) (vector-ref st 7)) +(define (fmt-port st) (vector-ref st 8)) +(define (fmt-decimal-sep st) (vector-ref st 9)) +(define (fmt-decimal-align st) (vector-ref st 10)) +(define (fmt-string-width st) (vector-ref st 11)) +(define (fmt-ellipses st) (vector-ref st 12)) + +(define (fmt-set-row! st x) (vector-set! st 0 x) st) +(define (fmt-set-col! st x) (vector-set! st 1 x) st) +(define (fmt-set-radix! st x) (vector-set! st 2 x) st) +(define (fmt-set-properties! st x) (vector-set! st 3 x) st) +(define (fmt-set-pad-char! st x) (vector-set! st 4 x) st) +(define (fmt-set-precision! st x) (vector-set! st 5 x) st) +(define (fmt-set-width! st x) (vector-set! st 6 x) st) +(define (fmt-set-writer! st x) (vector-set! st 7 x) st) +(define (fmt-set-port! st x) (vector-set! st 8 x) st) +(define (fmt-set-decimal-sep! st x) (vector-set! st 9 x) st) +(define (fmt-set-decimal-align! st x) (vector-set! st 10 x) st) +(define (fmt-set-string-width! st x) (vector-set! st 11 x) st) +(define (fmt-set-ellipses! st x) (vector-set! st 12 x) st) + +(define (fmt-ref st key . o) + (case key + ((row) (fmt-row st)) + ((col) (fmt-col st)) + ((radix) (fmt-radix st)) + ((properties) (fmt-properties st)) + ((writer) (fmt-writer st)) + ((port) (fmt-port st)) + ((precision) (fmt-precision st)) + ((pad-char) (fmt-pad-char st)) + ((width) (fmt-width st)) + ((decimal-sep) (fmt-decimal-sep st)) + ((decimal-align) (fmt-decimal-align st)) + ((string-width) (fmt-string-width st)) + ((ellipses) (fmt-ellipses st)) + (else (cond ((assq key (fmt-properties st)) => cdr) + ((pair? o) (car o)) + (else #f))))) + +(define (fmt-set-property! st key val) + (cond ((assq key (fmt-properties st)) + => (lambda (cell) (set-cdr! cell val) st)) + (else (fmt-set-properties! + st + (cons (cons key val) (fmt-properties st)))))) + +(define (fmt-set! st key val) + (case key + ((row) (fmt-set-row! st val)) + ((col) (fmt-set-col! st val)) + ((radix) (fmt-set-radix! st val)) + ((properties) (fmt-set-properties! st val)) + ((pad-char) (fmt-set-pad-char! st val)) + ((precision) (fmt-set-precision! st val)) + ((writer) (fmt-set-writer! st val)) + ((port) (fmt-set-port! st val)) + ((width) (fmt-set-width! st val)) + ((decimal-sep) (fmt-set-decimal-sep! st val)) + ((decimal-align) (fmt-set-decimal-align! st val)) + ((string-width) (fmt-set-string-width! st val)) + ((ellipses) (fmt-set-ellipses! st val)) + (else (fmt-set-property! st key val)))) + +(define (fmt-add-properties! st alist) + (for-each (lambda (x) (fmt-set! st (car x) (cdr x))) alist) + st) + +(define (fmt-let key val . ls) + (lambda (st) + (let ((orig-val (fmt-ref st key))) + (fmt-set! ((apply-cat ls) (fmt-set! st key val)) key orig-val)))) + +(define (fmt-bind key val . ls) + (lambda (st) ((apply-cat ls) (fmt-set! st key val)))) + +(define (fix prec . ls) (fmt-let 'precision prec (apply-cat ls))) +(define (radix rad . ls) (fmt-let 'radix rad (apply-cat ls))) +(define (pad-char ch . ls) (fmt-let 'pad-char ch (apply-cat ls))) +(define (comma-char ch . ls) (fmt-let 'comma-char ch (apply-cat ls))) +(define (decimal-char ch . ls) (fmt-let 'decimal-sep ch (apply-cat ls))) +(define (decimal-align n . ls) (fmt-let 'decimal-align n (apply-cat ls))) +(define (with-width w . ls) (fmt-let 'width w (apply-cat ls))) +(define (ellipses ell . ls) (fmt-let 'ellipses ell (apply-cat ls))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; the basic interface + +(define (fmt-start st initializer proc) + (cond + ((or (output-port? st) (fmt-state? st)) + (proc (initializer st)) + (if #f #f)) + ((eq? #t st) + (proc (initializer (current-output-port))) + (if #f #f)) + ((eq? #f st) + (get-output-string + (fmt-port (proc (initializer (open-output-string)))))) + (else (error "unknown format output" st)))) + +(define (fmt st . args) + (fmt-start st new-fmt-state (apply-cat args))) + +(define (fmt-update str st) + (let ((len (string-length str)) + (nli (string-index-right str #\newline)) + (str-width (fmt-string-width st))) + (if nli + (let ((row (+ (fmt-row st) 1 (string-count str #\newline 0 nli)))) + (fmt-set-row! + (fmt-set-col! st (if str-width + (str-width str (+ nli 1) len) + (- len (+ nli 1)))) + row)) + (fmt-set-col! st (+ (fmt-col st) + (if str-width + (str-width str 0 len) + len)))))) + +(define (fmt-write str st) + (display str (fmt-port st)) + (fmt-update str st)) + +(define (apply-cat procs) + (lambda (st) + (let loop ((ls procs) (st st)) + (if (null? ls) + st + (loop (cdr ls) ((dsp (car ls)) st)))))) + +(define (cat . ls) (apply-cat ls)) + +(define (fmt-null st) st) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; control structures + +(define (fmt-if check pass . o) + (let ((fail (if (pair? o) (car o) (lambda (x) x)))) + (lambda (st) (if (check st) ((dsp pass) st) ((dsp fail) st))))) + +(define (fmt-try-fit proc . fail) + (if (null? fail) + proc + (lambda (orig-st) + (let ((width (fmt-width orig-st)) + (buffer '())) + (call-with-current-continuation + (lambda (return) + (define (output* str st) + (let lp ((i 0) (col (fmt-col st))) + (let ((nli (string-index str #\newline i))) + (if nli + (if (> (+ (- nli i) col) width) + (return ((apply fmt-try-fit fail) orig-st)) + (lp (+ nli 1) 0)) + (let* ((len ((or (fmt-string-width st) string-length) + str)) + (col (+ (- len i) col))) + (if (> col width) + (return ((apply fmt-try-fit fail) orig-st)) + (begin + (set! buffer (cons str buffer)) + (fmt-update str st)))))))) + (proc (fmt-set-port! (fmt-set-writer! (copy-fmt-state orig-st) + output*) + (open-output-string))) + ((fmt-writer orig-st) + (string-concatenate-reverse buffer) + orig-st))))))) + +(define (fits-in-width gen width) + (lambda (st) + (let ((output (fmt-writer st)) + (port (open-output-string))) + (call-with-current-continuation + (lambda (return) + (define (output* str st) + (let ((st (fmt-update str st))) + (if (> (fmt-col st) width) + (return #f) + (begin + (display str port) + st)))) + (gen (fmt-set-port! (fmt-set-writer! (copy-fmt-state st) output*) + port)) + (get-output-string port)))))) + +(define (fits-in-columns ls write width) + (lambda (st) + (let ((max-w (quotient width 2))) + (let lp ((ls ls) (res '()) (widest 0)) + (cond + ((pair? ls) + (let ((str ((fits-in-width (write (car ls)) max-w) st))) + (and str + (lp (cdr ls) + (cons str res) + (max ((or (fmt-string-width st) string-length) str) + widest))))) + ((null? ls) (cons widest (reverse res))) + (else #f)))))) + +(define (fmt-capture producer consumer) + (lambda (st) + (let ((port (open-output-string))) + (producer (fmt-set-writer! (fmt-set-port! (copy-fmt-state st) port) + fmt-write)) + ((consumer (get-output-string port)) st)))) + +(define (fmt-to-string producer) + (fmt-capture producer (lambda (str) (lambda (st) str)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; standard formatters + +(define (nl st) + ((fmt-writer st) nl-str st)) + +;; output a newline iff we're not at the start of a fresh line +(define (fl st) + (if (zero? (fmt-col st)) st (nl st))) + +;; tab to a given tab-stop +(define (tab-to . o) + (lambda (st) + (let* ((tab-width (if (pair? o) (car o) 8)) + (rem (modulo (fmt-col st) tab-width))) + (if (positive? rem) + ((fmt-writer st) + (make-string (- tab-width rem) (fmt-pad-char st)) + st) + st)))) + +;; move to an explicit column +(define (space-to col) + (lambda (st) + (let ((width (- col (fmt-col st)))) + (if (positive? width) + ((fmt-writer st) (make-string width (fmt-pad-char st)) st) + st)))) + +(define (fmt-join fmt ls . o) + (let ((sep (dsp (if (pair? o) (car o) "")))) + (lambda (st) + (if (null? ls) + st + (let lp ((ls (cdr ls)) + (st ((fmt (car ls)) st))) + (if (null? ls) + st + (lp (cdr ls) ((fmt (car ls)) (sep st))))))))) + +(define (fmt-join/prefix fmt ls . o) + (if (null? ls) + fmt-null + (let ((sep (dsp (if (pair? o) (car o) "")))) + (cat sep (fmt-join fmt ls sep))))) +(define (fmt-join/suffix fmt ls . o) + (if (null? ls) + fmt-null + (let ((sep (dsp (if (pair? o) (car o) "")))) + (cat (fmt-join fmt ls sep) sep)))) + +(define (fmt-join/last fmt fmt/last ls . o) + (let ((sep (dsp (if (pair? o) (car o) "")))) + (lambda (st) + (cond + ((null? ls) + st) + ((null? (cdr ls)) + ((fmt/last (car ls)) (sep st))) + (else + (let lp ((ls (cdr ls)) + (st ((fmt (car ls)) st))) + (if (null? (cdr ls)) + ((fmt/last (car ls)) (sep st)) + (lp (cdr ls) ((fmt (car ls)) (sep st)))))))))) + +(define (fmt-join/dot fmt fmt/dot ls . o) + (let ((sep (dsp (if (pair? o) (car o) "")))) + (lambda (st) + (cond + ((pair? ls) + (let lp ((ls (cdr ls)) + (st ((fmt (car ls)) st))) + (cond + ((null? ls) st) + ((pair? ls) (lp (cdr ls) ((fmt (car ls)) (sep st)))) + (else ((fmt/dot ls) (sep st)))))) + ((null? ls) st) + (else ((fmt/dot ls) st)))))) + +(define (fmt-join/range fmt start . o) + (let-optionals* o ((end #f) (sep "")) + (lambda (st) + (let lp ((i (+ start 1)) (st ((fmt start) st))) + (if (and end (>= i end)) + st + (lp (+ i 1) ((fmt i) ((dsp sep) st)))))))) + +(define (pad/both width . ls) + (fmt-capture + (apply-cat ls) + (lambda (str) + (lambda (st) + (let ((diff (- width ((or (fmt-string-width st) string-length) str))) + (output (fmt-writer st))) + (if (positive? diff) + (let* ((diff/2 (quotient diff 2)) + (left (make-string diff/2 (fmt-pad-char st))) + (right (if (even? diff) + left + (make-string (+ 1 diff/2) (fmt-pad-char st))))) + (output right (output str (output left st)))) + (output str st))))))) + +(define (pad width . ls) + (lambda (st) + (let* ((col (fmt-col st)) + (padder + (lambda (st) + (let ((diff (- width (- (fmt-col st) col)))) + (if (positive? diff) + ((fmt-writer st) (make-string diff (fmt-pad-char st)) st) + st))))) + ((cat (apply-cat ls) padder) st)))) + +(define pad/right pad) + +(define (pad/left width . ls) + (fmt-capture + (apply-cat ls) + (lambda (str) + (lambda (st) + (let* ((str-width ((or (fmt-string-width st) string-length) str)) + (diff (- width str-width))) + ((fmt-writer st) + str + (if (positive? diff) + ((fmt-writer st) (make-string diff (fmt-pad-char st)) st) + st))))))) + +(define (trim/buffered width fmt proc) + (fmt-capture + fmt + (lambda (str) + (lambda (st) + (let* ((str-width ((or (fmt-string-width st) string-length) str)) + (diff (- str-width width))) + ((fmt-writer st) + (if (positive? diff) + (proc str str-width diff st) + str) + st)))))) + +(define (trim width . ls) + (lambda (st) + (let ((ell (fmt-ellipses st))) + (if ell + ((trim/buffered + width + (apply-cat ls) + (lambda (str str-width diff st) + (let* ((ell (if (char? ell) (string ell) ell)) + (ell-len (string-length ell)) + (diff (- (+ str-width ell-len) width))) + (if (negative? diff) + ell + (string-append + (substring/shared str 0 (- (string-length str) diff)) + ell))))) + st) + (let ((output (fmt-writer st)) + (start-col (fmt-col st))) + (call-with-current-continuation + (lambda (return) + (define (output* str st) + (let* ((len ((or (fmt-string-width st) string-length) str)) + (diff (- (+ (- (fmt-col st) start-col) len) width))) + (if (positive? diff) + (return + (fmt-set-writer! + (output (substring/shared str 0 (- len diff)) st) + output)) + (output str st)))) + ((fmt-let 'writer output* (apply-cat ls)) st)))))))) + +(define (trim/length width . ls) + (lambda (st) + (call-with-current-continuation + (lambda (return) + (let ((output (fmt-writer st)) + (sum 0)) + (define (output* str st) + (let ((len (string-length str))) + (set! sum (+ sum len)) + (if (> sum width) + (return + (fmt-set-writer! + (output (substring/shared str 0 (- len (- sum width))) st) + output)) + (output str st)))) + ((fmt-let 'writer output* (apply-cat ls)) st)))))) + +(define (trim/left width . ls) + (trim/buffered + width + (apply-cat ls) + (lambda (str str-width diff st) + (let ((ell (fmt-ellipses st))) + (if ell + (let* ((ell (if (char? ell) (string ell) ell)) + (ell-len (string-length ell)) + (diff (- (+ str-width ell-len) width))) + (if (negative? diff) + ell + (string-append ell (substring/shared str diff)))) + (substring/shared str diff)))))) + +(define (trim/both width . ls) + (trim/buffered + width + (apply-cat ls) + (lambda (str str-width diff st) + (let ((ell (fmt-ellipses st))) + (if ell + (let* ((ell (if (char? ell) (string ell) ell)) + (ell-len (string-length ell)) + (diff (- (+ str-width ell-len ell-len) width)) + (left (quotient diff 2)) + (right (- (string-length str) (quotient (+ diff 1) 2)))) + (if (negative? diff) + ell + (string-append ell (substring/shared str left right) ell))) + (substring/shared str + (quotient (+ diff 1) 2) + (- (string-length str) (quotient diff 2)))))))) + +(define (fit width . ls) + (pad width (trim width (apply-cat ls)))) +(define (fit/left width . ls) + (pad/left width (trim/left width (apply-cat ls)))) +(define (fit/both width . ls) + (pad/both width (trim/both width (apply-cat ls)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; String-map formatters + +(define (make-string-fmt-transformer proc) + (lambda ls + (lambda (st) + (let ((base-writer (fmt-writer st))) + ((fmt-let + 'writer (lambda (str st) (base-writer (proc str) st)) + (apply-cat ls)) + st))))) + +(define upcase (make-string-fmt-transformer string-upcase)) +(define downcase (make-string-fmt-transformer string-downcase)) +(define titlecase (make-string-fmt-transformer string-titlecase)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Numeric formatting + +(define *min-e* -1024) +(define *bot-f* (expt 2 52)) +;;(define *top-f* (* 2 *bot-f*)) + +(define (integer-log a base) + (if (zero? a) + 0 + (inexact->exact (ceiling (/ (log (+ a 1)) (log base)))))) +(define (integer-length* a) + (if (negative? a) + (integer-log (- 1 a) 2) + (integer-log a 2))) + +(define invlog2of + (let ((table (make-vector 37)) + (log2 (log 2))) + (do ((b 2 (+ b 1))) + ((= b 37)) + (vector-set! table b (/ log2 (log b)))) + (lambda (b) + (if (<= 2 b 36) + (vector-ref table b) + (/ log2 (log b)))))) + +(define fast-expt + (let ((table (make-vector 326))) + (do ((k 0 (+ k 1)) (v 1 (* v 10))) + ((= k 326)) + (vector-set! table k v)) + (lambda (b k) + (if (and (= b 10) (<= 0 k 326)) + (vector-ref table (inexact->exact (truncate k))) + (expt b k))))) + +(define (mirror-of c) + (case c ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else c))) + +(define default-digits + (list->vector (string->list "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"))) + +;; kanji (10 included for base 11 ;) +;; (vector "０" "一" "二" "三" "四" "五" "六" "七" "八" "九" "十") + +;; old style kanji: +;; (vector "零" "壱" "弐" "参" "肆" "伍" "陸" "柒" "捌" "玖" "拾") + +;; General algorithm based on "Printing Floating-Point Numbers Quickly +;; and Accurately" by Burger and Dybvig (FP-Printing-PLDI96.pdf). The +;; code below will be hard to read out of that context until it's +;; cleaned up. + +(define (num->string n st . opt) + (call-with-output-string + (lambda (port) + (let-optionals* opt + ((base (fmt-radix st)) + (digits (fmt-precision st)) + (sign? #f) + (commify? #f) + (comma-sep (and commify? (fmt-ref st 'comma-char #\,))) + (decimal-sep (or (fmt-decimal-sep st) + (if (eqv? comma-sep #\.) #\, #\.))) + (comma-rule (if (eq? commify? #t) 3 commify?)) + (align (fmt-decimal-align st)) + (digit-vec default-digits) + (stack '())) + + (define (write-digit d) + (display (vector-ref digit-vec (inexact->exact (truncate d))) port)) + + ;; This is ugly because we need to keep a list of all output + ;; of the form x9999... in case we get to the end of the + ;; precision and need to round up. Alas, if it weren't for + ;; decimals and commas, we could just keep track of the last + ;; non-9 digit and the number of nines seen, without any need + ;; for a heap-allocated stack. + (define (write-digit-list ls) + (for-each + (lambda (x) (if (number? x) (write-digit x) (display x port))) + ls)) + + (define (flush) + (write-digit-list (reverse stack)) + (set! stack '())) + + (define (flush/rounded) + (let lp ((ls stack) (res '())) + (cond + ((null? ls) + (write-digit-list (cons #\1 res))) + ((not (number? (car ls))) + (lp (cdr ls) (cons (car ls) res))) + ((= (car ls) (- base 1)) + (lp (cdr ls) (cons #\0 res))) + (else + (write-digit-list + (append (reverse (cdr ls)) (cons (+ 1 (car ls)) res)))))) + (set! stack '())) + + (define (output digit) + (if (and (number? digit) (< digit (- base 1))) + (flush)) + (set! stack (cons digit stack))) + + (define (write-prefix prefix align k) + (if align + (let* ((prefix (cond ((string? prefix) prefix) + ((char? prefix) (string prefix)) + (else ""))) + (diff (- align + (+ (if (<= k 0) 1 k) (string-length prefix)) + 1))) + (if (positive? diff) + (display (make-string diff (fmt-pad-char st)) port)) + (display prefix port)) + (if prefix (display prefix port)))) + + (define (write-real n prefix align) + + (let* ((m+e (mantissa+exponent (exact->inexact n))) + (f (car m+e)) + (e (cadr m+e)) + (inv-base (invlog2of base)) + (round? (even? f)) + (smaller (if round? <= <)) + (bigger (if round? >= >))) + + (define (pad d i) ;; just pad 0's, not #'s + (write-digit d) + (let lp ((i (- i 1))) + (cond + ((>= i 0) + (if (and commify? + (if digits + (and (> i digits) + (zero? (modulo (- i (- digits 1)) + comma-rule))) + (and (positive? i) + (zero? (modulo i comma-rule))))) + (display comma-sep port)) + (if (= i (- digits 1)) + (display decimal-sep port)) + (write-digit 0) + (lp (- i 1)))))) + + (define (pad-all d i) + (cond + ((>= d base) + (flush/rounded)) + (else + (flush) + (write-digit d))) + (let lp ((i (- i 1))) + (cond + ((> i 0) + (if (and commify? (zero? (modulo i comma-rule))) + (display comma-sep port)) + (write-digit 0) + (lp (- i 1))) + ((and (= i 0) (inexact? n)) + (display decimal-sep port) + (write-digit 0))))) + + ;;(define (pad-sci d i k) + ;; (cond + ;; ((>= d base) + ;; (flush/rounded)) + ;; (else + ;; (flush) + ;; (write-digit d))) + ;; (write-char #\e port) + ;; (cond + ;; ((positive? k) + ;; (write-char #\+ port) + ;; (write (- k 1) port)) + ;; (else + ;; (write k port)))) + + (define (scale r s m+ m- k f e) + (let ((est (inexact->exact + (ceiling (- (* (+ e (integer-length* f) -1) + (invlog2of base)) + 1.0e-10))))) + (if (not (negative? est)) + (fixup r (* s (fast-expt base est)) m+ m- est) + (let ((skale (fast-expt base (- est)))) + (fixup (* r skale) s (* m+ skale) (* m- skale) est))))) + + (define (fixup r s m+ m- k) + (if (and (bigger (+ r m+) s)) ;; (or digits (>= k -4)) + (lead r s m+ m- (+ k 1)) + (lead (* r base) s (* m+ base) (* m- base) k))) + + (define (lead r s m+ m- k) + (write-prefix prefix align k) + (cond + ((and (not digits) (or (> k 14) (< k -4))) + (write n port)) ; XXXX native write for sci + ;;((and (not digits) (> k 14)) + ;; (generate-sci r s m+ m- k)) + ;;((and (not digits) (< k -4)) + ;; (if (>= (/ r s) base) + ;; (generate-sci (/ r base) s (/ m+ base) (/ m- base) k) + ;; (generate-sci r s m+ m- k))) + (else + (cond + ((and (not digits) + (or (negative? k) + (and (zero? k) (not (integer? n))))) + (write-digit 0) + (display decimal-sep port) + (let lp ((i 0)) + (cond ((> i k) + (write-digit 0) + (lp (- i 1))))))) + (if digits + (generate-fixed r s m+ m- k) + (generate-all r s m+ m- k))))) + + (define (generate-all r s m+ m- k) + (let gen ((r r) (m+ m+) (m- m-) (i k)) + (cond ((= i k)) + ((zero? i) + (output decimal-sep)) + ((and commify? + (positive? i) + (zero? (modulo i comma-rule))) + (output comma-sep))) + (let ((d (quotient r s)) + (r (remainder r s))) + (if (not (smaller r m-)) + (cond + ((not (bigger (+ r m+) s)) + (output d) + (gen (* r base) (* m+ base) (* m- base) (- i 1))) + (else + (pad-all (+ d 1) i))) + (if (not (bigger (+ r m+) s)) + (pad-all d i) + (pad-all (if (< (* r 2) s) d (+ d 1)) i)))))) + + (define (generate-fixed r s m+ m- k) + (if (<= k 0) + (set! stack (append (make-list (min (- k) digits) 0) + (list decimal-sep 0)))) + (let ((i0 (- (+ k digits) 1))) + (let gen ((r r) (m+ m+) (m- m-) (i i0)) + (cond ((= i i0)) + ((= i (- digits 1)) + (output decimal-sep)) + ((and commify? + (> i digits) + (zero? (modulo (- i (- digits 1)) + comma-rule))) + (output comma-sep))) + (let ((d (quotient r s)) + (r (remainder r s))) + (cond + ((< i 0) + (let ((d2 (* 2 (if (>= (* r 2) s) (+ d 1) d)))) + (if (and (not (> (- k) digits)) + (or (> d2 base) + (and (= d2 base) + (pair? stack) + (number? (car stack)) + (odd? (car stack))))) + (flush/rounded) + (flush)))) + ((smaller r m-) + (cond + ((>= d base) + (flush/rounded) + (pad 0 i)) + (else + (flush) + (if (bigger (+ r m+) s) + (pad (if (< (* r 2) s) d (+ d 1)) i) + (pad d i))))) + ((bigger (+ r m+) s) + (cond + ((>= d (- base 1)) + (flush/rounded) + (pad 0 i)) + (else + (flush) + (pad (+ d 1) i)))) + (else + (output d) + (gen (* r base) (* m+ base) (* m- base) (- i 1)))))))) + + ;;(define (generate-sci r s m+ m- k) + ;; (let gen ((r r) (m+ m+) (m- m-) (i k)) + ;; (cond ((= i (- k 1)) (display decimal-sep port))) + ;; (let ((d (quotient r s)) + ;; (r (remainder r s))) + ;; (if (not (smaller r m-)) + ;; (cond + ;; ((not (bigger (+ r m+) s)) + ;; (output d) + ;; (gen (* r base) (* m+ base) (* m- base) (- i 1))) + ;; (else (pad-sci (+ d 1) i k))) + ;; (if (not (bigger (+ r m+) s)) + ;; (pad-sci d i k) + ;; (pad-sci (if (< (* r 2) s) d (+ d 1)) i k)))))) + + (cond + ((negative? e) + (if (or (= e *min-e*) (not (= f *bot-f*))) + (scale (* f 2) (* (expt 2.0 (- e)) 2) 1 1 0 f e) + (scale (* f 2 2) (* (expt 2.0 (- 1 e)) 2) 2 1 0 f e))) + (else + (if (= f *bot-f*) + (let ((be (expt 2 e))) + (scale (* f be 2) 2.0 be be 0 f e)) + (let* ((be (expt 2 e)) (be1 (* be 2))) + (scale (* f be1 2) (* 2.0 2) be1 be 0 f e))))))) + + (define (write-fixed-rational p prefix align) + (define (get-scale q) (expt base (- (integer-log q base) 1))) + (let ((n (numerator p)) + (d (denominator p)) + (k (integer-log p base))) + (write-prefix prefix align k) + (let lp ((n n) + (i (- k))) + (cond + ((< i digits) + (if (zero? i) (output decimal-sep)) + (let ((q (quotient n d))) + (cond + ((>= q base) + (let* ((scale (get-scale q)) + (digit (quotient q scale)) + (n2 (- n (* d digit scale)))) + (output digit) + (lp n2 (+ i 1)))) + (else + (output q) + (lp (* (remainder n d) base) (+ i 1)))))) + (else + (let* ((q (quotient n d)) + (digit + (* 2 (if (>= q base) (quotient q (get-scale q)) q)))) + (if (or (> digit base) + (and (= digit base) + (let ((prev (find integer? stack))) + (and prev (odd? prev))))) + (flush/rounded) + (flush)))))))) + + (define (wrap-sign n sign? align writer) + (cond + ((negative? n) + (cond + ((char? sign?) + (writer (abs n) sign? align) + (display (mirror-of sign?) port)) + (else + (writer (abs n) #\- align)))) + (else + (cond + ((and sign? (not (char? sign?))) + (writer n #\+ align)) + (else + (writer n #f align)))))) + + (let ((imag (imag-part n))) + (cond + ((and base (not (and (integer? base) (<= 2 base 36)))) + (error "invalid base for numeric formatting" base)) + ((zero? imag) + (cond + ((and (exact? n) (not (integer? n))) + (cond + (digits + (wrap-sign n sign? align write-fixed-rational)) + (else + (wrap-sign (numerator n) sign? #f write-real) + (write-char #\/ port) + (wrap-sign (denominator n) #f #f write-real)))) + (else + (wrap-sign n sign? align write-real)))) + (else (wrap-sign (real-part n) sign? #f write-real) + (wrap-sign imag #t #f write-real) + (write-char #\i port)))))))) + +(define (num n . opt) + (lambda (st) ((fmt-writer st) (apply num->string n st opt) st))) + +(define (num/comma n . o) + (lambda (st) + (let-optionals* o + ((base (fmt-radix st)) + (digits (fmt-precision st)) + (sign? #f) + (comma-rule 3) + (comma-sep (fmt-ref st 'comma-char #\,)) + (decimal-sep (or (fmt-decimal-sep st) + (if (eqv? comma-sep #\.) #\, #\.)))) + ((num n base digits sign? comma-rule comma-sep decimal-sep) st)))) + +;; SI suffix formatting, as used in --human-readable options to some +;; GNU commands (such as ls). See +;; +;; http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html +;; http://physics.nist.gov/cuu/Units/binary.html +;; +;; Note: lowercase "k" for base 10, uppercase "K" for base 2 + +(define num/si + (let* ((names10 '#("" "k" "M" "G" "T" "E" "P" "Z" "Y")) + (names2 (list->vector + (cons "" + (cons "Ki" (map (lambda (s) (string-append s "i")) + (cddr (vector->list names10)))))))) + (lambda (n . o) + (let-optionals* o ((base 1024) + (suffix "") + (names (if (= base 1024) names2 names10))) + (let* ((k (min (inexact->exact (floor (/ (log n) (log base)))) + (vector-length names))) + (n2 (/ (round (* (/ n (expt base k)) 10)) 10))) + (cat (if (integer? n2) + (number->string (inexact->exact n2)) + (exact->inexact n2)) + (vector-ref names k) + (if (zero? k) "" suffix))))))) + +(define roman-numerals + '((1000 . #\M) (500 . #\D) (100 . #\C) + (50 . #\L) (10 . #\X) (5 . #\V) (1 . #\I))) + +(define (num/old-roman num) + (lambda (st) + (let lp ((num num) (res '())) + (if (positive? num) + (let ((ch (find (lambda (x) (>= num (car x))) roman-numerals))) + (lp (- num (car ch)) (cons (cdr ch) res))) + (fmt-write (reverse-list->string res) st))))) + +(define (num/roman num) + (lambda (st) + (let lp1 ((num num) (res '())) + (if (positive? num) + (let lp2 ((ls roman-numerals)) + (let* ((big (car ls)) + (big-n (car big))) + (cond + ((>= num big-n) + (lp1 (- num big-n) (cons (cdr big) res))) + ((and (> (* 2 num) big-n) + (find (lambda (c) + (let ((x (car c))) + (<= (+ x 1) (- big-n x) num))) + ls)) + => (lambda (c) + (lp1 (- num (- big-n (car c))) + (cons (cdr big) (cons (cdr c) res))))) + (else + (lp2 (cdr ls)))))) + (fmt-write (reverse-list->string res) st))))) + +;; Force a number into a fixed width, print as #'s if doesn't fit. +;; Needs to be wrapped in a PAD if you want to expand to the width. + +(define (num/fit width n . args) + (fmt-capture + (apply num n args) + (lambda (str) + (lambda (st) + (if (> (string-length str) width) + (let ((prec (if (and (pair? args) (pair? (cdr args))) + (cadr args) + (fmt-precision st)))) + (if prec + (let* ((decimal-sep + (or (fmt-ref st 'decimal-sep) + (if (eqv? #\. (fmt-ref st 'comma-sep)) #\, #\.))) + (diff (- width (+ prec + (if (char? decimal-sep) + 1 + (string-length decimal-sep)))))) + ((cat (if (positive? diff) (make-string diff #\#) "") + decimal-sep (make-string prec #\#)) + st)) + ((fmt-writer st) (make-string width #\#) st))) + ((fmt-writer st) str st)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; shared structure utilities + +(define (eq?-table-ref tab x) (hash-table-ref/default tab x #f)) +(define (eq?-table-set! tab x v) (hash-table-set! tab x v)) + +;; XXXX extend for records and other container data types +(define (make-shared-ref-table obj) + (let ((tab (make-eq?-table)) + (res (make-eq?-table)) + (index 0)) + (let walk ((obj obj)) + (cond + ((eq?-table-ref tab obj) + => (lambda (i) (eq?-table-set! tab obj (+ i 1)))) + ((not (or (symbol? obj) (number? obj) (char? obj) + (boolean? obj) (null? obj) (eof-object? obj))) + (eq?-table-set! tab obj 1) + (cond + ((pair? obj) + (walk (car obj)) + (walk (cdr obj))) + ((vector? obj) + (let ((len (vector-length obj))) + (do ((i 0 (+ i 1))) ((>= i len)) + (walk (vector-ref obj i))))))))) + (hash-table-walk + tab + (lambda (obj count) + (if (> count 1) + (begin + (eq?-table-set! res obj (cons index #f)) + (set! index (+ index 1)))))) + res)) + +(define (gen-shared-ref i suffix) + (string-append "#" (number->string i) suffix)) + +(define (maybe-gen-shared-ref st cell shares) + (cond + ((pair? cell) + (set-car! cell (cdr shares)) + (set-cdr! cell #t) + (set-cdr! shares (+ (cdr shares) 1)) + ((fmt-writer st) (gen-shared-ref (car cell) "=") st)) + (else st))) + +(define (call-with-shared-ref obj st shares proc) + (let ((cell (eq?-table-ref (car shares) obj))) + (if (and (pair? cell) (cdr cell)) + ((fmt-writer st) (gen-shared-ref (car cell) "#") st) + (proc (maybe-gen-shared-ref st cell shares))))) + +(define (call-with-shared-ref/cdr obj st shares proc sep) + (let ((cell (eq?-table-ref (car shares) obj)) + (output (fmt-writer st))) + (cond + ((and (pair? cell) (cdr cell)) + (output (gen-shared-ref (car cell) "#") (output ". " (sep st)))) + ((pair? cell) + (let ((st (maybe-gen-shared-ref (output ". " (sep st)) cell shares))) + (output ")" (proc (output "(" st))))) + (else + (proc (sep st)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; sexp formatters + +(define (slashified str . o) + (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f))) + (lambda (st) + (let* ((len (string-length str)) + (output (fmt-writer st)) + (quot-str (string quot)) + (esc-str (if (char? esc) (string esc) (or esc quot-str)))) + (let lp ((i 0) (j 0) (st st)) + (define (collect) + (if (= i j) st (output (substring/shared str i j) st))) + (if (>= j len) + (collect) + (let ((c (string-ref str j))) + (cond + ((or (eqv? c quot) (eqv? c esc)) + (lp j (+ j 1) (output esc-str (collect)))) + ((rename c) + => (lambda (c2) + (lp (+ j 1) + (+ j 1) + (output c2 (output esc-str (collect)))))) + (else + (lp i (+ j 1) st)))))))))) + +;; Only slashify if there are special characters, in which case also +;; wrap in quotes. For writing symbols in |...| escapes, or CSV +;; fields, etc. The predicate indicates which characters cause +;; slashification - this is in addition to automatic slashifying when +;; either the quote or escape char is present. + +(define (maybe-slashified str pred . o) + (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f))) + (define (esc? c) (or (eqv? c quot) (eqv? c esc) (rename c) (pred c))) + (if (string-index str esc?) + (cat quot (slashified str quot esc rename) quot) + (dsp str)))) + +(define (fmt-write-string str) + (define (rename c) + (case c + ((#\newline) "n") + (else #f))) + (slashified str #\" #\\ rename)) + +(define (dsp obj) + (cond + ((procedure? obj) obj) + ((string? obj) (lambda (st) ((fmt-writer st) obj st))) + ((char? obj) (dsp (string obj))) + (else (wrt obj)))) + +(define (write-with-shares obj shares) + (lambda (st) + (let* ((output (fmt-writer st)) + (wr-num + (cond ((and (= 10 (fmt-radix st)) + (not (fmt-precision st)) + (not (fmt-decimal-align st))) + (lambda (n st) (output (number->string n) st))) + ((assv (fmt-radix st) + '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))) + => (lambda (cell) + (let ((prefix (cdr cell))) + (lambda (n st) ((num n) (output prefix st)))))) + (else (lambda (n st) (output (number->string n) st)))))) + (let wr ((obj obj) (st st)) + (call-with-shared-ref obj st shares + (lambda (st) + (cond + ((pair? obj) + (output + ")" + (let lp ((ls obj) + (st (output "(" st))) + (let ((st (wr (car ls) st)) + (rest (cdr ls))) + (cond + ((null? rest) st) + ((pair? rest) + (call-with-shared-ref/cdr rest st shares + (lambda (st) (lp rest st)) + (dsp " "))) + (else (wr rest (output " . " st)))))))) + ((vector? obj) + (let ((len (vector-length obj))) + (if (zero? len) + (output "#()" st) + (let lp ((i 1) + (st + (wr (vector-ref obj 0) + (output "#(" st)))) + (if (>= i len) + (output ")" st) + (lp (+ i 1) + (wr (vector-ref obj i) + (output " " st)))))))) + ((string? obj) + (output "\"" ((fmt-write-string obj) (output "\"" st)))) + ((number? obj) + (wr-num obj st)) + ((boolean? obj) + (output (if obj "#t" "#f") st)) + (else + (output (write-to-string obj) st))))))))) + +(define (wrt obj) + (write-with-shares obj (cons (make-shared-ref-table obj) 0))) + +;; the only expensive part, in both time and memory, of handling +;; shared structures when writing is building the initial table, so +;; for the efficient version we just skip that + +(define (wrt/unshared obj) + (write-with-shares obj (cons (make-eq?-table) 0))) + diff --git a/functional-tests/fmt/fmt.sls b/functional-tests/fmt/fmt.sls new file mode 100644 index 0000000..0b4b021 --- /dev/null +++ b/functional-tests/fmt/fmt.sls @@ -0,0 +1,47 @@ +;;;; fmt.scm -- extensible formatting library +;; +;; Copyright (c) 2006-2009 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +#!r6rs +(library (fmt fmt) + (export + new-fmt-state + fmt fmt-start fmt-if fmt-capture fmt-let fmt-bind fmt-null + fmt-ref fmt-set! fmt-add-properties! fmt-set-property! + fmt-col fmt-set-col! fmt-row fmt-set-row! + fmt-radix fmt-set-radix! fmt-precision fmt-set-precision! + fmt-properties fmt-set-properties! fmt-width fmt-set-width! + fmt-writer fmt-set-writer! fmt-port fmt-set-port! + fmt-decimal-sep fmt-set-decimal-sep! + fmt-file fmt-try-fit cat apply-cat nl fl nl-str + fmt-join fmt-join/last fmt-join/dot + fmt-join/prefix fmt-join/suffix fmt-join/range + pad pad/right pad/left pad/both trim trim/left trim/both trim/length + fit fit/left fit/both tab-to space-to wrt wrt/unshared dsp + pretty pretty/unshared slashified maybe-slashified + num num/si num/fit num/comma radix fix decimal-align ellipses + upcase downcase titlecase pad-char comma-char decimal-char + with-width wrap-lines fold-lines justify + make-string-fmt-transformer + make-space make-nl-space display-to-string write-to-string + fmt-columns columnar tabular line-numbers) + (import (chezscheme) + (only (srfi s13 strings) string-count string-index + string-index-right + string-concatenate string-concatenate-reverse + substring/shared reverse-list->string string-tokenize + string-suffix? string-prefix?) + (srfi private let-opt) + (srfi private include) + (scheme) + (only (srfi s1 lists) fold length+)) + + (include/resolve ("fmt") "hash-compat.scm") + (include/resolve ("fmt") "mantissa.scm") + (include/resolve ("fmt") "read-line.scm") + (include/resolve ("fmt") "string-ports.scm") + (include/resolve ("fmt") "fmt.scm") + (include/resolve ("fmt") "fmt-column.scm") + (include/resolve ("fmt") "fmt-pretty.scm") + ) diff --git a/functional-tests/fmt/hash-compat.scm b/functional-tests/fmt/hash-compat.scm new file mode 100644 index 0000000..8df6a8e --- /dev/null +++ b/functional-tests/fmt/hash-compat.scm @@ -0,0 +1,5 @@ + +(define (make-eq?-table) (make-eq-hashtable)) +(define hash-table-ref/default hashtable-ref) +(define hash-table-set! hashtable-set!) +(define hash-table-walk hash-table-for-each) diff --git a/functional-tests/fmt/js.sls b/functional-tests/fmt/js.sls new file mode 100644 index 0000000..b78e1a6 --- /dev/null +++ b/functional-tests/fmt/js.sls @@ -0,0 +1,18 @@ +;;;; fmt-js.scm -- javascript formatting utilities +;; +;; Copyright (c) 2011-2012 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +#!r6rs +(library + (fmt js) + (export + js-expr js-function js-var js-comment js-array js-object js=== js>>>) + + (import (chezscheme) + (fmt fmt) (fmt c) + (srfi private include)) + + (include ("fmt") "fmt-js.scm") + + ) diff --git a/functional-tests/fmt/mantissa.scm b/functional-tests/fmt/mantissa.scm new file mode 100644 index 0000000..cf32d57 --- /dev/null +++ b/functional-tests/fmt/mantissa.scm @@ -0,0 +1,20 @@ + +;; Break a positive real number down to a normalized mantissa and +;; exponent. Default base=2, mant-size=52, exp-size=11 for IEEE doubles. + + +(define mantissa+exponent + (case-lambda + [(num) (mantissa+exponent num 2)] + [(num base) (mantissa+exponent num base 52)] + [(num base mant-size) (mantissa+exponent num base mant-size 11)] + [(num base mant-size exp-size) + (if (zero? num) + (list 0 0) + (let* ((bot (expt base mant-size)) + (top (* base bot))) + (let lp ((n num) (e 0)) + (cond + ((>= n top) (lp (quotient n base) (+ e 1))) + ((< n bot) (lp (* n base) (- e 1))) + (else (list n e))))))])) diff --git a/functional-tests/fmt/read-line.scm b/functional-tests/fmt/read-line.scm new file mode 100644 index 0000000..48f3d37 --- /dev/null +++ b/functional-tests/fmt/read-line.scm @@ -0,0 +1,11 @@ + +(define (read-line . o) + (let ((port (if (pair? o) (car o) (current-input-port)))) + (let lp ((res '())) + (let ((c (read-char port))) + (cond + [(and (eof-object? c) (null? res)) #f] + [(or (eof-object? c) (eqv? c #\newline)) + (list->string (reverse res))] + [else + (lp (cons c res))]))))) diff --git a/functional-tests/fmt/string-ports.scm b/functional-tests/fmt/string-ports.scm new file mode 100644 index 0000000..f58217f --- /dev/null +++ b/functional-tests/fmt/string-ports.scm @@ -0,0 +1,5 @@ + +(define (call-with-output-string f) + (let ((port (open-output-string))) + (let () (f port)) + (get-output-string port))) diff --git a/functional-tests/fmt/test-fmt-c.scm b/functional-tests/fmt/test-fmt-c.scm new file mode 100644 index 0000000..c5ec5ac --- /dev/null +++ b/functional-tests/fmt/test-fmt-c.scm @@ -0,0 +1,464 @@ + +(cond-expand + (chicken (use test) (load "fmt-c-chicken.scm")) + (gauche + (use gauche.test) + (use text.fmt) + (use text.fmt.c) + (define test-begin test-start) + (define orig-test (with-module gauche.test test)) + (define-syntax test + (syntax-rules () + ((test name expected expr) + (orig-test name expected (lambda () expr))) + ((test expected expr) + (orig-test (let ((s (with-output-to-string (lambda () (write 'expr))))) + (substring s 0 (min 60 (string-length s)))) + expected + (lambda () expr))) + ))) + (else)) + +(cond-expand + (chicken + (import fmt fmt-c)) + (else)) + +(test-begin "fmt-c") + +(test "if (1) { + 2; +} else { + 3; +} +" + (fmt #f (c-if 1 2 3))) + +(test "if (x ? y : z) { + 2; +} else { + 3; +} +" + (fmt #f (c-if (c-if 'x 'y 'z) 2 3))) + +(test "if (x ? y : z) { + 2; +} else { + 3; +} +" + (fmt #f (c-expr '(if (if x y z) 2 3)))) + +(test "if (x ? y : z) { + 2; +} else { + 3; +} +" + (fmt #f (c-expr '(%begin (if (if x y z) 2 3))))) + +(test "int square (int x) { + return x * x; +} +" + (fmt #f (c-fun 'int 'square '((int x)) (c* 'x 'x)))) + +(test "int foo (int x, int y, int z) { + if (x ? y : z) { + return 2; + } else { + return 3; + } +} +" + (fmt #f (c-fun 'int 'foo '((int x) (int y) (int z)) + (c-if (c-if 'x 'y 'z) 2 3)))) + +(test "void bar (int mode, const char *msg, unsigned int arg) { + if (mode == 1) { + printf(msg); + } else { + printf(msg, arg); + } +} +" + (fmt #f (c-fun 'void 'bar + '((int mode) + ((%pointer (const char)) msg) + ((unsigned int) arg)) + (c-if (c== 'mode 1) '(printf msg) '(printf msg arg))))) + +(test "while ((line = readline()) != EOF) { + printf(\"%s\", line); +} +" + (fmt #f (c-while (c!= (c= 'line '(readline)) 'EOF) + '(printf "%s" line)))) + +(test "switch (y) { + case 1: + x = 1; + break; + case 2: + x = 4; + break; + default: + x = 5; + break; +} +" + (fmt #f (c-switch 'y + (c-case 1 (c= 'x 1)) + (c-case 2 (c= 'x 4)) + (c-default (c= 'x 5))))) + +(test "switch (y) { + case 1: + x = 1; + break; + case 2: + x = 4; + default: + x = 5; + break; +} +" + (fmt #f (c-switch 'y + (c-case 1 (c= 'x 1)) + (c-case/fallthrough 2 (c= 'x 4)) + (c-default (c= 'x 5))))) + +(test "switch (y) { + case 1: + x = 1; + break; + case 2: + x = 4; + break; + default: + x = 5; + break; +} +" + (fmt #f (c-switch 'y '((1) (= x 1)) '((2) (= x 4)) '(else (= x 5))))) + +(test "switch (y) { + case 1: + x = 1; + break; + case 2: + x = 4; + break; + default: + x = 5; + break; +} +" + (fmt #f (c-expr '(switch y ((1) (= x 1)) ((2) (= x 4)) (else (= x 5)))))) + +(test "int q (int x) { + switch (x) { + case 1: + return 1; + case 2: + return 4; + default: + return 5; + } +} +" + (fmt #f (c-fun 'int 'q '(x) (c-switch 'x '((1) 1) '((2) 4) '(else 5))))) + +(test "switch (x) { + case 1: + case 2: + foo(); + break; + default: + bar(); + break; +} +" + (fmt #f (c-expr '(switch x ((1 2) (foo)) (else (bar)))))) + +(test "switch (x) { + case 1: + foo(); + break; + case 2: + case 3: + bar(); + break; + default: + baz(); + break; +} +" + (fmt #f (c-expr + '(switch x (case 1 (foo)) (case (2 3) (bar)) (else (baz)))))) + +(test "switch (x) { + case 1: + case 2: + foo(); + default: + bar(); + break; +} +" + (fmt #f (c-expr '(switch x (case/fallthrough (1 2) (foo)) (else (bar)))))) + +(test "switch (x) { + case 1: + case 2: + foo(); + break; + default: + bar(); + break; +} +" + (fmt #f (c-expr '(switch x ((1 2) (foo)) (default (bar)))))) + +(test "switch (x) { + default: + bar(); + case 1: + case 2: + foo(); + break; +} +" + (fmt #f (c-expr '(switch x (else/fallthrough (bar)) ((1 2) (foo)))))) + +(test "for (i = 0; i < n; i++) { + printf(\"i: %d\"); +} +" + (fmt #f (c-for (c= 'i 0) (c< 'i 'n) (c++/post 'i) '(printf "i: %d")))) + +(test "a * x + b * y == c;\n" + (fmt #f (c== (c+ (c* 'a 'x) (c* 'b 'y)) 'c))) +(test "a * x + b * y == c;\n" + (fmt #f (c-expr '(== (+ (* a x) (* b y)) c)))) + +(test "(a + x) * (b + y) == c;\n" + (fmt #f (c-expr '(== (* (+ a x) (+ b y)) c)))) + +(test +"(abracadabra!!!! + xylophone????) + * (bananarama____ + yellowstonepark~~~~) + * (cryptoanalysis + zebramania);\n" + (fmt #f (c-expr '(* (+ abracadabra!!!! xylophone????) + (+ bananarama____ yellowstonepark~~~~) + (+ cryptoanalysis zebramania))))) + +(test +"abracadabra(xylophone, + bananarama, + yellowstonepark, + cryptoanalysis, + zebramania, + delightful, + wubbleflubbery);\n" + (fmt #f (c-expr '(abracadabra xylophone + bananarama + yellowstonepark + cryptoanalysis + zebramania + delightful + wubbleflubbery)))) + +(test "#define foo(x, y) (((x) + (y)))\n" + (fmt #f (cpp-define '(foo (int x) (int y)) (c+ 'x 'y)))) + +(test "#define min(x, y) (((x) < (y)) ? (x) : (y))\n" + (fmt #f (cpp-define '(min x y) (c-if (c< 'x 'y) 'x 'y)))) + +(test +"#define foo(x, y) (abracadabra(((x) + (y)), \\ + xylophone, \\ + bananarama, \\ + yellowstonepark, \\ + cryptoanalysis, \\ + zebramania, \\ + delightful, \\ + wubbleflubbery))\n" + (fmt #f (cpp-define '(foo x y) + '(abracadabra (+ x y) + xylophone + bananarama + yellowstonepark + cryptoanalysis + zebramania + delightful + wubbleflubbery)))) + +(test "#ifndef FOO_H +#define FOO_H + +extern int foo (); + +#endif /* ! FOO_H */ +" + (fmt #f (cpp-wrap-header + 'FOO_H + (c-extern (c-prototype 'int 'foo '()))))) + +(test "#if foo +1 +#elif bar +2 +#elif baz +3 +#else +4 +#endif +" + (fmt #f (cpp-if 'foo 1 'bar 2 'baz 3 4))) + +(test "/* this is a /\\* nested *\\/ comment */" + (fmt #f (c-comment " this is a " (c-comment " nested ") " comment "))) + +;; the initial leading space is annoying but hard to remove at the +;; moment - the important thing is we preserve indentation in the body +(test "switch (y) { + case 1: + x = 1; + break; + +#ifdef H_TWO + case 2: + x = 4; + break; +#endif /* H_TWO */ + default: + x = 5; + break; +} +" + (fmt #f (c-expr + `(switch y + ((1) (= x 1)) + ,(cpp-ifdef 'H_TWO (c-case '(2) '(= x 4))) + (else (= x 5)))))) + +(test "#define eprintf(...) (fprintf(stderr, __VA_ARGS__))\n" + (fmt #f (c-expr '(%define (eprintf . args) (fprintf stderr args))))) + +(test "struct point { + int x; + int y; +}; +" + (fmt #f (c-expr `(struct point (x y))))) + +(test "struct employee { + short age; + char *name; + struct { + int year; + int month; + int day; + } dob; +} __attribute__ ((packed)); +" + (fmt #f (c-expr `(struct employee + ((short age) + ((%pointer char) name) + ((struct (year month day)) dob)) + (%attribute packed) + )))) + +(test "class employee { + short age; + char *name; + struct { + int year; + int month; + int day; + } dob; +} __attribute__ ((packed)); +" + (fmt #f (c-class 'employee + '((short age) + ((%pointer char) name) + ((struct (year month day)) dob)) + (c-attribute 'packed) + ))) + +(test "union object { + char tag; + struct { + char tag; + char *data; + } string; + struct { + char tag; + void *car; + void *cdr; + } pair; + struct { + char tag; + unsigned int length; + void *data; + } vector; +}; +" + (fmt #f (c-expr + '(union object + ((char tag) + ((struct ((char tag) ((* char) data))) string) + ((struct ((char tag) + ((* void) car) + ((* void) cdr))) + pair) + ((struct ((char tag) + ((unsigned int) length) + ((* void) data))) + vector) + ))))) + +(test "enum type_tags { + TYPE_CHAR = 1, + TYPE_FIXNUM, + TYPE_BOOLEAN, + TYPE_NULL, + TYPE_EOF, + TYPE_STRING, + TYPE_PAIR, + TYPE_VECTOR +}; +" + (fmt #f (c-expr '(enum type_tags ((TYPE_CHAR 1) TYPE_FIXNUM TYPE_BOOLEAN TYPE_NULL TYPE_EOF TYPE_STRING TYPE_PAIR TYPE_VECTOR))))) + +(test "#define OP_EVAL 0xFE\n" (fmt #f (radix 16 (cpp-define 'OP_EVAL 254)))) + +(test "unsigned long table[SIZE] = {1, 2, 3, 4};\n" + (fmt #f (c-var '(%array (unsigned long) SIZE) 'table '#(1 2 3 4)))) + +(test "int *array_of_ptr[];\n" + (fmt #f (c-var '(%array (* int)) 'array_of_ptr))) + +(test "int (*ptr_to_array)[];\n" + (fmt #f (c-var '(* (%array int)) 'ptr_to_array))) + +(test "foo **table = {{1, \"foo\"}, {2, \"bar\"}, {3, \"baz\"}, {4, \"qux\"}};\n" + (fmt #f (c-var '(* (* foo)) 'table + '#(#(1 "foo") #(2 "bar") #(3 "baz") #(4 "qux"))))) + +(test "sexp (*f)(sexp, sexp) = NULL;\n" + (fmt #f (c-var '(%fun sexp (sexp sexp)) 'f 'NULL))) + +(test "sexp (*)(sexp) (*f)(sexp, sexp) = NULL;\n" + (fmt #f (c-var '(%fun (%fun sexp (sexp)) (sexp sexp)) 'f 'NULL))) + +(test "typedef double (*f)(double *, double, int);\n" + (fmt #f (c-typedef '(%fun double ((* double) double int)) 'f))) + +(test "\"foo\\tbar\";\n" + (fmt #f (c-expr "foo\tbar"))) + +(test-end) + diff --git a/functional-tests/fmt/test-fmt-js.scm b/functional-tests/fmt/test-fmt-js.scm new file mode 100644 index 0000000..e04ae05 --- /dev/null +++ b/functional-tests/fmt/test-fmt-js.scm @@ -0,0 +1,46 @@ + +(cond-expand + (chicken + (load "fmt-js-chicken.scm")) + (else)) + +(cond-expand + (chicken + (use test) + (import fmt) + (import fmt-js)) + (gauche + (use gauche.test) + (use text.fmt) + (use text.fmt.js) + (define test-begin test-start) + (define orig-test (with-module gauche.test test)) + (define-syntax test + (syntax-rules () + ((test name expected expr) + (orig-test name expected (lambda () expr))) + ((test expected expr) + (orig-test (let ((s (with-output-to-string (lambda () (write 'expr))))) + (substring s 0 (min 60 (string-length s)))) + expected + (lambda () expr))) + ))) + (else)) + +(test-begin "fmt-js") + +(test "var foo = 1 + 2;\n" + (fmt #f (js-expr '(%var foo (+ 1 2))))) + +(test "var foo = 1 + 2;\n" + (fmt #f (js-expr '(%begin (%var foo (+ 1 2)))))) + +(test "function square(x) { + return x * x; +}" + (fmt #f (js-function 'square '(x) '(* x x)))) + +(test "{\"foo\": [1, 2, 3], \"bar\": \"baz\"}" + (fmt #f (js-expr '(%object ("foo" . #(1 2 3)) ("bar" . "baz"))))) + +(test-end) diff --git a/functional-tests/fmt/test-fmt.scm b/functional-tests/fmt/test-fmt.scm new file mode 100644 index 0000000..4cc48f0 --- /dev/null +++ b/functional-tests/fmt/test-fmt.scm @@ -0,0 +1,486 @@ + +(cond-expand + (chicken + (load "fmt-chicken.scm")) + (else)) + +(cond-expand + (chicken + (use test) + (import fmt)) + (gauche + (use gauche.test) + (use text.fmt) + (define test-begin test-start) + (define orig-test (with-module gauche.test test)) + (define-syntax test + (syntax-rules () + ((test name expected expr) + (guard (e (else #f)) + (orig-test name expected (lambda () expr)))) + ((test expected expr) + (test (let ((s (with-output-to-string (lambda () (write 'expr))))) + (substring s 0 (min 60 (string-length s)))) + expected expr))))) + (else)) + +(test-begin "fmt") + +;; basic data types + +(test "hi" (fmt #f "hi")) +(test "\"hi\"" (fmt #f (wrt "hi"))) +(test "\"hi \\\"bob\\\"\"" (fmt #f (wrt "hi \"bob\""))) +(test "\"hello\\nworld\"" (fmt #f (wrt "hello\nworld"))) +(test "ABC" (fmt #f (upcase "abc"))) +(test "abc" (fmt #f (downcase "ABC"))) +(test "Abc" (fmt #f (titlecase "abc"))) + +(test "abc def" (fmt #f "abc" (tab-to) "def")) +(test "abc def" (fmt #f "abc" (tab-to 5) "def")) +(test "abcdef" (fmt #f "abc" (tab-to 3) "def")) + +(test "-1" (fmt #f -1)) +(test "0" (fmt #f 0)) +(test "1" (fmt #f 1)) +(test "10" (fmt #f 10)) +(test "100" (fmt #f 100)) +(test "-1" (fmt #f (num -1))) +(test "0" (fmt #f (num 0))) +(test "1" (fmt #f (num 1))) +(test "10" (fmt #f (num 10))) +(test "100" (fmt #f (num 100))) +;; (test "1e+15" (fmt #f (num 1e+15))) +;; (test "1e+23" (fmt #f (num 1e+23))) +;; (test "1.2e+23" (fmt #f (num 1.2e+23))) +;; (test "1e-5" (fmt #f (num 1e-5))) +;; (test "1e-6" (fmt #f (num 1e-6))) +;; (test "1e-7" (fmt #f (num 1e-7))) +;; (test "2e-6" (fmt #f (num 2e-6))) +(test "57005" (fmt #f #xDEAD)) +(test "#xDEAD" (fmt #f (radix 16 #xDEAD))) +(test "#xDEAD1234" (fmt #f (radix 16 #xDEAD) 1234)) +(test "#xDE.AD" (fmt #f (radix 16 (exact->inexact (/ #xDEAD #x100))))) +(test "#xD.EAD" (fmt #f (radix 16 (exact->inexact (/ #xDEAD #x1000))))) +(test "#x0.DEAD" (fmt #f (radix 16 (exact->inexact (/ #xDEAD #x10000))))) +(test "1G" (fmt #f (radix 17 (num 33)))) +(test "1G" (fmt #f (num 33 17))) + +(test "3.14159" (fmt #f 3.14159)) +(test "3.14" (fmt #f (fix 2 3.14159))) +(test "3.14" (fmt #f (fix 2 3.14))) +(test "3.00" (fmt #f (fix 2 3.))) +(test "1.10" (fmt #f (num 1.099 10 2))) +(test "0.00" (fmt #f (fix 2 1e-17))) +(test "0.0000000000" (fmt #f (fix 10 1e-17))) +(test "0.00000000000000001000" (fmt #f (fix 20 1e-17))) +;; (test-error (fmt #f (num 1e-17 0))) +(test "0.000004" (fmt #f (num 0.000004 10 6))) +(test "0.0000040" (fmt #f (num 0.000004 10 7))) +(test "0.00000400" (fmt #f (num 0.000004 10 8))) +;; (test "0.000004" (fmt #f (num 0.000004))) + +(test " 3.14159" (fmt #f (decimal-align 5 (num 3.14159)))) +(test " 31.4159" (fmt #f (decimal-align 5 (num 31.4159)))) +(test " 314.159" (fmt #f (decimal-align 5 (num 314.159)))) +(test "3141.59" (fmt #f (decimal-align 5 (num 3141.59)))) +(test "31415.9" (fmt #f (decimal-align 5 (num 31415.9)))) +(test " -3.14159" (fmt #f (decimal-align 5 (num -3.14159)))) +(test " -31.4159" (fmt #f (decimal-align 5 (num -31.4159)))) +(test "-314.159" (fmt #f (decimal-align 5 (num -314.159)))) +(test "-3141.59" (fmt #f (decimal-align 5 (num -3141.59)))) +(test "-31415.9" (fmt #f (decimal-align 5 (num -31415.9)))) + +(cond + ((exact? (/ 1 3)) ;; exact rationals + (test "333.333333333333333333333333333333" (fmt #f (fix 30 1000/3))) + (test "33.333333333333333333333333333333" (fmt #f (fix 30 100/3))) + (test "3.333333333333333333333333333333" (fmt #f (fix 30 10/3))) + (test "0.333333333333333333333333333333" (fmt #f (fix 30 1/3))) + (test "0.033333333333333333333333333333" (fmt #f (fix 30 1/30))) + (test "0.003333333333333333333333333333" (fmt #f (fix 30 1/300))) + (test "0.000333333333333333333333333333" (fmt #f (fix 30 1/3000))) + (test "0.666666666666666666666666666667" (fmt #f (fix 30 2/3))) + (test "0.090909090909090909090909090909" (fmt #f (fix 30 1/11))) + (test "1.428571428571428571428571428571" (fmt #f (fix 30 10/7))) + (test "0.123456789012345678901234567890" + (fmt #f (fix 30 (/ 123456789012345678901234567890 + 1000000000000000000000000000000)))) + (test " 333.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 1000/3)))) + (test " 33.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 100/3)))) + (test " 3.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 10/3)))) + (test " 0.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 1/3)))) + )) + +(test "11.75" (fmt #f (num (/ 47 4) 10 2))) +(test "-11.75" (fmt #f (num (/ -47 4) 10 2))) + +(test "(#x11 #x22 #x33)" (fmt #f (radix 16 '(#x11 #x22 #x33)))) + +(test "299,792,458" (fmt #f (num 299792458 10 #f #f #t))) +(test "299,792,458" (fmt #f (num/comma 299792458))) +(test "299.792.458" (fmt #f (comma-char #\. (num/comma 299792458)))) +(test "299.792.458,0" (fmt #f (comma-char #\. (num/comma 299792458.0)))) + +(test "100,000" (fmt #f (num 100000 10 0 #f 3))) +(test "100,000.0" (fmt #f (num 100000 10 1 #f 3))) +(test "100,000.00" (fmt #f (num 100000 10 2 #f 3))) + +(test "1.23" (fmt #f (fix 2 (num/fit 4 1.2345)))) +(test "1.00" (fmt #f (fix 2 (num/fit 4 1)))) +(test "#.##" (fmt #f (fix 2 (num/fit 4 12.345)))) + +;; (cond +;; ((feature? 'full-numeric-tower) +;; (test "1+2i" (fmt #f (string->number "1+2i"))) +;; (test "1+2i" (fmt #f (num (string->number "1+2i")))) +;; (test "1.00+2.00i" (fmt #f (fix 2 (num (string->number "1+2i"))))) +;; (test "3.14+2.00i" (fmt #f (fix 2 (num (string->number "3.14159+2i"))))))) + +(test "3.9Ki" (fmt #f (num/si 3986))) +(test "4k" (fmt #f (num/si 3986 1000))) +(test "608" (fmt #f (num/si 608))) +(test "3G" (fmt #f (num/si 12345.12355 16))) + +;; padding/trimming + +(test "abc " (fmt #f (pad 5 "abc"))) +(test " abc" (fmt #f (pad/left 5 "abc"))) +(test " abc " (fmt #f (pad/both 5 "abc"))) +(test "abcde" (fmt #f (pad 5 "abcde"))) +(test "abcdef" (fmt #f (pad 5 "abcdef"))) + +(test "abc" (fmt #f (trim 3 "abcde"))) +(test "abc" (fmt #f (trim/length 3 "abcde"))) +(test "abc" (fmt #f (trim/length 3 "abc\nde"))) +(test "cde" (fmt #f (trim/left 3 "abcde"))) +(test "bcd" (fmt #f (trim/both 3 "abcde"))) + +(test "prefix: abc" (fmt #f "prefix: " (trim 3 "abcde"))) +(test "prefix: abc" (fmt #f "prefix: " (trim/length 3 "abcde"))) +(test "prefix: abc" (fmt #f "prefix: " (trim/length 3 "abc\nde"))) +(test "prefix: cde" (fmt #f "prefix: " (trim/left 3 "abcde"))) +(test "prefix: bcd" (fmt #f "prefix: " (trim/both 3 "abcde"))) + +(test "abcde" (fmt #f (ellipses "..." (trim 5 "abcde")))) +(test "ab..." (fmt #f (ellipses "..." (trim 5 "abcdef")))) +(test "abc..." (fmt #f (ellipses "..." (trim 6 "abcdefg")))) +(test "abcde" (fmt #f (ellipses "..." (trim/left 5 "abcde")))) +(test "...ef" (fmt #f (ellipses "..." (trim/left 5 "abcdef")))) +(test "...efg" (fmt #f (ellipses "..." (trim/left 6 "abcdefg")))) +(test "abcdefg" (fmt #f (ellipses "..." (trim/both 7 "abcdefg")))) +(test "...d..." (fmt #f (ellipses "..." (trim/both 7 "abcdefgh")))) +(test "...e..." (fmt #f (ellipses "..." (trim/both 7 "abcdefghi")))) + +(test "abc " (fmt #f (fit 5 "abc"))) +(test " abc" (fmt #f (fit/left 5 "abc"))) +(test " abc " (fmt #f (fit/both 5 "abc"))) +(test "abcde" (fmt #f (fit 5 "abcde"))) +(test "abcde" (fmt #f (fit/left 5 "abcde"))) +(test "abcde" (fmt #f (fit/both 5 "abcde"))) +(test "abcde" (fmt #f (fit 5 "abcdefgh"))) +(test "defgh" (fmt #f (fit/left 5 "abcdefgh"))) +(test "cdefg" (fmt #f (fit/both 5 "abcdefgh"))) + +(test "prefix: abc " (fmt #f "prefix: " (fit 5 "abc"))) +(test "prefix: abc" (fmt #f "prefix: " (fit/left 5 "abc"))) +(test "prefix: abc " (fmt #f "prefix: " (fit/both 5 "abc"))) +(test "prefix: abcde" (fmt #f "prefix: " (fit 5 "abcde"))) +(test "prefix: abcde" (fmt #f "prefix: " (fit/left 5 "abcde"))) +(test "prefix: abcde" (fmt #f "prefix: " (fit/both 5 "abcde"))) +(test "prefix: abcde" (fmt #f "prefix: " (fit 5 "abcdefgh"))) +(test "prefix: defgh" (fmt #f "prefix: " (fit/left 5 "abcdefgh"))) +(test "prefix: cdefg" (fmt #f "prefix: " (fit/both 5 "abcdefgh"))) + +(test "abc\n123\n" (fmt #f (fmt-join/suffix (cut trim 3 <>) (string-split "abcdef\n123456\n" "\n") nl))) + +;; utilities + +(test "1 2 3" (fmt #f (fmt-join dsp '(1 2 3) " "))) + +;; shared structures + +(test "#0=(1 . #0#)" + (fmt #f (wrt (let ((ones (list 1))) (set-cdr! ones ones) ones)))) +(test "(0 . #0=(1 . #0#))" + (fmt #f (wrt (let ((ones (list 1))) + (set-cdr! ones ones) + (cons 0 ones))))) +(test "(sym . #0=(sym . #0#))" + (fmt #f (wrt (let ((syms (list 'sym))) + (set-cdr! syms syms) + (cons 'sym syms))))) +(test "(#0=(1 . #0#) #1=(2 . #1#))" + (fmt #f (wrt (let ((ones (list 1)) + (twos (list 2))) + (set-cdr! ones ones) + (set-cdr! twos twos) + (list ones twos))))) + +;; without shared detection + +(test "(1 1 1 1 1" + (fmt #f (trim/length + 10 + (wrt/unshared + (let ((ones (list 1))) (set-cdr! ones ones) ones))))) + +(test "(1 1 1 1 1 " + (fmt #f (trim/length + 11 + (wrt/unshared + (let ((ones (list 1))) (set-cdr! ones ones) ones))))) + +;; pretty printing + +;; (define-macro (test-pretty str) +;; (let ((sexp (with-input-from-string str read))) +;; `(test ,str (fmt #f (pretty ',sexp))))) + +(define-syntax test-pretty + (syntax-rules () + ((test-pretty str) + (let ((sexp (with-input-from-string str read))) + (test str (fmt #f (pretty sexp))))))) + +(test-pretty "(foo bar)\n") + +(test-pretty +"((self . aquanet-paper-1991) + (type . paper) + (title . \"Aquanet: a hypertext tool to hold your\")) +") + +(test-pretty +"(abracadabra xylophone + bananarama + yellowstonepark + cryptoanalysis + zebramania + delightful + wubbleflubbery)\n") + +(test-pretty + "#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 + 25 26 27 28 29 30 31 32 33 34 35 36 37)\n") + +(test-pretty + "(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 + 25 26 27 28 29 30 31 32 33 34 35 36 37)\n") + +(test-pretty + "(define (fold kons knil ls) + (define (loop ls acc) + (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))) + (loop ls knil))\n") + +(test-pretty +"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n") + +(test-pretty +"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) + (vector-set! vec i 'supercalifrajalisticexpialidocious))\n") + +(test-pretty +"(do ((my-vector (make-vector 5)) (index 0 (+ index 1))) + ((= index 5) my-vector) + (vector-set! my-vector index index))\n") + +(test-pretty + "(define (fold kons knil ls) + (let loop ((ls ls) (acc knil)) + (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n") + +(test-pretty + "(define (file->sexp-list pathname) + (call-with-input-file pathname + (lambda (port) + (let loop ((res '())) + (let ((line (read port))) + (if (eof-object? line) (reverse res) (loop (cons line res))))))))\n") + +(test "(let ((ones '#0=(1 . #0#))) ones)\n" + (fmt #f (pretty (let ((ones (list 1))) (set-cdr! ones ones) `(let ((ones ',ones)) ones))))) + +'(test +"(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + (ones '#0=(1 . #0#))) + (append zeros ones))\n" + (fmt #f (pretty + (let ((ones (list 1))) + (set-cdr! ones ones) + `(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)) + (ones ',ones)) + (append zeros ones)))))) + +;; slashify + +(test "\"note\",\"very simple\",\"csv\",\"writer\",\"\"\"yay!\"\"\"" + (fmt #f (fmt-join (lambda (x) (cat "\"" (slashified x #\" #f) "\"")) + '("note" "very simple" "csv" "writer" "\"yay!\"") + ","))) + +(test "note,\"very simple\",csv,writer,\"\"\"yay!\"\"\"" + (fmt #f (fmt-join (cut maybe-slashified <> char-whitespace? #\" #f) + '("note" "very simple" "csv" "writer" "\"yay!\"") + ","))) + +;; columnar formatting + +(test "abc\ndef\n" (fmt #f (fmt-columns (list dsp "abc\ndef\n")))) +(test "abc123\ndef456\n" (fmt #f (fmt-columns (list dsp "abc\ndef\n") (list dsp "123\n456\n")))) +(test "abc123\ndef456\n" (fmt #f (fmt-columns (list dsp "abc\ndef\n") (list dsp "123\n456")))) +(test "abc123\ndef456\n" (fmt #f (fmt-columns (list dsp "abc\ndef") (list dsp "123\n456\n")))) +(test "abc123\ndef456\nghi789\n" + (fmt #f (fmt-columns (list dsp "abc\ndef\nghi\n") (list dsp "123\n456\n789\n")))) +(test "abc123wuv\ndef456xyz\n" + (fmt #f (fmt-columns (list dsp "abc\ndef\n") (list dsp "123\n456\n") (list dsp "wuv\nxyz\n")))) +(test "abc 123\ndef 456\n" + (fmt #f (fmt-columns (list (cut pad/right 5 <>) "abc\ndef\n") (list dsp "123\n456\n")))) +(test "ABC 123\nDEF 456\n" + (fmt #f (fmt-columns (list (compose upcase (cut pad/right 5 <>)) "abc\ndef\n") + (list dsp "123\n456\n")))) +(test "ABC 123\nDEF 456\n" + (fmt #f (fmt-columns (list (compose (cut pad/right 5 <>) upcase) "abc\ndef\n") + (list dsp "123\n456\n")))) + +(test "hello\nworld\n" (fmt #f (with-width 8 (wrap-lines "hello world")))) +(test "\n" (fmt #f (wrap-lines " "))) + +(test ;; test divide by zero error + "The quick +brown fox +jumped +over the +lazy dog +" + (fmt #f (with-width 10 (justify "The quick brown fox jumped over the lazy dog")))) + +(test "his message +(http://lists.nongnu.org/archive/html/chicken-users/2010-10/msg00171.html) +to the chicken-users +(http://lists.nongnu.org/mailman/listinfo/chicken-users)\n" + (fmt #f (with-width 67 (wrap-lines "his message (http://lists.nongnu.org/archive/html/chicken-users/2010-10/msg00171.html) to the chicken-users (http://lists.nongnu.org/mailman/listinfo/chicken-users)")))) + +(test "The fundamental list iterator. +Applies KONS to each element of +LS and the result of the previous +application, beginning with KNIL. +With KONS as CONS and KNIL as '(), +equivalent to REVERSE. +" + (fmt #f (with-width 36 (wrap-lines "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE.")))) + +(test +"The fundamental list iterator. +Applies KONS to each element of +LS and the result of the previous +application, beginning with KNIL. +With KONS as CONS and KNIL as '(), +equivalent to REVERSE. +" + (fmt #f (with-width 36 (justify "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE.")))) + +(test +"(define (fold kons knil ls) ; The fundamental list iterator. + (let lp ((ls ls) (acc knil)) ; Applies KONS to each element of + (if (null? ls) ; LS and the result of the previous + acc ; application, beginning with KNIL. + (lp (cdr ls) ; With KONS as CONS and KNIL as '(), + (kons (car ls) acc))))) ; equivalent to REVERSE. +" + (fmt #f (fmt-columns + (list + (cut pad/right 36 <>) + (with-width 36 + (pretty '(define (fold kons knil ls) + (let lp ((ls ls) (acc knil)) + (if (null? ls) + acc + (lp (cdr ls) + (kons (car ls) acc)))))))) + (list + (cut cat " ; " <>) + (with-width 36 + (wrap-lines "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE.")))))) + +(test +"(define (fold kons knil ls) ; The fundamental list iterator. + (let lp ((ls ls) (acc knil)) ; Applies KONS to each element of + (if (null? ls) ; LS and the result of the previous + acc ; application, beginning with KNIL. + (lp (cdr ls) ; With KONS as CONS and KNIL as '(), + (kons (car ls) acc))))) ; equivalent to REVERSE. +" + (fmt #f (with-width 76 + (columnar + (pretty '(define (fold kons knil ls) + (let lp ((ls ls) (acc knil)) + (if (null? ls) + acc + (lp (cdr ls) + (kons (car ls) acc)))))) + " ; " + (wrap-lines "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))) + +(test +"- Item 1: The text here is + indented according + to the space \"Item + 1\" takes, and one + does not known what + goes here. +" + (fmt #f (columnar 9 (dsp "- Item 1:") " " (with-width 20 (wrap-lines "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here."))))) + +(test +"- Item 1: The text here is + indented according + to the space \"Item + 1\" takes, and one + does not known what + goes here. +" + (fmt #f (columnar 9 (dsp "- Item 1:\n") " " (with-width 20 (wrap-lines "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here."))))) + +(test +"- Item 1: The text here is---------------------------------------------------- +--------- indented according-------------------------------------------------- +--------- to the space \"Item-------------------------------------------------- +--------- 1\" takes, and one--------------------------------------------------- +--------- does not known what------------------------------------------------- +--------- goes here.---------------------------------------------------------- +" + (fmt #f (pad-char #\- (columnar 9 (dsp "- Item 1:\n") " " (with-width 20 (wrap-lines "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))) + +(test +"a | 123 +bc | 45 +def | 6 +" + (fmt #f (with-width + 20 + (tabular (dsp "a\nbc\ndef\n") " | " (dsp "123\n45\n6\n"))))) + +;; misc extras + +(define (string-hide-passwords str) + (string-substitute (regexp "(pass(?:w(?:or)?d)?\\s?[:=>]\\s+)\\S+" #t) + "\\1******" + str + #t)) + +(define hide-passwords + (make-string-fmt-transformer string-hide-passwords)) + +(define (string-mangle-email str) + (string-substitute + (regexp "\\b([-+.\\w]+)@((?:[-+\\w]+\\.)+[a-z]{2,4})\\b" #t) + "\\1 _at_ \\2" + str + #t)) + +(define mangle-email + (make-string-fmt-transformer string-mangle-email)) + +(test-end) diff --git a/functional-tests/fmt/test-round.scm b/functional-tests/fmt/test-round.scm new file mode 100644 index 0000000..a913aca --- /dev/null +++ b/functional-tests/fmt/test-round.scm @@ -0,0 +1,27 @@ + +(use fmt test) +;;(use numbers) ; test with and without numbers via -R numbers + +(define (check-representation n) + (define pence + (inexact->exact (round (/ (modulo n 1000) 10)))) + (define pounds (quotient n 1000)) + + (if (> pence 99) + (begin + (set! pence (- 100 pence)) + (set! pounds (add1 pounds)))) + + (define expected-result + (cond + ((= pence 0) (sprintf "~S.00" pounds)) + ((< pence 10) (sprintf "~S.0~S" pounds pence)) + (else (sprintf "~S.~S" pounds pence)))) + + (test (sprintf "~S = ~S?" (exact->inexact (/ n 1000)) expected-result) + expected-result + (fmt #f (num (/ n 1000) 10 2)))) + +(test-begin) +(for-each check-representation (iota 10000)) +(test-end) diff --git a/functional-tests/matchable.sls b/functional-tests/matchable.sls new file mode 100644 index 0000000..07660ef --- /dev/null +++ b/functional-tests/matchable.sls @@ -0,0 +1,1132 @@ +;;; Chez-Scheme Wrappers for Alex Shinn's Match (Wright Compatible) +;;; +;;; Copyright (c) 2016 Federico Beffa +;;; +;;; Permission to use, copy, modify, and distribute this software for +;;; any purpose with or without fee is hereby granted, provided that the +;;; above copyright notice and this permission notice appear in all +;;; copies. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA +;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +;;; PERFORMANCE OF THIS SOFTWARE. + +;; The reader in #!r6rs mode doesn't allow the '..1' identifier. +#!chezscheme +(library (matchable) + (export + match + match-lambda + match-lambda* + match-let + match-let* + match-letrec + match-named-let + :_ ___ ..1 *** ? $ struct @ object) + + #;(import + (rnrs base) + (rnrs lists) + (rnrs mutable-pairs) + (rnrs records syntactic) + (rnrs records procedural) + (rnrs records inspection) + (rnrs syntax-case) + (only (chezscheme) iota include) + ;; avoid dependence on chez-srfi (apart for tests) + ;; (srfi private aux-keywords) + ;; (srfi private include) + ) + (import (chezscheme)) + + ;; We declare end export the symbols used as auxiliary identifiers + ;; in 'syntax-rules' to make them work in Chez Scheme's interactive + ;; environment. (FBE) + + ;; Also we replaced '_' with ':_' as the special identifier matching + ;; anything and not binding. This is because R6RS forbids its use + ;; as an auxiliary literal in a syntax-rules form. + (define-syntax define-auxiliary-keyword + (syntax-rules () + [(_ name) + (define-syntax name + (lambda (x) + (syntax-violation #f "misplaced use of auxiliary keyword" x)))])) + + (define-syntax define-auxiliary-keywords + (syntax-rules () + [(_ name* ...) + (begin (define-auxiliary-keyword name*) ...)])) + + (define-auxiliary-keywords :_ ___ ..1 *** ? $ struct @ object) + + (define-syntax is-a? + (syntax-rules () + ((_ rec rtn) + (and (record? rec) + (eq? (record-type-name (record-rtd rec)) (quote rtn)))))) + + (define-syntax slot-ref + (syntax-rules () + ((_ rtn rec n) + (if (number? n) + ((record-accessor (record-rtd rec) n) rec) + ;; If it's not a number, then it should be a symbol with + ;; the name of a field. + (let* ((rtd (record-rtd rec)) + (fields (record-type-field-names rtd)) + (fields-idxs (map (lambda (f i) (cons f i)) + (vector->list fields) + (iota (vector-length fields)))) + (idx (cdr (assv n fields-idxs)))) + ((record-accessor rtd idx) rec)))))) + + (define-syntax slot-set! + (syntax-rules () + ((_ rtn rec n) + (if (number? n) + ((record-mutator (record-rtd rec) n) rec) + ;; If it's not a number, then it should be a symbol with + ;; the name of a field. + (let* ((rtd (record-rtd rec)) + (fields (record-type-field-names rtd)) + (fields-idxs (map (lambda (f i) (cons f i)) + (vector->list fields) + (iota (vector-length fields)))) + (idx (cdr (assv n fields-idxs)))) + ((record-mutator rtd idx) rec)))))) + +;;;; match.scm -- portable hygienic pattern matcher -*- coding: utf-8 -*- + ;; + ;; This code is written by Alex Shinn and placed in the + ;; Public Domain. All warranties are disclaimed. + + ;;> \example-import[(srfi 9)] + + ;;> A portable hygienic pattern matcher. + + ;;> This is a full superset of the popular \hyperlink[ + ;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match} + ;;> package by Andrew Wright, written in fully portable \scheme{syntax-rules} + ;;> and thus preserving hygiene. + + ;;> The most notable extensions are the ability to use \emph{non-linear} + ;;> patterns - patterns in which the same identifier occurs multiple + ;;> times, tail patterns after ellipsis, and the experimental tree patterns. + + ;;> \section{Patterns} + + ;;> Patterns are written to look like the printed representation of + ;;> the objects they match. The basic usage is + + ;;> \scheme{(match expr (pat body ...) ...)} + + ;;> where the result of \var{expr} is matched against each pattern in + ;;> turn, and the corresponding body is evaluated for the first to + ;;> succeed. Thus, a list of three elements matches a list of three + ;;> elements. + + ;;> \example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))} + + ;;> If no patterns match an error is signalled. + + ;;> Identifiers will match anything, and make the corresponding + ;;> binding available in the body. + + ;;> \example{(match (list 1 2 3) ((a b c) b))} + + ;;> If the same identifier occurs multiple times, the first instance + ;;> will match anything, but subsequent instances must match a value + ;;> which is \scheme{equal?} to the first. + + ;;> \example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))} + + ;;> The special identifier \scheme{_} matches anything, no matter how + ;;> many times it is used, and does not bind the result in the body. + + ;;> \example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))} + + ;;> To match a literal identifier (or list or any other literal), use + ;;> \scheme{quote}. + + ;;> \example{(match 'a ('b 1) ('a 2))} + + ;;> Analogous to its normal usage in scheme, \scheme{quasiquote} can + ;;> be used to quote a mostly literally matching object with selected + ;;> parts unquoted. + + ;;> \example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}| + + ;;> Often you want to match any number of a repeated pattern. Inside + ;;> a list pattern you can append \scheme{...} after an element to + ;;> match zero or more of that pattern (like a regexp Kleene star). + + ;;> \example{(match (list 1 2) ((1 2 3 ...) #t))} + ;;> \example{(match (list 1 2 3) ((1 2 3 ...) #t))} + ;;> \example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))} + + ;;> Pattern variables matched inside the repeated pattern are bound to + ;;> a list of each matching instance in the body. + + ;;> \example{(match (list 1 2) ((a b c ...) c))} + ;;> \example{(match (list 1 2 3) ((a b c ...) c))} + ;;> \example{(match (list 1 2 3 4 5) ((a b c ...) c))} + + ;;> More than one \scheme{...} may not be used in the same list, since + ;;> this would require exponential backtracking in the general case. + ;;> However, \scheme{...} need not be the final element in the list, + ;;> and may be succeeded by a fixed number of patterns. + + ;;> \example{(match (list 1 2 3 4) ((a b c ... d e) c))} + ;;> \example{(match (list 1 2 3 4 5) ((a b c ... d e) c))} + ;;> \example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))} + + ;;> \scheme{___} is provided as an alias for \scheme{...} when it is + ;;> inconvenient to use the ellipsis (as in a syntax-rules template). + + ;;> The \scheme{..1} syntax is exactly like the \scheme{...} except + ;;> that it matches one or more repetitions (like a regexp "+"). + + ;;> \example{(match (list 1 2) ((a b c ..1) c))} + ;;> \example{(match (list 1 2 3) ((a b c ..1) c))} + + ;;> The boolean operators \scheme{and}, \scheme{or} and \scheme{not} + ;;> can be used to group and negate patterns analogously to their + ;;> Scheme counterparts. + + ;;> The \scheme{and} operator ensures that all subpatterns match. + ;;> This operator is often used with the idiom \scheme{(and x pat)} to + ;;> bind \var{x} to the entire value that matches \var{pat} + ;;> (c.f. "as-patterns" in ML or Haskell). Another common use is in + ;;> conjunction with \scheme{not} patterns to match a general case + ;;> with certain exceptions. + + ;;> \example{(match 1 ((and) #t))} + ;;> \example{(match 1 ((and x) x))} + ;;> \example{(match 1 ((and x 1) x))} + + ;;> The \scheme{or} operator ensures that at least one subpattern + ;;> matches. If the same identifier occurs in different subpatterns, + ;;> it is matched independently. All identifiers from all subpatterns + ;;> are bound if the \scheme{or} operator matches, but the binding is + ;;> only defined for identifiers from the subpattern which matched. + + ;;> \example{(match 1 ((or) #t) (else #f))} + ;;> \example{(match 1 ((or x) x))} + ;;> \example{(match 1 ((or x 2) x))} + + ;;> The \scheme{not} operator succeeds if the given pattern doesn't + ;;> match. None of the identifiers used are available in the body. + + ;;> \example{(match 1 ((not 2) #t))} + + ;;> The more general operator \scheme{?} can be used to provide a + ;;> predicate. The usage is \scheme{(? predicate pat ...)} where + ;;> \var{predicate} is a Scheme expression evaluating to a predicate + ;;> called on the value to match, and any optional patterns after the + ;;> predicate are then matched as in an \scheme{and} pattern. + + ;;> \example{(match 1 ((? odd? x) x))} + + ;;> The field operator \scheme{=} is used to extract an arbitrary + ;;> field and match against it. It is useful for more complex or + ;;> conditional destructuring that can't be more directly expressed in + ;;> the pattern syntax. The usage is \scheme{(= field pat)}, where + ;;> \var{field} can be any expression, and should result in a + ;;> procedure of one argument, which is applied to the value to match + ;;> to generate a new value to match against \var{pat}. + + ;;> Thus the pattern \scheme{(and (= car x) (= cdr y))} is equivalent + ;;> to \scheme{(x . y)}, except it will result in an immediate error + ;;> if the value isn't a pair. + + ;;> \example{(match '(1 . 2) ((= car x) x))} + ;;> \example{(match 4 ((= square x) x))} + + ;;> The record operator \scheme{$} is used as a concise way to match + ;;> records defined by SRFI-9 (or SRFI-99). The usage is + ;;> \scheme{($ rtd field ...)}, where \var{rtd} should be the record + ;;> type descriptor specified as the first argument to + ;;> \scheme{define-record-type}, and each \var{field} is a subpattern + ;;> matched against the fields of the record in order. Not all fields + ;;> must be present. + + ;;> \example{ + ;;> (let () + ;;> (define-record-type employee + ;;> (make-employee name title) + ;;> employee? + ;;> (name get-name) + ;;> (title get-title)) + ;;> (match (make-employee "Bob" "Doctor") + ;;> (($ employee n t) (list t n)))) + ;;> } + + ;;> For records with more fields it can be helpful to match them by + ;;> name rather than position. For this you can use the \scheme{@} + ;;> operator, originally a Gauche extension: + + ;;> \example{ + ;;> (let () + ;;> (define-record-type employee + ;;> (make-employee name title) + ;;> employee? + ;;> (name get-name) + ;;> (title get-title)) + ;;> (match (make-employee "Bob" "Doctor") + ;;> ((@ employee (title t) (name n)) (list t n)))) + ;;> } + + ;;> The \scheme{set!} and \scheme{get!} operators are used to bind an + ;;> identifier to the setter and getter of a field, respectively. The + ;;> setter is a procedure of one argument, which mutates the field to + ;;> that argument. The getter is a procedure of no arguments which + ;;> returns the current value of the field. + + ;;> \example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))} + ;;> \example{(match '(1 . 2) ((1 . (get! g)) (g)))} + + ;;> The new operator \scheme{***} can be used to search a tree for + ;;> subpatterns. A pattern of the form \scheme{(x *** y)} represents + ;;> the subpattern \var{y} located somewhere in a tree where the path + ;;> from the current object to \var{y} can be seen as a list of the + ;;> form \scheme{(x ...)}. \var{y} can immediately match the current + ;;> object in which case the path is the empty list. In a sense it's + ;;> a 2-dimensional version of the \scheme{...} pattern. + + ;;> As a common case the pattern \scheme{(_ *** y)} can be used to + ;;> search for \var{y} anywhere in a tree, regardless of the path + ;;> used. + + ;;> \example{(match '(a (a (a b))) ((x *** 'b) x))} + ;;> \example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))} + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Notes + + ;; The implementation is a simple generative pattern matcher - each + ;; pattern is expanded into the required tests, calling a failure + ;; continuation if the tests fail. This makes the logic easy to + ;; follow and extend, but produces sub-optimal code in cases where you + ;; have many similar clauses due to repeating the same tests. + ;; Nonetheless a smart compiler should be able to remove the redundant + ;; tests. For MATCH-LET and DESTRUCTURING-BIND type uses there is no + ;; performance hit. + + ;; The original version was written on 2006/11/29 and described in the + ;; following Usenet post: + ;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd + ;; and is still available at + ;; http://synthcode.com/scheme/match-simple.scm + ;; It's just 80 lines for the core MATCH, and an extra 40 lines for + ;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. + ;; + ;; A variant of this file which uses COND-EXPAND in a few places for + ;; performance can be found at + ;; http://synthcode.com/scheme/match-cond-expand.scm + ;; + ;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe) + ;; 2015/05/09 - fixing bug in var extraction of quasiquote patterns + ;; 2014/11/24 - adding Gauche's `@' pattern for named record field matching + ;; 2012/12/26 - wrapping match-let&co body in lexical closure + ;; 2012/11/28 - fixing typo s/vetor/vector in largely unused set! code + ;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns + ;; 2011/09/25 - fixing bug when directly matching an identifier repeated in + ;; the pattern (thanks to Stefan Israelsson Tampe) + ;; 2011/01/27 - fixing bug when matching tail patterns against improper lists + ;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès) + ;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns + ;; 2009/11/25 - adding `***' tree search patterns + ;; 2008/03/20 - fixing bug where (a ...) matched non-lists + ;; 2008/03/15 - removing redundant check in vector patterns + ;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) + ;; 2007/09/04 - fixing quasiquote patterns + ;; 2007/07/21 - allowing ellipsis patterns in non-final list positions + ;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipsis + ;; (thanks to Taylor Campbell) + ;; 2007/04/08 - clean up, commenting + ;; 2006/12/24 - bugfixes + ;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; force compile-time syntax errors with useful messages + + (define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;;> \section{Syntax} + + ;;> \macro{(match expr (pattern . body) ...)\br{} + ;;> (match expr (pattern (=> failure) . body) ...)} + + ;;> The result of \var{expr} is matched against each \var{pattern} in + ;;> turn, according to the pattern rules described in the previous + ;;> section, until the the first \var{pattern} matches. When a match is + ;;> found, the corresponding \var{body}s are evaluated in order, + ;;> and the result of the last expression is returned as the result + ;;> of the entire \scheme{match}. If a \var{failure} is provided, + ;;> then it is bound to a procedure of no arguments which continues, + ;;> processing at the next \var{pattern}. If no \var{pattern} matches, + ;;> an error is signalled. + + ;; The basic interface. MATCH just performs some basic syntax + ;; validation, binds the match expression to a temporary variable `v', + ;; and passes it on to MATCH-NEXT. It's a constant throughout the + ;; code below that the binding `v' is a direct variable reference, not + ;; an expression. + + (define-syntax match + (syntax-rules () + ((match) + (match-syntax-error "missing match expression")) + ((match atom) + (match-syntax-error "no match clauses")) + ((match (app ...) (pat . body) ...) + (let ((v (app ...))) + (match-next v ((app ...) (set! (app ...))) (pat . body) ...))) + ((match #(vec ...) (pat . body) ...) + (let ((v #(vec ...))) + (match-next v (v (set! v)) (pat . body) ...))) + ((match atom (pat . body) ...) + (let ((v atom)) + (match-next v (atom (set! atom)) (pat . body) ...))) + )) + + ;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure + ;; thunk, which is expanded by recursing MATCH-NEXT on the remaining + ;; clauses. `g+s' is a list of two elements, the get! and set! + ;; expressions respectively. + + (define-syntax match-next + (syntax-rules (=>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern" v)) + ;; named failure continuation + ((match-next v g+s (pat (=> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=> failure) . body) . rest)))) + + ;; MATCH-ONE first checks for ellipsis patterns, otherwise passes on to + ;; MATCH-TWO. + + (define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipsis and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipsis + q + (match-extract-vars p (match-gen-ellipsis v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + + ;; This is the guts of the pattern matcher. We are passed a lot of + ;; information in the form: + ;; + ;; (match-two var pattern getter setter success-k fail-k (ids ...)) + ;; + ;; usually abbreviated + ;; + ;; (match-two v p g+s sk fk i) + ;; + ;; where VAR is the symbol name of the current variable we are + ;; matching, PATTERN is the current pattern, getter and setter are the + ;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding + ;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure + ;; continuation (which is just a thunk call and is thus safe to expand + ;; multiple times) and IDS are the list of identifiers bound in the + ;; pattern so far. + + ;; Replace '_' with ':_' as the former is forbidden as an auxiliariy + ;; keyword in R6RS. (FBE) + (define-syntax match-two + (syntax-rules (:_ ___ ..1 *** quote quasiquote ? $ struct @ object = and or not set! get!) + ((match-two v () g+s (sk ...) fk i) + (if (null? v) (sk ... i) fk)) + ((match-two v (quote p) g+s (sk ...) fk i) + (if (equal? v 'p) (sk ... i) fk)) + ((match-two v (quasiquote p) . x) + (match-quasiquote v p . x)) + ((match-two v (and) g+s (sk ...) fk i) (sk ... i)) + ((match-two v (and p q ...) g+s sk fk i) + (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i)) + ((match-two v (or) g+s sk fk i) fk) + ((match-two v (or p) . x) + (match-one v p . x)) + ((match-two v (or p ...) g+s sk fk i) + (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ())) + ((match-two v (not p) g+s (sk ...) fk i) + (match-one v p g+s (match-drop-ids fk) (sk ... i) i)) + ((match-two v (get! getter) (g s) (sk ...) fk i) + (let ((getter (lambda () g))) (sk ... i))) + ((match-two v (set! setter) (g (s ...)) (sk ...) fk i) + (let ((setter (lambda (x) (s ... x)))) (sk ... i))) + ((match-two v (? pred . p) g+s sk fk i) + (if (pred v) (match-one v (and . p) g+s sk fk i) fk)) + ((match-two v (= proc p) . x) + (let ((w (proc v))) (match-one w p . x))) + ((match-two v (p ___ . r) g+s sk fk i) + (match-extract-vars p (match-gen-ellipsis v p r g+s sk fk i) i ())) + ((match-two v (p) g+s sk fk i) + (if (and (pair? v) (null? (cdr v))) + (let ((w (car v))) + (match-one w p ((car v) (set-car! v)) sk fk i)) + fk)) + ((match-two v (p *** q) g+s sk fk i) + (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) + ((match-two v (p *** . q) g+s sk fk i) + (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v (p ..1) g+s sk fk i) + (if (pair? v) + (match-one v (p ___) g+s sk fk i) + fk)) + ((match-two v ($ rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-refs v rec 0 (p ...) g+s sk fk i) + fk)) + ((match-two v (struct rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-refs v rec 0 (p ...) g+s sk fk i) + fk)) + ((match-two v (@ rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-named-refs v rec (p ...) g+s sk fk i) + fk)) + ((match-two v (object rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-named-refs v rec (p ...) g+s sk fk i) + fk)) + ((match-two v (p . q) g+s sk fk i) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-one w p ((car v) (set-car! v)) + (match-one x q ((cdr v) (set-cdr! v)) sk fk) + fk + i)) + fk)) + ((match-two v #(p ...) g+s . x) + (match-vector v 0 () (p ...) . x)) + ;; Next line: replace '_' with ':_'. (FBE) + ((match-two v :_ g+s (sk ...) fk i) (sk ... i)) + ;; Not a pair or vector or special literal, test to see if it's a + ;; new symbol, in which case we just bind it, or if it's an + ;; already bound symbol or some other literal, in which case we + ;; compare it with EQUAL?. + ((match-two v x g+s (sk ...) fk (id ...)) + (let-syntax + ((new-sym? + (syntax-rules (id ...) + ((new-sym? x sk2 fk2) sk2) + ((new-sym? y sk2 fk2) fk2)))) + (new-sym? random-sym-to-match + (let ((x v)) (sk ... (id ... x))) + (if (equal? v x) (sk ... (id ...)) fk)))) + )) + + ;; QUASIQUOTE patterns + + (define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + + (define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Utilities + + ;; Takes two values and just expands into the first. + (define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + + (define-syntax match-tuck-ids + (syntax-rules () + ((_ (letish args (expr ...)) ids ...) + (letish args (expr ... ids ...))))) + + (define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + + ;; To expand an OR group we try each clause in succession, passing the + ;; first that succeeds to the success continuation. On failure for + ;; any clause, we just try the next clause, finally resorting to the + ;; failure continuation fk if all clauses fail. The only trick is + ;; that we want to unify the identifiers, so that the success + ;; continuation can refer to a variable from any of the OR clauses. + + (define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)))))) + + (define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i)))) + (match-one v p g+s sk (fk2) i))) + )) + + ;; We match a pattern (p ...) by matching the pattern p in a loop on + ;; each element of the variable, accumulating the bound ids into lists. + + ;; Look at the body of the simple case - it's just a named let loop, + ;; matching each element in turn to the same pattern. The only trick + ;; is that we want to keep track of the lists of each extracted id, so + ;; when the loop recurses we cons the ids onto their respective list + ;; variables, and on success we bind the ids (what the user input and + ;; expects to see in the success body) to the reversed accumulated + ;; list IDs. + + (define-syntax match-gen-ellipsis + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipsis + r + (let* ((tail-len (length 'r)) + (ls v) + (len (and (list? ls) (length ls)))) + (if (or (not len) (< len tail-len)) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((= n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ...) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + + ;; This is just a safety check. Although unlike syntax-rules we allow + ;; trailing patterns after an ellipsis, we explicitly disable multiple + ;; ellipsis at the same level. This is because in the general case + ;; such patterns are exponential in the number of ellipsis, and we + ;; don't want to make it easy to construct very expensive operations + ;; with simple looking patterns. For example, it would be O(n^2) for + ;; patterns like (a ... b ...) because we must consider every trailing + ;; element for every possible break for the leading "a ...". + + (define-syntax match-verify-no-ellipsis + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipsis + x + (match-syntax-error + "multiple ellipsis patterns not allowed at same level") + (match-verify-no-ellipsis y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipsis" x)))) + + ;; To implement the tree search, we use two recursive procedures. TRY + ;; attempts to match Y once, and on success it calls the normal SK on + ;; the accumulated list ids as in MATCH-GEN-ELLIPSIS. On failure, we + ;; call NEXT which first checks if the current value is a list + ;; beginning with X, then calls TRY on each remaining element of the + ;; list. Since TRY will recursively call NEXT again on failure, this + ;; effects a full depth-first search. + ;; + ;; The failure continuation throughout is a jump to the next step in + ;; the tree search, initialized with the original failure continuation + ;; FK. + + (define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-tuck-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + + ;; Vector patterns are just more of the same, with the slight + ;; exception that we pass around the current vector index being + ;; matched. + + (define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipsis q + (match-gen-vector-ellipsis v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipsis v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + + ;; Check the exact vector length, then check each element in turn. + + (define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (= len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + + (define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + + ;; With a vector ellipsis pattern we first check to see if the vector + ;; length is at least the required length. + + (define-syntax match-gen-vector-ellipsis + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>= len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + + (define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) + + (define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>= j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vector-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + + (define-syntax match-record-refs + (syntax-rules () + ((_ v rec n (p . q) g+s sk fk i) + (let ((w (slot-ref rec v n))) + (match-one w p ((slot-ref rec v n) (slot-set! rec v n)) + (match-record-refs v rec (+ n 1) q g+s sk fk) fk i))) + ((_ v rec n () g+s (sk ...) fk i) + (sk ... i)))) + + (define-syntax match-record-named-refs + (syntax-rules () + ((_ v rec ((f p) . q) g+s sk fk i) + (let ((w (slot-ref rec v 'f))) + (match-one w p ((slot-ref rec v 'f) (slot-set! rec v 'f)) + (match-record-named-refs v rec q g+s sk fk) fk i))) + ((_ v rec () g+s (sk ...) fk i) + (sk ... i)))) + + ;; Extract all identifiers in a pattern. A little more complicated + ;; than just looking for symbols, we need to ignore special keywords + ;; and non-pattern forms (such as the predicate expression in ? + ;; patterns), and also ignore previously bound identifiers. + ;; + ;; Calls the continuation with all new vars as a list of the form + ;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely + ;; pair with the original variable (e.g. it's used in the ellipsis + ;; generation for list variables). + ;; + ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + + ;; Replace '_' with ':_' as the former is forbidden as an auxiliariy + ;; keyword in R6RS. (FBE) + (define-syntax match-extract-vars + (syntax-rules (:_ ___ ..1 *** ? $ struct @ object = quote quasiquote and or not get! set!) + ((match-extract-vars (? pred . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars ($ rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (struct rec . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (@ rec (f p) ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars (object rec (f p) ...) . x) + (match-extract-vars (p ...) . x)) + ((match-extract-vars (= proc p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (quote x) (k ...) i v) + (k ... v)) + ((match-extract-vars (quasiquote x) k i v) + (match-extract-quasiquote-vars x k i v (#t))) + ((match-extract-vars (and . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (or . p) . x) + (match-extract-vars p . x)) + ((match-extract-vars (not . p) . x) + (match-extract-vars p . x)) + ;; A non-keyword pair, expand the CAR with a continuation to + ;; expand the CDR. + ((match-extract-vars (p q . r) k i v) + (match-check-ellipsis + q + (match-extract-vars (p . r) k i v) + (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) + ((match-extract-vars (p . q) k i v) + (match-extract-vars p (match-extract-vars-step q k i v) i ())) + ((match-extract-vars #(p ...) . x) + (match-extract-vars (p ...) . x)) + ;; Next line: replace '_' with ':_'. (FBE) + ((match-extract-vars :_ (k ...) i v) (k ... v)) + ((match-extract-vars ___ (k ...) i v) (k ... v)) + ((match-extract-vars *** (k ...) i v) (k ... v)) + ((match-extract-vars ..1 (k ...) i v) (k ... v)) + ;; This is the main part, the only place where we might add a new + ;; var if it's an unbound symbol. + ((match-extract-vars p (k ...) (i ...) v) + (let-syntax + ((new-sym? + (syntax-rules (i ...) + ((new-sym? p sk fk) sk) + ((new-sym? any sk fk) fk)))) + (new-sym? random-sym-to-match + (k ... ((p p-ls) . v)) + (k ... v)))) + )) + + ;; Stepper used in the above so it can expand the CAR and CDR + ;; separately. + + (define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + + (define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v d) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i () d)) + ((match-extract-quasiquote-vars #(x ...) k i v d) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v d) + (k ... v)) + )) + + (define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Gimme some sugar baby. + + ;;> Shortcut for \scheme{lambda} + \scheme{match}. Creates a + ;;> procedure of one argument, and matches that argument against each + ;;> clause. + + (define-syntax match-lambda + (syntax-rules () + ((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...))))) + + ;;> Similar to \scheme{match-lambda}. Creates a procedure of any + ;;> number of arguments, and matches the argument list against each + ;;> clause. + + (define-syntax match-lambda* + (syntax-rules () + ((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...))))) + + ;;> Matches each var to the corresponding expression, and evaluates + ;;> the body with all match variables in scope. Raises an error if + ;;> any of the expressions fail to match. Syntax analogous to named + ;;> let can also be used for recursive functions which match on their + ;;> arguments as in \scheme{match-lambda*}. + + (define-syntax match-let + (syntax-rules () + ((_ ((var value) ...) . body) + (match-let/helper let () () ((var value) ...) . body)) + ((_ loop ((var init) ...) . body) + (match-named-let loop () ((var init) ...) . body)))) + + ;;> Similar to \scheme{match-let}, but analogously to \scheme{letrec} + ;;> matches and binds the variables with all match variables in scope. + + (define-syntax match-letrec + (syntax-rules () + ((_ ((var value) ...) . body) + (match-let/helper letrec () () ((var value) ...) . body)))) + + (define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + + (define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + + ;;> \macro{(match-let* ((var value) ...) body ...)} + + ;;> Similar to \scheme{match-let}, but analogously to \scheme{let*} + ;;> matches and binds the variables in sequence, with preceding match + ;;> variables in scope. + + (define-syntax match-let* + (syntax-rules () + ((_ () . body) + (let () . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Otherwise COND-EXPANDed bits. + + ;; To avoid depending on srfi-0 we comment the following form and copy + ;; the generic version below it. (FBE) + + ;; (cond-expand + ;; (chibi + ;; (define-syntax match-check-ellipsis + ;; (er-macro-transformer + ;; (lambda (expr rename compare) + ;; (if (compare '... (cadr expr)) + ;; (car (cddr expr)) + ;; (cadr (cddr expr)))))) + ;; (define-syntax match-check-identifier + ;; (er-macro-transformer + ;; (lambda (expr rename compare) + ;; (if (identifier? (cadr expr)) + ;; (car (cddr expr)) + ;; (cadr (cddr expr))))))) + + ;; (else + ;; ;; Portable versions + ;; ;; + ;; ;; This *should* work, but doesn't :( + ;; ;; (define-syntax match-check-ellipsis + ;; ;; (syntax-rules (...) + ;; ;; ((_ ... sk fk) sk) + ;; ;; ((_ x sk fk) fk))) + ;; ;; + ;; ;; This is a little more complicated, and introduces a new let-syntax, + ;; ;; but should work portably in any R[56]RS Scheme. Taylor Campbell + ;; ;; originally came up with the idea. + ;; (define-syntax match-check-ellipsis + ;; (syntax-rules () + ;; ;; these two aren't necessary but provide fast-case failures + ;; ((match-check-ellipsis (a . b) success-k failure-k) failure-k) + ;; ((match-check-ellipsis #(a ...) success-k failure-k) failure-k) + ;; ;; matching an atom + ;; ((match-check-ellipsis id success-k failure-k) + ;; (let-syntax ((ellipsis? (syntax-rules () + ;; ;; iff `id' is `...' here then this will + ;; ;; match a list of any length + ;; ((ellipsis? (foo id) sk fk) sk) + ;; ((ellipsis? other sk fk) fk)))) + ;; ;; this list of three elements will only match the (foo id) list + ;; ;; above if `id' is `...' + ;; (ellipsis? (a b c) success-k failure-k))))) + + ;; ;; This is portable but can be more efficient with non-portable + ;; ;; extensions. This trick was originally discovered by Oleg Kiselyov. + ;; (define-syntax match-check-identifier + ;; (syntax-rules () + ;; ;; fast-case failures, lists and vectors are not identifiers + ;; ((_ (x . y) success-k failure-k) failure-k) + ;; ((_ #(x ...) success-k failure-k) failure-k) + ;; ;; x is an atom + ;; ((_ x success-k failure-k) + ;; (let-syntax + ;; ((sym? + ;; (syntax-rules () + ;; ;; if the symbol `abracadabra' matches x, then x is a + ;; ;; symbol + ;; ((sym? x sk fk) sk) + ;; ;; otherwise x is a non-symbol datum + ;; ((sym? y sk fk) fk)))) + ;; (sym? abracadabra success-k failure-k))))))) + + ;; Portable versions + ;; + ;; This *should* work, but doesn't :( + ;; (define-syntax match-check-ellipsis + ;; (syntax-rules (...) + ;; ((_ ... sk fk) sk) + ;; ((_ x sk fk) fk))) + ;; + ;; This is a little more complicated, and introduces a new let-syntax, + ;; but should work portably in any R[56]RS Scheme. Taylor Campbell + ;; originally came up with the idea. + (define-syntax match-check-ellipsis + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipsis (a . b) success-k failure-k) failure-k) + ((match-check-ellipsis #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipsis id success-k failure-k) + (let-syntax ((ellipsis? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipsis? (foo id) sk fk) sk) + ((ellipsis? other sk fk) fk)))) + ;; this list of three elements will only match the (foo id) list + ;; above if `id' is `...' + (ellipsis? (a b c) success-k failure-k))))) + + ;; This is portable but can be more efficient with non-portable + ;; extensions. This trick was originally discovered by Oleg Kiselyov. + (define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) + ) diff --git a/functional-tests/run-tests b/functional-tests/run-tests index 8def1f7..865a78f 100755 --- a/functional-tests/run-tests +++ b/functional-tests/run-tests @@ -1,14 +1,4 @@ -#! /usr/bin/scheme-script +#!/bin/sh -(import (rnrs) - (test-runner) - (cache-functional-tests) - (era-functional-tests) - (thin-functional-tests)) - -(register-thin-tests) -(register-cache-tests) -(register-era-tests) - -(run-tests) +scheme --libdirs . --program run-tests.scm $* diff --git a/functional-tests/run-tests.scm b/functional-tests/run-tests.scm new file mode 100644 index 0000000..805a3a1 --- /dev/null +++ b/functional-tests/run-tests.scm @@ -0,0 +1,12 @@ +(import (rnrs) + (test-runner) + (cache-functional-tests) + (era-functional-tests) + (thin-functional-tests)) + +(register-thin-tests) +(register-cache-tests) +(register-era-tests) + +(run-tests) + diff --git a/functional-tests/srfi/LICENSE b/functional-tests/srfi/LICENSE new file mode 100644 index 0000000..4b54782 --- /dev/null +++ b/functional-tests/srfi/LICENSE @@ -0,0 +1,32 @@ +The following license applies to all files written by Derick Eddington, +unless otherwise stated. + +=========================================================================== + Copyright (c) 2008-2009 Derick Eddington + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation + the rights to use, copy, modify, merge, publish, distribute, sublicense, + and/or sell copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + Except as contained in this notice, the name(s) of the above copyright + holders shall not be used in advertising or otherwise to promote the sale, + use or other dealings in this Software without prior written authorization. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + DEALINGS IN THE SOFTWARE. +=========================================================================== + + +Files written by others retain any copyright, license, and/or other notice +they originally had. diff --git a/functional-tests/srfi/README b/functional-tests/srfi/README new file mode 100644 index 0000000..b9bb60d --- /dev/null +++ b/functional-tests/srfi/README @@ -0,0 +1,17 @@ + +There is an existing R6RS srfi project at: + +https://code.launchpad.net/~scheme-libraries-team/scheme-libraries/srfi + +In that project, the library names use the colon character. E.g.: + + (srfi :1 lists) + +Filenames with a colon are not portable across UNIX and Windows. Some +Scheme implementations support an encoding whereby ':1' is +mapped to '%3a1'. Chez Scheme does not perform the conversion. + +The surfage libraries are a port of the R6RS srfi libraries to have +names such as: + + (surfage s1 lists) diff --git a/functional-tests/srfi/private/OS-id-features.sls b/functional-tests/srfi/private/OS-id-features.sls new file mode 100644 index 0000000..e39079b --- /dev/null +++ b/functional-tests/srfi/private/OS-id-features.sls @@ -0,0 +1,25 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi private OS-id-features) + (export + OS-id-features) + (import + (rnrs)) + + (define (OS-id-features OS-id features-alist) + (define OS-id-len (string-length OS-id)) + (define (OS-id-contains? str) + (define str-len (string-length str)) + (let loop ((i 0)) + (and (<= (+ i str-len) OS-id-len) + (or (string-ci=? str (substring OS-id i (+ i str-len))) + (loop (+ 1 i)))))) + (apply append + (map cdr (filter (lambda (x) (OS-id-contains? (car x))) + features-alist)))) +) diff --git a/functional-tests/srfi/private/auxiliary-keyword.sls b/functional-tests/srfi/private/auxiliary-keyword.sls new file mode 100644 index 0000000..e184e90 --- /dev/null +++ b/functional-tests/srfi/private/auxiliary-keyword.sls @@ -0,0 +1,18 @@ + +#!r6rs +(library (srfi private auxiliary-keyword) + (export define-auxiliary-keyword define-auxiliary-keywords) + (import (scheme)) + + (define-syntax define-auxiliary-keyword + (syntax-rules () + [(_ name) + (define-syntax name + (lambda (x) + (syntax-violation 'name "misplaced use of auxiliary keyword" x)))])) + + (define-syntax define-auxiliary-keywords + (syntax-rules () + [(_ name* ...) + (begin (define-auxiliary-keyword name*) ...)]))) + diff --git a/functional-tests/srfi/private/feature-cond.sls b/functional-tests/srfi/private/feature-cond.sls new file mode 100644 index 0000000..fc1dcf3 --- /dev/null +++ b/functional-tests/srfi/private/feature-cond.sls @@ -0,0 +1,53 @@ +#!r6rs +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +(library (srfi private feature-cond) + (export + feature-cond) + (import + (rnrs) + (srfi private registry)) + + (define-syntax feature-cond + (lambda (stx) + (define (identifier?/name=? x n) + (and (identifier? x) + (symbol=? n (syntax->datum x)))) + (define (make-test t) + (define (invalid-test) + (syntax-violation #F "invalid test syntax" stx t)) + (syntax-case t () + ((c x ...) + (identifier?/name=? (syntax c) (quote and)) + (cons (syntax and) (map make-test (syntax (x ...))))) + ((c x ...) + (identifier?/name=? (syntax c) (quote or)) + (cons (syntax or) (map make-test (syntax (x ...))))) + ((c x ...) + (identifier?/name=? (syntax c) (quote not)) + (if (= 1 (length (syntax (x ...)))) + (list (syntax not) (make-test (car (syntax (x ...))))) + (invalid-test))) + (datum + (not (and (identifier? (syntax datum)) + (memq (syntax->datum (syntax datum)) + (quote (and or not else))))) + (syntax (and (member (quote datum) available-features) #T))) + (_ (invalid-test)))) + (syntax-case stx () + ((_ (test . exprs) ... (e . eexprs)) + (identifier?/name=? (syntax e) (quote else)) + (with-syntax (((clause ...) + (map cons (map make-test (syntax (test ...))) + (syntax (exprs ...))))) + (syntax (cond clause ... (else . eexprs))))) + ((kw (test . exprs) ...) + (syntax (kw (test . exprs) ... (else (no-clause-true)))))))) + + (define (no-clause-true) + (assertion-violation (quote feature-cond) "no clause true")) +) diff --git a/functional-tests/srfi/private/include.sls b/functional-tests/srfi/private/include.sls new file mode 100644 index 0000000..563e8c1 --- /dev/null +++ b/functional-tests/srfi/private/include.sls @@ -0,0 +1,51 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi private include) + (export + include/resolve) + (import + (rnrs) + (for (srfi private include compat) expand)) + + (define-syntax include/resolve + (lambda (stx) + (define (include/lexical-context ctxt filename) + (with-exception-handler + (lambda (ex) + (raise + (condition + (make-error) + (make-who-condition 'include/resolve) + (make-message-condition "error while trying to include") + (make-irritants-condition (list filename)) + (if (condition? ex) ex (make-irritants-condition (list ex)))))) + (lambda () + (call-with-input-file filename + (lambda (fip) + (let loop ([a '()]) + (let ([x (read fip)]) + (if (eof-object? x) + (cons #'begin (datum->syntax ctxt (reverse a))) + (loop (cons x a)))))))))) + (syntax-case stx () + [(ctxt (lib-path* ...) file-path) + (for-all (lambda (s) (and (string? s) (positive? (string-length s)))) + (syntax->datum #'(lib-path* ... file-path))) + (let ([p (apply string-append + (map (lambda (ps) (string-append "/" ps)) + (syntax->datum #'(lib-path* ... file-path))))] + [sp (search-paths)]) + (let loop ([search sp]) + (if (null? search) + (error 'include/resolve "cannot find file in search paths" + (substring p 1 (string-length p)) sp) + (let ([full (string-append (car search) p)]) + (if (file-exists? full) + (include/lexical-context #'ctxt full) + (loop (cdr search)))))))]))) +) diff --git a/functional-tests/srfi/private/include/compat.chezscheme.sls b/functional-tests/srfi/private/include/compat.chezscheme.sls new file mode 100644 index 0000000..c639245 --- /dev/null +++ b/functional-tests/srfi/private/include/compat.chezscheme.sls @@ -0,0 +1,11 @@ + +(library (srfi private include compat) + + (export search-paths) + + (import (chezscheme)) + + (define (search-paths) + (map car (library-directories))) + + ) \ No newline at end of file diff --git a/functional-tests/srfi/private/let-opt.sls b/functional-tests/srfi/private/let-opt.sls new file mode 100644 index 0000000..6ccc786 --- /dev/null +++ b/functional-tests/srfi/private/let-opt.sls @@ -0,0 +1,130 @@ +#!r6rs +;;; LET-OPTIONALS macros +;;; Copyright (c) 2001 by Olin Shivers. + +;;; Copyright (c) 1993-2003 Richard Kelsey and Jonathan Rees +;;; Copyright (c) 1994-2003 by Olin Shivers and Brian D. Carlstrom. +;;; Copyright (c) 1999-2003 by Martin Gasbichler. +;;; Copyright (c) 2001-2003 by Michael Sperber. +;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the authors may not be used to endorse or promote products +;;; derived from this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; Made into an R6RS library by Derick Eddington. + +(library (srfi private let-opt) + (export + let-optionals* :optional) + (import + (rnrs)) + +;;; (:optional rest-arg default-exp [test-pred]) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This form is for evaluating optional arguments and their defaults +;;; in simple procedures that take a *single* optional argument. It is +;;; a macro so that the default will not be computed unless it is needed. +;;; +;;; REST-ARG is a rest list from a lambda -- e.g., R in +;;; (lambda (a b . r) ...) +;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that. +;;; - If REST-ARG has 1 element, return that element. +;;; - If REST-ARG has >1 element, error. +;;; +;;; If there is an TEST-PRED form, it is a predicate that is used to test +;;; a non-default value. If the predicate returns false, an error is raised. + +(define-syntax :optional + (syntax-rules () + ([_ rest default-exp] + (let ((maybe-arg rest)) + (if (pair? maybe-arg) + (if (null? (cdr maybe-arg)) (car maybe-arg) + (error ':optional "too many optional arguments" maybe-arg)) + default-exp))) + ([_ rest default-exp arg-test] + (let ((maybe-arg rest)) + (if (pair? maybe-arg) + (if (null? (cdr maybe-arg)) + (let ((val (car maybe-arg))) + (if (arg-test val) val + (error ':optional "optional argument failed test" val))) + (error ':optional "too many optional arguments" maybe-arg)) + default-exp))))) + ; erutcurts-enifed + +;;; Here is a simpler but less-efficient version of LET-OPTIONALS*. +;;; It redundantly performs end-of-list checks for every optional var, +;;; even after the list runs out. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax let-optionals* + (syntax-rules () + ((let-optionals* arg (opt-clause ...) body ...) + (let ((rest arg)) + (%let-optionals* rest (opt-clause ...) + (let () body ...)))))) + +;;; The arg-list expression *must* be a variable. +;;; (Or must be side-effect-free, in any event.) + +(define-syntax %let-optionals* + (syntax-rules () + ((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...) + (call-with-values (lambda () (xparser arg)) + (lambda (rest var ...) + (%let-optionals* rest (opt-clause ...) body ...)))) + + ((%let-optionals* arg ((var default) opt-clause ...) body ...) + (call-with-values (lambda () (if (null? arg) (values default '()) + (values (car arg) (cdr arg)))) + (lambda (var rest) + (%let-optionals* rest (opt-clause ...) body ...)))) + + ((%let-optionals* arg ((var default test) opt-clause ...) body ...) + (call-with-values (lambda () + (if (null? arg) (values default '()) + (let ((var (car arg))) + (if test (values var (cdr arg)) + (error 'let-optionals* "arg failed LET-OPT test" var))))) + (lambda (var rest) + (%let-optionals* rest (opt-clause ...) body ...)))) + + ((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...) + (call-with-values (lambda () + (if (null? arg) (values default #f '()) + (let ((var (car arg))) + (if test (values var #t (cdr arg)) + (error 'let-optionals* "arg failed LET-OPT test" var))))) + (lambda (var supplied? rest) + (%let-optionals* rest (opt-clause ...) body ...)))) + + ((%let-optionals* arg (rest) body ...) + (let ((rest arg)) body ...)) + + ((%let-optionals* arg () body ...) + (if (null? arg) (begin body ...) + (error 'let-optionals* "too many arguments in let-opt" arg))))) +; erutcurts-enifed + +) diff --git a/functional-tests/srfi/private/make-aliased-libraries.sps b/functional-tests/srfi/private/make-aliased-libraries.sps new file mode 100644 index 0000000..33f5f01 --- /dev/null +++ b/functional-tests/srfi/private/make-aliased-libraries.sps @@ -0,0 +1,54 @@ +#!r6rs +(import + (rnrs) + (only (srfi private registry) available-features) + (only (xitomatl lists) map/filter) + (only (xitomatl match) match-lambda) + (only (xitomatl common) format fprintf printf) + (only (xitomatl strings) string-intersperse) + (only (xitomatl predicates) symbolnumber (symbol->string num)) + name)) + (_ #F)) + available-features)) + +(define alias-template +";; Automatically generated by ~a +#!r6rs +(library ~s + (export + ~a) + (import ~s) +) +") + +(define program-name (car (command-line))) + +(for-each + (lambda (x) + (let* ((srfi-num (car x)) + (lib-name (cadr x)) + (exports (list-sort symbolsymbol (format ":~d" srfi-num)))) + (out-file (format "~d.sls" srfi-num))) + (cond + ((file-exists? out-file) + (printf "Skipping ~a because it already exists.\n" out-file)) + (else + (call-with-output-file out-file + (lambda (fop) + (fprintf fop alias-template + program-name + alias-name + (string-intersperse (map symbol->string exports) "\n ") + lib-name))) + (printf "~a\n" out-file))))) + srfi-libraries/mnemonics) diff --git a/functional-tests/srfi/private/platform-features.chezscheme.sls b/functional-tests/srfi/private/platform-features.chezscheme.sls new file mode 100644 index 0000000..d1c2e42 --- /dev/null +++ b/functional-tests/srfi/private/platform-features.chezscheme.sls @@ -0,0 +1,23 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +(library (srfi private platform-features) + (export + OS-features + implementation-features) + (import + (rnrs) + (only (chezscheme) machine-type) + (srfi private OS-id-features)) + + (define (OS-features) + (OS-id-features + (symbol->string (machine-type)) + '(("i3la" linux posix)))) + + (define (implementation-features) + '(chezscheme)) +) diff --git a/functional-tests/srfi/private/registry.sls b/functional-tests/srfi/private/registry.sls new file mode 100644 index 0000000..631370d --- /dev/null +++ b/functional-tests/srfi/private/registry.sls @@ -0,0 +1,103 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi private registry) + (export + available-features) + (import + (rnrs) + (srfi private platform-features)) + + (define available-features + (let-syntax + ((SRFI-features + (lambda (stx) + (define SRFIs + '((0 cond-expand) + (1 lists) + (2 and-let*) + #;(5 let) + (6 basic-string-ports) + (8 receive) + (9 records) + (11 let-values) + (13 strings) + (14 char-sets) + (16 case-lambda) + #;(17 generalized-set!) + #;(18 multithreading) + (19 time) + #;(21 real-time-multithreading) + (23 error) + (25 multi-dimensional-arrays) + (26 cut) + (27 random-bits) + #;(28 basic-format-strings) + #;(29 localization) + (31 rec) + (37 args-fold) + (38 with-shared-structure) + (39 parameters) + (41 streams) + (42 eager-comprehensions) + (43 vectors) + #;(44 collections) + #;(45 lazy) + #;(46 syntax-rules) + #;(47 arrays) + (48 intermediate-format-strings) + #;(51 rest-values) + #;(54 cat) + #;(57 records) + #;(59 vicinities) + #;(60 integer-bits) + (61 cond) + #;(63 arrays) + (64 testing) + #;(66 octet-vectors) + (67 compare-procedures) + (69 basic-hash-tables) + #;(71 let) + #;(74 blobs) + (78 lightweight-testing) + #;(86 mu-and-nu) + #;(87 case) + #;(95 sorting-and-merging) + (98 os-environment-variables) + (99 records))) + (define (make-feature-names x) + (define number car) + (define mnemonic cdr) + (define (make-symbol . args) + (string->symbol (apply string-append + (map (lambda (a) + (if (symbol? a) + (symbol->string a) + a)) + args)))) + (let* ((n-str (number->string (number x))) + (colon-n (make-symbol ":" n-str)) + (srfi-n (make-symbol "srfi-" n-str)) + (srfi-n-m (apply make-symbol srfi-n + (map (lambda (m) (make-symbol "-" m)) + (mnemonic x))))) + ;; The first two are recommended by SRFI-97. + ;; The last two are the two types of SRFI-97 library name. + (list srfi-n + srfi-n-m + `(srfi ,colon-n) + `(srfi ,colon-n . ,(mnemonic x))))) + (syntax-case stx () + ((kw) + #`(quote #,(datum->syntax #'kw + (apply append (map make-feature-names SRFIs))))))))) + `(,@(OS-features) + ,@(implementation-features) + ,@(SRFI-features) + r6rs))) + +) diff --git a/functional-tests/srfi/private/vanish.sls b/functional-tests/srfi/private/vanish.sls new file mode 100644 index 0000000..e897693 --- /dev/null +++ b/functional-tests/srfi/private/vanish.sls @@ -0,0 +1,43 @@ +#!r6rs +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +(library (srfi private vanish) + (export + vanish-define) + (import + (rnrs) + (for (only (rnrs base) begin) (meta -1))) + + #;(define (show stx) + (display (make-string 60 #\-)) (newline) + (write (syntax->datum stx)) (newline)) + + (define-syntax vanish-define + (lambda (stx) + (syntax-case stx () + ((_ def (vanish ...)) + (for-all identifier? #'(vanish ...)) + #'(make-vanish-define (syntax def) (syntax vanish) ...))))) + + (define (make-vanish-define def . to-vanish) + (lambda (stx) + (define (vanish? id) + (memp (lambda (x) (free-identifier=? id x)) + to-vanish)) + #;(show stx) + (syntax-case stx () + ((_ name . _) + (and (identifier? #'name) + (vanish? #'name)) + #'(begin)) + ((_ (name . _) . _) + (and (identifier? #'name) + (vanish? #'name)) + #'(begin)) + ((_ . r) + (cons def #'r))))) +) diff --git a/functional-tests/srfi/s0/cond-expand.sls b/functional-tests/srfi/s0/cond-expand.sls new file mode 100644 index 0000000..ee5f595 --- /dev/null +++ b/functional-tests/srfi/s0/cond-expand.sls @@ -0,0 +1,51 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s0 cond-expand) + (export + cond-expand) + (import + (rnrs) + (for (srfi private registry) expand)) + + (define-syntax cond-expand + (lambda (stx) + (syntax-case stx (and or not else) + [(_) + (syntax-violation #f "Unfulfilled cond-expand" stx)] + [(_ (else body ...)) + #'(begin body ...)] + [(_ ((and) body ...) more-clauses ...) + #'(begin body ...)] + [(_ ((and req1 req2 ...) body ...) more-clauses ...) + #'(cond-expand + (req1 + (cond-expand + ((and req2 ...) body ...) + more-clauses ...)) + more-clauses ...)] + [(_ ((or) body ...) more-clauses ...) + #'(cond-expand more-clauses ...)] + [(_ ((or req1 req2 ...) body ...) more-clauses ...) + #'(cond-expand + (req1 + (begin body ...)) + (else + (cond-expand + ((or req2 ...) body ...) + more-clauses ...)))] + [(_ ((not req) body ...) more-clauses ...) + #'(cond-expand + (req + (cond-expand more-clauses ...)) + (else body ...))] + [(_ (feature-id body ...) more-clauses ...) + (if (member (syntax->datum #'feature-id) available-features) + #'(begin body ...) + #'(cond-expand more-clauses ...))]))) + +) diff --git a/functional-tests/srfi/s1/lists.sls b/functional-tests/srfi/s1/lists.sls new file mode 100644 index 0000000..a3006cb --- /dev/null +++ b/functional-tests/srfi/s1/lists.sls @@ -0,0 +1,1142 @@ +#!r6rs + +;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with +;; this code as long as you do not remove this copyright notice or +;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. +;; -Olin + +;; Ikarus porting begun by Abdulaziz Ghuloum, +;; and continued by Derick Eddington. + +(library (srfi s1 lists) + (export + xcons make-list list-tabulate list-copy + proper-list? circular-list? dotted-list? not-pair? null-list? list= + circular-list length+ + iota + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr + take drop + take-right drop-right + take! drop-right! + split-at split-at! + last last-pair + zip unzip1 unzip2 unzip3 unzip4 unzip5 + count + append! append-reverse append-reverse! concatenate concatenate! + unfold fold pair-fold reduce + unfold-right pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter! partition! remove! + find-tail any every list-index + take-while drop-while take-while! + span break span! break! + delete delete! + alist-cons alist-copy + delete-duplicates delete-duplicates! + alist-delete alist-delete! + reverse! + lset<= lset= lset-adjoin + lset-union lset-intersection lset-difference lset-xor + lset-diff+intersection + lset-union! lset-intersection! lset-difference! lset-xor! + lset-diff+intersection! + ;; re-exported: + append assq assv caaaar caaadr caaar caadar caaddr + caadr caar cadaar cadadr cadar caddar cadddr caddr cadr + car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar + cddadr cddar cdddar cddddr cdddr cddr cdr cons cons* + length list list-ref memq memv null? pair? + reverse set-car! set-cdr! + ;; different than R6RS: + assoc filter find fold-right for-each map member partition remove) + (import + (except (rnrs) + assoc error filter find fold-right + for-each map member partition remove) + (rnrs mutable-pairs)) + + (define-syntax check-arg + (lambda (stx) + (syntax-case stx () + [(_ pred val caller) + (and (identifier? #'val) (identifier? #'caller)) + #'(unless (pred val) + (assertion-violation 'caller "check-arg failed" val))]))) + + (define (error . args) + (if (and (<= 2 (length args)) (symbol? (car args)) (string? (cadr args))) + (apply assertion-violation args) + (apply assertion-violation "(library (srfi s1 lists))" + "misuse of error procedure" args))) + + ;; Constructors + ;; ;;;;;;;;;;;;; + + (define (xcons d a) (cons a d)) + + (define (make-list len . maybe-elt) + (check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list) + (let ((elt (cond ((null? maybe-elt) #f) ; Default value + ((null? (cdr maybe-elt)) (car maybe-elt)) + (else (error 'make-list "Too many arguments" + (cons len maybe-elt)))))) + (do ((i len (- i 1)) + (ans '() (cons elt ans))) + ((<= i 0) ans)))) + + (define (list-tabulate len proc) + (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate) + (check-arg procedure? proc list-tabulate) + (do ((i (- len 1) (- i 1)) + (ans '() (cons (proc i) ans))) + ((< i 0) ans))) + + (define (list-copy lis) + (let recur ((lis lis)) + (if (pair? lis) + (cons (car lis) (recur (cdr lis))) + lis))) + + (define iota + (case-lambda + [(count) (iota count 0 1)] + [(count start) (iota count start 1)] + [(count start step) + (check-arg integer? count iota) + (if (< count 0) (error 'iota "Negative step count" count)) + (check-arg number? start iota) + (check-arg number? step iota) + (let ((last-val (+ start (* (- count 1) step)))) + (do ((count count (- count 1)) + (val last-val (- val step)) + (ans '() (cons val ans))) + ((<= count 0) ans)))])) + + (define (circular-list val1 . vals) + (let ((ans (cons val1 vals))) + (set-cdr! (last-pair ans) ans) + ans)) + + (define (proper-list? x) + (let lp ((x x) (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) (lp x lag))) + (null? x))) + (null? x)))) + + (define (dotted-list? x) + (let lp ((x x) (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) (lp x lag))) + (not (null? x)))) + (not (null? x))))) + + (define (circular-list? x) + (let lp ((x x) (lag x)) + (and (pair? x) + (let ((x (cdr x))) + (and (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (or (eq? x lag) (lp x lag)))))))) + + (define (not-pair? x) (not (pair? x))) ; Inline me. + + (define (null-list? l) + (cond ((pair? l) #f) + ((null? l) #t) + (else (error 'null-list? "argument out of domain" l)))) + + + (define (list= elt= . lists) + (or (null? lists) ; special case + (let lp1 ((list-a (car lists)) (others (cdr lists))) + (or (null? others) + (let ((list-b-orig (car others)) + (others (cdr others))) + (if (eq? list-a list-b-orig) ; EQ? => LIST= + (lp1 list-b-orig others) + (let lp2 ((list-a list-a) (list-b list-b-orig)) + (if (null-list? list-a) + (and (null-list? list-b) + (lp1 list-b-orig others)) + (and (not (null-list? list-b)) + (elt= (car list-a) (car list-b)) + (lp2 (cdr list-a) (cdr list-b))))))))))) + + (define (length+ x) ; Returns #f if X is circular. + (let lp ((x x) (lag x) (len 0)) + (if (pair? x) + (let ((x (cdr x)) + (len (+ len 1))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag)) + (len (+ len 1))) + (and (not (eq? x lag)) (lp x lag len))) + len)) + len))) + + (define (zip list1 . more-lists) (apply map list list1 more-lists)) + + + ;; Selectors + ;; ;;;;;;;;;; + + (define first car) + (define second cadr) + (define third caddr) + (define fourth cadddr) + (define (fifth x) (car (cddddr x))) + (define (sixth x) (cadr (cddddr x))) + (define (seventh x) (caddr (cddddr x))) + (define (eighth x) (cadddr (cddddr x))) + (define (ninth x) (car (cddddr (cddddr x)))) + (define (tenth x) (cadr (cddddr (cddddr x)))) + + (define (car+cdr pair) (values (car pair) (cdr pair))) + + (define (take lis k) + (check-arg integer? k take) + (let recur ((lis lis) (k k)) + (if (zero? k) '() + (cons (car lis) + (recur (cdr lis) (- k 1)))))) + + (define (drop lis k) + (check-arg integer? k drop) + (let iter ((lis lis) (k k)) + (if (zero? k) lis (iter (cdr lis) (- k 1))))) + + (define (take! lis k) + (check-arg integer? k take!) + (if (zero? k) '() + (begin (set-cdr! (drop lis (- k 1)) '()) + lis))) + + (define (take-right lis k) + (check-arg integer? k take-right) + (let lp ((lag lis) (lead (drop lis k))) + (if (pair? lead) + (lp (cdr lag) (cdr lead)) + lag))) + + (define (drop-right lis k) + (check-arg integer? k drop-right) + (let recur ((lag lis) (lead (drop lis k))) + (if (pair? lead) + (cons (car lag) (recur (cdr lag) (cdr lead))) + '()))) + + (define (drop-right! lis k) + (check-arg integer? k drop-right!) + (let ((lead (drop lis k))) + (if (pair? lead) + + (let lp ((lag lis) (lead (cdr lead))) ; Standard case + (if (pair? lead) + (lp (cdr lag) (cdr lead)) + (begin (set-cdr! lag '()) + lis))) + + '()))) ; Special case dropping everything -- no cons to side-effect. + + (define-syntax receive + (syntax-rules () + [(_ (id* ...) expr body body* ...) + (let-values ([(id* ...) expr]) body body* ...)])) + + + (define (split-at x k) + (check-arg integer? k split-at) + (let recur ((lis x) (k k)) + (if (zero? k) (values '() lis) + (receive (prefix suffix) (recur (cdr lis) (- k 1)) + (values (cons (car lis) prefix) suffix))))) + + (define (split-at! x k) + (check-arg integer? k split-at!) + (if (zero? k) (values '() x) + (let* ((prev (drop x (- k 1))) + (suffix (cdr prev))) + (set-cdr! prev '()) + (values x suffix)))) + + + (define (last lis) (car (last-pair lis))) + + (define (last-pair lis) + (check-arg pair? lis last-pair) + (let lp ((lis lis)) + (let ((tail (cdr lis))) + (if (pair? tail) (lp tail) lis)))) + + + ;; Unzippers -- 1 through 5 + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (unzip1 lis) (map car lis)) + + (define (unzip2 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle + (let ((elt (car lis))) ; dotted lists. + (receive (a b) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b))))))) + + (define (unzip3 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis) + (let ((elt (car lis))) + (receive (a b c) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c))))))) + + (define (unzip4 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis lis) + (let ((elt (car lis))) + (receive (a b c d) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c) + (cons (cadddr elt) d))))))) + + (define (unzip5 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis lis lis) + (let ((elt (car lis))) + (receive (a b c d e) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c) + (cons (cadddr elt) d) + (cons (car (cddddr elt)) e))))))) + + + ;; append! append-reverse append-reverse! concatenate concatenate! + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (append! . lists) + ;; First, scan through lists looking for a non-empty one. + (let lp ((lists lists) (prev '())) + (if (not (pair? lists)) prev + (let ((first (car lists)) + (rest (cdr lists))) + (if (not (pair? first)) (lp rest first) + + ;; Now, do the splicing. + (let lp2 ((tail-cons (last-pair first)) + (rest rest)) + (if (pair? rest) + (let ((next (car rest)) + (rest (cdr rest))) + (set-cdr! tail-cons next) + (lp2 (if (pair? next) (last-pair next) tail-cons) + rest)) + first))))))) + + (define (append-reverse rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (lp (cdr rev-head) (cons (car rev-head) tail))))) + + (define (append-reverse! rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (let ((next-rev (cdr rev-head))) + (set-cdr! rev-head tail) + (lp next-rev rev-head))))) + + + (define (concatenate lists) (reduce-right append '() lists)) + (define (concatenate! lists) (reduce-right append! '() lists)) + + ;; Fold/map internal utilities + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (%cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (let ((lis (car lists))) + (if (null-list? lis) (abort '()) + (cons (cdr lis) (recur (cdr lists))))) + '()))))) + + (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) + (let recur ((lists lists)) + (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) + + (define (%cars+cdrs lists) + (let f ([ls lists] [a* '()] [d* '()]) + (cond + [(pair? ls) + (let ([a (car ls)]) + (if (pair? a) + (f (cdr ls) (cons (car a) a*) (cons (cdr a) d*)) + (values '() '())))] + [else (values (reverse a*) (reverse d*))]))) + + (define (%cars+cdrs+ lists cars-final) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs)))))) + (values (list cars-final) '())))))) + + (define (%cars+cdrs/no-test lists) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs))))) + (values '() '())))) + + + ;; count + ;; ;;;;;; + (define (count pred list1 . lists) + (check-arg procedure? pred count) + (if (pair? lists) + + ;; N-ary case + (let lp ((list1 list1) (lists lists) (i 0)) + (if (null-list? list1) i + (receive (as ds) (%cars+cdrs lists) + (if (null? as) i + (lp (cdr list1) ds + (if (apply pred (car list1) as) (+ i 1) i)))))) + + ;; Fast path + (let lp ((lis list1) (i 0)) + (if (null-list? lis) i + (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) + + + ;; fold/unfold + ;; ;;;;;;;;;;;; + + (define unfold-right + (case-lambda + [(p f g seed) + (unfold-right p f g seed '())] + [(p f g seed tail) + (check-arg procedure? p unfold-right) + (check-arg procedure? f unfold-right) + (check-arg procedure? g unfold-right) + (let lp ((seed seed) (ans tail)) + (if (p seed) ans + (lp (g seed) + (cons (f seed) ans))))])) + + + (define (unfold p f g seed . maybe-tail-gen) + (check-arg procedure? p unfold) + (check-arg procedure? f unfold) + (check-arg procedure? g unfold) + (if (pair? maybe-tail-gen) ;;; so much for :optional (aghuloum) + + (let ((tail-gen (car maybe-tail-gen))) + (if (pair? (cdr maybe-tail-gen)) + (apply error 'unfold "Too many arguments" p f g seed maybe-tail-gen) + + (let recur ((seed seed)) + (if (p seed) (tail-gen seed) + (cons (f seed) (recur (g seed))))))) + + (let recur ((seed seed)) + (if (p seed) '() + (cons (f seed) (recur (g seed))))))) + + + (define (fold kons knil lis1 . lists) + (check-arg procedure? kons fold) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case + (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) + (if (null? cars+ans) ans ; Done. + (lp cdrs (apply kons cars+ans))))) + + (let lp ((lis lis1) (ans knil)) ; Fast path + (if (null-list? lis) ans + (lp (cdr lis) (kons (car lis) ans)))))) + + + (define (fold-right kons knil lis1 . lists) + (check-arg procedure? kons fold-right) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) ; N-ary case + (let ((cdrs (%cdrs lists))) + (if (null? cdrs) knil + (apply kons (%cars+ lists (recur cdrs)))))) + + (let recur ((lis lis1)) ; Fast path + (if (null-list? lis) knil + (let ((head (car lis))) + (kons head (recur (cdr lis)))))))) + + + (define (pair-fold-right f zero lis1 . lists) + (check-arg procedure? f pair-fold-right) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) ; N-ary case + (let ((cdrs (%cdrs lists))) + (if (null? cdrs) zero + (apply f (append! lists (list (recur cdrs))))))) + + (let recur ((lis lis1)) ; Fast path + (if (null-list? lis) zero (f lis (recur (cdr lis))))))) + + (define (pair-fold f zero lis1 . lists) + (check-arg procedure? f pair-fold) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case + (let ((tails (%cdrs lists))) + (if (null? tails) ans + (lp tails (apply f (append! lists (list ans))))))) + + (let lp ((lis lis1) (ans zero)) + (if (null-list? lis) ans + (let ((tail (cdr lis))) ; Grab the cdr now, + (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. + + ;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. + ;; These cannot meaningfully be n-ary. + + (define (reduce f ridentity lis) + (check-arg procedure? f reduce) + (if (null-list? lis) ridentity + (fold f (car lis) (cdr lis)))) + + (define (reduce-right f ridentity lis) + (check-arg procedure? f reduce-right) + (if (null-list? lis) ridentity + (let recur ((head (car lis)) (lis (cdr lis))) + (if (pair? lis) + (f head (recur (car lis) (cdr lis))) + head)))) + + ;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (append-map f lis1 . lists) + (check-arg procedure? f append-map) + (really-append-map append f lis1 lists)) + (define (append-map! f lis1 . lists) + (check-arg procedure? f append-map!) + (really-append-map append! f lis1 lists)) + + (define (really-append-map appender f lis1 lists) + (if (pair? lists) + (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) + (if (null? cars) '() + (let recur ((cars cars) (cdrs cdrs)) + (let ((vals (apply f cars))) + (receive (cars2 cdrs2) (%cars+cdrs cdrs) + (if (null? cars2) vals + (appender vals (recur cars2 cdrs2)))))))) + + ;; Fast path + (if (null-list? lis1) '() + (let recur ((elt (car lis1)) (rest (cdr lis1))) + (let ((vals (f elt))) + (if (null-list? rest) vals + (appender vals (recur (car rest) (cdr rest))))))))) + + + (define (pair-for-each proc lis1 . lists) + (check-arg procedure? proc pair-for-each) + (if (pair? lists) + + (let lp ((lists (cons lis1 lists))) + (let ((tails (%cdrs lists))) + (if (pair? tails) + (begin (apply proc lists) + (lp tails))))) + + ;; Fast path. + (let lp ((lis lis1)) + (if (not (null-list? lis)) + (let ((tail (cdr lis))) ; Grab the cdr now, + (proc lis) ; in case PROC SET-CDR!s LIS. + (lp tail)))))) + + ;; We stop when LIS1 runs out, not when any list runs out. + (define (map! f lis1 . lists) + (check-arg procedure? f map!) + (if (pair? lists) + (let lp ((lis1 lis1) (lists lists)) + (if (not (null-list? lis1)) + (receive (heads tails) (%cars+cdrs/no-test lists) + (set-car! lis1 (apply f (car lis1) heads)) + (lp (cdr lis1) tails)))) + + ;; Fast path. + (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) + lis1) + + + ;; Map F across L, and save up all the non-false results. + (define (filter-map f lis1 . lists) + (check-arg procedure? f filter-map) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) + (else (recur cdrs))) ; Tail call in this arm. + '()))) + + ;; Fast path. + (let recur ((lis lis1)) + (if (null-list? lis) lis + (let ((tail (recur (cdr lis)))) + (cond ((f (car lis)) => (lambda (x) (cons x tail))) + (else tail))))))) + + + ;; Map F across lists, guaranteeing to go left-to-right. + ;; NOTE: Some implementations of R5RS MAP are compliant with this spec; + ;; in which case this procedure may simply be defined as a synonym for MAP. + + (define (map-in-order f lis1 . lists) + (check-arg procedure? f map-in-order) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (let ((x (apply f cars))) ; Do head first, + (cons x (recur cdrs))) ; then tail. + '()))) + + ;; Fast path. + (let recur ((lis lis1)) + (if (null-list? lis) lis + (let ((tail (cdr lis)) + (x (f (car lis)))) ; Do head first, + (cons x (recur tail))))))) ; then tail. + + + ;; We extend MAP to handle arguments of unequal length. + (define map map-in-order) + + ;; Contributed by Michael Sperber since it was missing from the + ;; reference implementation. + (define (for-each f lis1 . lists) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (begin + (apply f cars) ; Do head first, + (recur cdrs))))) ; then tail. + + ;; Fast path. + (let recur ((lis lis1)) + (if (not (null-list? lis)) + (begin + (f (car lis)) ; Do head first, + (recur (cdr lis))))))) ; then tail. + + ;; filter, remove, partition + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; FILTER, REMOVE, PARTITION and their destructive counterparts do not + ;; disorder the elements of their argument. + + ;; This FILTER shares the longest tail of L that has no deleted elements. + ;; If Scheme had multi-continuation calls, they could be made more efficient. + + (define (filter pred lis) ; Sleazing with EQ? makes this + (check-arg procedure? pred filter) ; one faster. + (let recur ((lis lis)) + (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. + (let ((head (car lis)) + (tail (cdr lis))) + (if (pred head) + (let ((new-tail (recur tail))) ; Replicate the RECUR call so + (if (eq? tail new-tail) lis + (cons head new-tail))) + (recur tail)))))) ; this one can be a tail call. + + + (define (filter! pred lis) + (check-arg procedure? pred filter!) + (let lp ((ans lis)) + (cond ((null-list? ans) ans) ; Scan looking for + ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. + (else (letrec ((scan-in (lambda (prev lis) + (if (pair? lis) + (if (pred (car lis)) + (scan-in lis (cdr lis)) + (scan-out prev (cdr lis)))))) + (scan-out (lambda (prev lis) + (let lp ((lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (begin (set-cdr! prev lis) + (scan-in lis (cdr lis))) + (lp (cdr lis))) + (set-cdr! prev lis)))))) + (scan-in ans (cdr ans)) + ans))))) + + (define (partition pred lis) + (check-arg procedure? pred partition) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. + (let ((elt (car lis)) + (tail (cdr lis))) + (receive (in out) (recur tail) + (if (pred elt) + (values (if (pair? out) (cons elt in) lis) out) + (values in (if (pair? in) (cons elt out) lis)))))))) + + (define (partition! pred lis) + (check-arg procedure? pred partition!) + (if (null-list? lis) (values lis lis) + (letrec ((scan-in (lambda (in-prev out-prev lis) + (let lp ((in-prev in-prev) (lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (lp lis (cdr lis)) + (begin (set-cdr! out-prev lis) + (scan-out in-prev lis (cdr lis)))) + (set-cdr! out-prev lis))))) ; Done. + + (scan-out (lambda (in-prev out-prev lis) + (let lp ((out-prev out-prev) (lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (begin (set-cdr! in-prev lis) + (scan-in lis out-prev (cdr lis))) + (lp lis (cdr lis))) + (set-cdr! in-prev lis)))))) ; Done. + + ;; Crank up the scan&splice loops. + (if (pred (car lis)) + ;; LIS begins in-list. Search for out-list's first pair. + (let lp ((prev-l lis) (l (cdr lis))) + (cond ((not (pair? l)) (values lis l)) + ((pred (car l)) (lp l (cdr l))) + (else (scan-out prev-l l (cdr l)) + (values lis l)))) ; Done. + + ;; LIS begins out-list. Search for in-list's first pair. + (let lp ((prev-l lis) (l (cdr lis))) + (cond ((not (pair? l)) (values l lis)) + ((pred (car l)) + (scan-in l prev-l (cdr l)) + (values l lis)) ; Done. + (else (lp l (cdr l))))))))) + + + ;; Inline us, please. + (define (remove pred l) (filter (lambda (x) (not (pred x))) l)) + (define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) + + (define delete + (case-lambda + [(x lis) + (delete x lis equal?)] + [(x lis =) + (filter (lambda (y) (not (= x y))) lis)])) + + (define delete! + (case-lambda + [(x lis) + (delete! x lis equal?)] + [(x lis =) + (filter! (lambda (y) (not (= x y))) lis)])) + + ;; Extended from R4RS to take an optional comparison argument. + (define member + (case-lambda + [(x lis) + (member x lis equal?)] + [(x lis =) + (find-tail (lambda (y) (= x y)) lis)])) + + (define delete-duplicates + (case-lambda + [(lis) + (delete-duplicates lis equal?)] + [(lis elt=) + (check-arg procedure? elt= delete-duplicates) + (let recur ((lis lis)) + (if (null-list? lis) lis + (let* ((x (car lis)) + (tail (cdr lis)) + (new-tail (recur (delete x tail elt=)))) + (if (eq? tail new-tail) lis (cons x new-tail)))))])) + + (define delete-duplicates! + (case-lambda + [(lis) + (delete-duplicates! lis equal?)] + [(lis elt=) + (check-arg procedure? elt= delete-duplicates!) + (let recur ((lis lis)) + (if (null-list? lis) lis + (let* ((x (car lis)) + (tail (cdr lis)) + (new-tail (recur (delete! x tail elt=)))) + (when (not (eq? tail new-tail)) + (set-cdr! lis new-tail)) + lis)))])) + + + ;; alist stuff + ;; ;;;;;;;;;;;; + + (define assoc + (case-lambda + [(x lis) + (assoc x lis equal?)] + [(x lis =) + (find (lambda (entry) (= x (car entry))) lis)])) + + (define (alist-cons key datum alist) (cons (cons key datum) alist)) + + (define (alist-copy alist) + (map (lambda (elt) (cons (car elt) (cdr elt))) + alist)) + + (define alist-delete + (case-lambda + [(key alist) + (alist-delete key alist equal?)] + [(key alist =) + (filter (lambda (elt) (not (= key (car elt)))) alist)])) + + (define alist-delete! + (case-lambda + [(key alist) + (alist-delete! key alist equal?)] + [(key alist =) + (filter! (lambda (elt) (not (= key (car elt)))) alist)])) + + + ;; find find-tail take-while drop-while span break any every list-index + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (find pred list) + (cond ((find-tail pred list) => car) + (else #f))) + + (define (find-tail pred list) + (check-arg procedure? pred find-tail) + (let lp ((list list)) + (and (not (null-list? list)) + (if (pred (car list)) list + (lp (cdr list)))))) + + (define (take-while pred lis) + (check-arg procedure? pred take-while) + (let recur ((lis lis)) + (if (null-list? lis) '() + (let ((x (car lis))) + (if (pred x) + (cons x (recur (cdr lis))) + '()))))) + + (define (drop-while pred lis) + (check-arg procedure? pred drop-while) + (let lp ((lis lis)) + (if (null-list? lis) '() + (if (pred (car lis)) + (lp (cdr lis)) + lis)))) + + (define (take-while! pred lis) + (check-arg procedure? pred take-while!) + (if (or (null-list? lis) (not (pred (car lis)))) '() + (begin (let lp ((prev lis) (rest (cdr lis))) + (if (pair? rest) + (let ((x (car rest))) + (if (pred x) (lp rest (cdr rest)) + (set-cdr! prev '()))))) + lis))) + + (define (span pred lis) + (check-arg procedure? pred span) + (let recur ((lis lis)) + (if (null-list? lis) (values '() '()) + (let ((x (car lis))) + (if (pred x) + (receive (prefix suffix) (recur (cdr lis)) + (values (cons x prefix) suffix)) + (values '() lis)))))) + + (define (span! pred lis) + (check-arg procedure? pred span!) + (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) + (let ((suffix (let lp ((prev lis) (rest (cdr lis))) + (if (null-list? rest) rest + (let ((x (car rest))) + (if (pred x) (lp rest (cdr rest)) + (begin (set-cdr! prev '()) + rest))))))) + (values lis suffix)))) + + + (define (break pred lis) (span (lambda (x) (not (pred x))) lis)) + (define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) + + (define (any pred lis1 . lists) + (check-arg procedure? pred any) + (if (pair? lists) + + ;; N-ary case + (receive (heads tails) (%cars+cdrs (cons lis1 lists)) + (and (pair? heads) + (let lp ((heads heads) (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (or (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))) ; Last PRED app is tail call. + + ;; Fast path + (and (not (null-list? lis1)) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null-list? tail) + (pred head) ; Last PRED app is tail call. + (or (pred head) (lp (car tail) (cdr tail)))))))) + + (define every + (case-lambda + [(p ls) + (or (null-list? ls) + (let f ([p p] [a (car ls)] [d (cdr ls)]) + (cond + [(pair? d) + (and (p a) (f p (car d) (cdr d)))] + [else (p a)])))] + [(p ls1 ls2) + (cond + [(and (pair? ls1) (pair? ls2)) + (let f ([p p] [a1 (car ls1)] [d1 (cdr ls1)] [a2 (car ls2)] [d2 (cdr ls2)]) + (cond + [(and (pair? d1) (pair? d2)) + (and (p a1 a2) (f p (car d1) (cdr d1) (car d2) (cdr d2)))] + [else (p a1 a2)]))] + [else #t])] + [(pred lis1 . lists) + (receive (heads tails) (%cars+cdrs (cons lis1 lists)) + (or (not (pair? heads)) + (let lp ((heads heads) (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (and (apply pred heads) (lp next-heads next-tails)) + (apply pred heads))))))])) + + (define (list-index pred lis1 . lists) + (check-arg procedure? pred list-index) + (if (pair? lists) + + ;; N-ary case + (let lp ((lists (cons lis1 lists)) (n 0)) + (receive (heads tails) (%cars+cdrs lists) + (and (pair? heads) + (if (apply pred heads) n + (lp tails (+ n 1)))))) + + ;; Fast path + (let lp ((lis lis1) (n 0)) + (and (not (null-list? lis)) + (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) + + ;; Reverse + ;; ;;;;;;;; + + (define (reverse! lis) + (let lp ((lis lis) (ans '())) + (if (null-list? lis) ans + (let ((tail (cdr lis))) + (set-cdr! lis ans) + (lp tail lis))))) + + ;; Lists-as-sets + ;; ;;;;;;;;;;;;;; + + (define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1)) + + (define (lset<= = . lists) + (check-arg procedure? = lset<=) + (or (not (pair? lists)) ; 0-ary case + (let lp ((s1 (car lists)) (rest (cdr lists))) + (or (not (pair? rest)) + (let ((s2 (car rest)) (rest (cdr rest))) + (and (or (eq? s2 s1) ; Fast path + (%lset2<= = s1 s2)) ; Real test + (lp s2 rest))))))) + + (define (lset= = . lists) + (check-arg procedure? = lset=) + (or (not (pair? lists)) ; 0-ary case + (let lp ((s1 (car lists)) (rest (cdr lists))) + (or (not (pair? rest)) + (let ((s2 (car rest)) + (rest (cdr rest))) + (and (or (eq? s1 s2) ; Fast path + (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test + (lp s2 rest))))))) + + + (define (lset-adjoin = lis . elts) + (check-arg procedure? = lset-adjoin) + (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) + lis elts)) + + + (define (lset-union = . lists) + (check-arg procedure? = lset-union) + (reduce (lambda (lis ans) ; Compute ANS + LIS. + (cond ((null? lis) ans) ; Don't copy any lists + ((null? ans) lis) ; if we don't have to. + ((eq? lis ans) ans) + (else + (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) + ans + (cons elt ans))) + ans lis)))) + '() lists)) + + (define (lset-union! = . lists) + (check-arg procedure? = lset-union!) + (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. + (cond ((null? lis) ans) ; Don't copy any lists + ((null? ans) lis) ; if we don't have to. + ((eq? lis ans) ans) + (else + (pair-fold (lambda (pair ans) + (let ((elt (car pair))) + (if (any (lambda (x) (= x elt)) ans) + ans + (begin (set-cdr! pair ans) pair)))) + ans lis)))) + '() lists)) + + + (define (lset-intersection = lis1 . lists) + (check-arg procedure? = lset-intersection) + (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. + (cond ((any null-list? lists) '()) ; Short cut + ((null? lists) lis1) ; Short cut + (else (filter (lambda (x) + (every (lambda (lis) (member x lis =)) lists)) + lis1))))) + + (define (lset-intersection! = lis1 . lists) + (check-arg procedure? = lset-intersection!) + (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. + (cond ((any null-list? lists) '()) ; Short cut + ((null? lists) lis1) ; Short cut + (else (filter! (lambda (x) + (every (lambda (lis) (member x lis =)) lists)) + lis1))))) + + + (define (lset-difference = lis1 . lists) + (check-arg procedure? = lset-difference) + (let ((lists (filter pair? lists))) ; Throw out empty lists. + (cond ((null? lists) lis1) ; Short cut + ((memq lis1 lists) '()) ; Short cut + (else (filter (lambda (x) + (every (lambda (lis) (not (member x lis =))) + lists)) + lis1))))) + + (define (lset-difference! = lis1 . lists) + (check-arg procedure? = lset-difference!) + (let ((lists (filter pair? lists))) ; Throw out empty lists. + (cond ((null? lists) lis1) ; Short cut + ((memq lis1 lists) '()) ; Short cut + (else (filter! (lambda (x) + (every (lambda (lis) (not (member x lis =))) + lists)) + lis1))))) + + + (define (lset-xor = . lists) + (check-arg procedure? = lset-xor) + (reduce (lambda (b a) ; Compute A xor B: + ;; Note that this code relies on the constant-time + ;; short-cuts provided by LSET-DIFF+INTERSECTION, + ;; LSET-DIFFERENCE & APPEND to provide constant-time short + ;; cuts for the cases A = (), B = (), and A eq? B. It takes + ;; a careful case analysis to see it, but it's carefully + ;; built in. + + ;; Compute a-b and a^b, then compute b-(a^b) and + ;; cons it onto the front of a-b. + (receive (a-b a-int-b) (lset-diff+intersection = a b) + (cond ((null? a-b) (lset-difference = b a)) + ((null? a-int-b) (append b a)) + (else (fold (lambda (xb ans) + (if (member xb a-int-b =) ans (cons xb ans))) + a-b + b))))) + '() lists)) + + + (define (lset-xor! = . lists) + (check-arg procedure? = lset-xor!) + (reduce (lambda (b a) ; Compute A xor B: + ;; Note that this code relies on the constant-time + ;; short-cuts provided by LSET-DIFF+INTERSECTION, + ;; LSET-DIFFERENCE & APPEND to provide constant-time short + ;; cuts for the cases A = (), B = (), and A eq? B. It takes + ;; a careful case analysis to see it, but it's carefully + ;; built in. + + ;; Compute a-b and a^b, then compute b-(a^b) and + ;; cons it onto the front of a-b. + (receive (a-b a-int-b) (lset-diff+intersection! = a b) + (cond ((null? a-b) (lset-difference! = b a)) + ((null? a-int-b) (append! b a)) + (else (pair-fold (lambda (b-pair ans) + (if (member (car b-pair) a-int-b =) ans + (begin (set-cdr! b-pair ans) b-pair))) + a-b + b))))) + '() lists)) + + + (define (lset-diff+intersection = lis1 . lists) + (check-arg procedure? = lset-diff+intersection) + (cond ((every null-list? lists) (values lis1 '())) ; Short cut + ((memq lis1 lists) (values '() lis1)) ; Short cut + (else (partition (lambda (elt) + (not (any (lambda (lis) (member elt lis =)) + lists))) + lis1)))) + + (define (lset-diff+intersection! = lis1 . lists) + (check-arg procedure? = lset-diff+intersection!) + (cond ((every null-list? lists) (values lis1 '())) ; Short cut + ((memq lis1 lists) (values '() lis1)) ; Short cut + (else (partition! (lambda (elt) + (not (any (lambda (lis) (member elt lis =)) + lists))) + lis1)))) + ;; end of library + ) diff --git a/functional-tests/srfi/s13/srfi-13.scm b/functional-tests/srfi/s13/srfi-13.scm new file mode 100644 index 0000000..3015777 --- /dev/null +++ b/functional-tests/srfi/s13/srfi-13.scm @@ -0,0 +1,2019 @@ +;;; SRFI 13 string library reference implementation -*- Scheme -*- +;;; Olin Shivers 7/2000 +;;; +;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology. +;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved. +;;; The details of the copyrights appear at the end of the file. Short +;;; summary: BSD-style open source. + +;;; Exports: +;;; string-map string-map! +;;; string-fold string-unfold +;;; string-fold-right string-unfold-right +;;; string-tabulate string-for-each string-for-each-index +;;; string-every string-any +;;; string-hash string-hash-ci +;;; string-compare string-compare-ci +;;; string= string< string> string<= string>= string<> +;;; string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<> +;;; string-downcase string-upcase string-titlecase +;;; string-downcase! string-upcase! string-titlecase! +;;; string-take string-take-right +;;; string-drop string-drop-right +;;; string-pad string-pad-right +;;; string-trim string-trim-right string-trim-both +;;; string-filter string-delete +;;; string-index string-index-right +;;; string-skip string-skip-right +;;; string-count +;;; string-prefix-length string-prefix-length-ci +;;; string-suffix-length string-suffix-length-ci +;;; string-prefix? string-prefix-ci? +;;; string-suffix? string-suffix-ci? +;;; string-contains string-contains-ci +;;; string-copy! substring/shared +;;; string-reverse string-reverse! reverse-list->string +;;; string-concatenate string-concatenate/shared string-concatenate-reverse +;;; string-append/shared +;;; xsubstring string-xcopy! +;;; string-null? +;;; string-join +;;; string-tokenize +;;; string-replace +;;; +;;; R5RS extended: +;;; string->list string-copy string-fill! +;;; +;;; R5RS re-exports: +;;; string? make-string string-length string-ref string-set! +;;; +;;; R5RS re-exports (also defined here but commented-out): +;;; string string-append list->string +;;; +;;; Low-level routines: +;;; make-kmp-restart-vector string-kmp-partial-search kmp-step +;;; string-parse-start+end +;;; string-parse-final-start+end +;;; let-string-start+end +;;; check-substring-spec +;;; substring-spec-ok? + +;;; Imports +;;; This is a fairly large library. While it was written for portability, you +;;; must be aware of its dependencies in order to run it in a given scheme +;;; implementation. Here is a complete list of the dependencies it has and the +;;; assumptions it makes beyond stock R5RS Scheme: +;;; +;;; This code has the following non-R5RS dependencies: +;;; - (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro; +;;; +;;; - Various imports from the char-set library for the routines that can +;;; take char-set arguments; +;;; +;;; - An n-ary ERROR procedure; +;;; +;;; - BITWISE-AND for the hash functions; +;;; +;;; - A simple CHECK-ARG procedure for checking parameter values; it is +;;; (lambda (pred val proc) +;;; (if (pred val) val (error "Bad arg" val pred proc))) +;;; +;;; - :OPTIONAL and LET-OPTIONALS* macros for parsing, defaulting & +;;; type-checking optional parameters from a rest argument; +;;; +;;; - CHAR-CASED? and CHAR-TITLECASE for the STRING-TITLECASE & +;;; STRING-TITLECASE! procedures. The former returns true iff a character is +;;; one that has case distinctions; in ASCII it returns true on a-z and A-Z. +;;; CHAR-TITLECASE is analagous to CHAR-UPCASE and CHAR-DOWNCASE. In ASCII & +;;; Latin-1, it is the same as CHAR-UPCASE. +;;; +;;; The code depends upon a small set of core string primitives from R5RS: +;;; MAKE-STRING STRING-REF STRING-SET! STRING? STRING-LENGTH SUBSTRING +;;; (Actually, SUBSTRING is not a primitive, but we assume that an +;;; implementation's native version is probably faster than one we could +;;; define, so we import it from R5RS.) +;;; +;;; The code depends upon a small set of R5RS character primitives: +;;; char? char=? char-ci=? charinteger (for the hash functions) +;;; +;;; We assume the following: +;;; - CHAR-DOWNCASE o CHAR-UPCASE = CHAR-DOWNCASE +;;; - CHAR-CI=? is equivalent to +;;; (lambda (c1 c2) (char=? (char-downcase (char-upcase c1)) +;;; (char-downcase (char-upcase c2)))) +;;; - CHAR-UPCASE, CHAR-DOWNCASE and CHAR-TITLECASE are locale-insensitive +;;; and consistent with Unicode's 1-1 char-mapping spec. +;;; These things are typically true, but if not, you would need to modify +;;; the case-mapping and case-insensitive routines. + +;;; Enough introductory blather. On to the source code. (But see the end of +;;; the file for further notes on porting & performance tuning.) + + +;;; Support for START/END substring specs +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This macro parses optional start/end arguments from arg lists, defaulting +;;; them to 0/(string-length s), and checks them for correctness. + +(define-syntax let-string-start+end + (syntax-rules () + ((let-string-start+end (start end) proc s-exp args-exp body ...) + (receive (start end) (string-parse-final-start+end proc s-exp args-exp) + body ...)) + ((let-string-start+end (start end rest) proc s-exp args-exp body ...) + (receive (rest start end) (string-parse-start+end proc s-exp args-exp) + body ...)))) + +;;; This one parses out a *pair* of final start/end indices. +;;; Not exported; for internal use. +(define-syntax let-string-start+end2 + (syntax-rules () + ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...) + (let ((procv proc)) ; Make sure PROC is only evaluated once. + (let-string-start+end (start1 end1 rest) procv s1 args + (let-string-start+end (start2 end2) procv s2 rest + body ...)))))) + + +;;; Returns three values: rest start end + +(define (string-parse-start+end proc s args) + (if (not (string? s)) (error "Non-string value" proc s)) + (let ((slen (string-length s))) + (if (pair? args) + + (let ((start (car args)) + (args (cdr args))) + (if (and (integer? start) (exact? start) (>= start 0)) + (receive (end args) + (if (pair? args) + (let ((end (car args)) + (args (cdr args))) + (if (and (integer? end) (exact? end) (<= end slen)) + (values end args) + (error "Illegal substring END spec" proc end s))) + (values slen args)) + (if (<= start end) (values args start end) + (error "Illegal substring START/END spec" + proc start end s))) + (error "Illegal substring START spec" proc start s))) + + (values '() 0 slen)))) + +(define (string-parse-final-start+end proc s args) + (receive (rest start end) (string-parse-start+end proc s args) + (if (pair? rest) (error "Extra arguments to procedure" proc rest) + (values start end)))) + +(define (substring-spec-ok? s start end) + (and (string? s) + (integer? start) + (exact? start) + (integer? end) + (exact? end) + (<= 0 start) + (<= start end) + (<= end (string-length s)))) + +(define (check-substring-spec proc s start end) + (if (not (substring-spec-ok? s start end)) + (error "Illegal substring spec." proc s start end))) + + +;;; Defined by R5RS, so commented out here. +;(define (string . chars) +; (let* ((len (length chars)) +; (ans (make-string len))) +; (do ((i 0 (+ i 1)) +; (chars chars (cdr chars))) +; ((>= i len)) +; (string-set! ans i (car chars))) +; ans)) +; +;(define (string . chars) (string-unfold null? car cdr chars)) + + + +;;; substring/shared S START [END] +;;; string-copy S [START END] +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; All this goop is just arg parsing & checking surrounding a call to the +;;; actual primitive, %SUBSTRING/SHARED. + +(define (substring/shared s start . maybe-end) + (check-arg string? s substring/shared) + (let ((slen (string-length s))) + (check-arg (lambda (start) (and (integer? start) (exact? start) (<= 0 start))) + start substring/shared) + (%substring/shared s start + (:optional maybe-end slen + (lambda (end) (and (integer? end) + (exact? end) + (<= start end) + (<= end slen))))))) + +;;; Split out so that other routines in this library can avoid arg-parsing +;;; overhead for END parameter. +(define (%substring/shared s start end) + (if (and (zero? start) (= end (string-length s))) s + (substring s start end))) + +(define (string-copy s . maybe-start+end) + (let-string-start+end (start end) string-copy s maybe-start+end + (substring s start end))) + +;This library uses the R5RS SUBSTRING, but doesn't export it. +;Here is a definition, just for completeness. +;(define (substring s start end) +; (check-substring-spec substring s start end) +; (let* ((slen (- end start)) +; (ans (make-string slen))) +; (do ((i 0 (+ i 1)) +; (j start (+ j 1))) +; ((>= i slen) ans) +; (string-set! ans i (string-ref s j))))) + +;;; Basic iterators and other higher-order abstractions +;;; (string-map proc s [start end]) +;;; (string-map! proc s [start end]) +;;; (string-fold kons knil s [start end]) +;;; (string-fold-right kons knil s [start end]) +;;; (string-unfold p f g seed [base make-final]) +;;; (string-unfold-right p f g seed [base make-final]) +;;; (string-for-each proc s [start end]) +;;; (string-for-each-index proc s [start end]) +;;; (string-every char-set/char/pred s [start end]) +;;; (string-any char-set/char/pred s [start end]) +;;; (string-tabulate proc len) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; You want compiler support for high-level transforms on fold and unfold ops. +;;; You'd at least like a lot of inlining for clients of these procedures. +;;; Don't hold your breath. + +(define (string-map proc s . maybe-start+end) + (check-arg procedure? proc string-map) + (let-string-start+end (start end) string-map s maybe-start+end + (%string-map proc s start end))) + +(define (%string-map proc s start end) ; Internal utility + (let* ((len (- end start)) + (ans (make-string len))) + (do ((i (- end 1) (- i 1)) + (j (- len 1) (- j 1))) + ((< j 0)) + (string-set! ans j (proc (string-ref s i)))) + ans)) + +(define (string-map! proc s . maybe-start+end) + (check-arg procedure? proc string-map!) + (let-string-start+end (start end) string-map! s maybe-start+end + (%string-map! proc s start end))) + +(define (%string-map! proc s start end) + (do ((i (- end 1) (- i 1))) + ((< i start)) + (string-set! s i (proc (string-ref s i))))) + +(define (string-fold kons knil s . maybe-start+end) + (check-arg procedure? kons string-fold) + (let-string-start+end (start end) string-fold s maybe-start+end + (let lp ((v knil) (i start)) + (if (< i end) (lp (kons (string-ref s i) v) (+ i 1)) + v)))) + +(define (string-fold-right kons knil s . maybe-start+end) + (check-arg procedure? kons string-fold-right) + (let-string-start+end (start end) string-fold-right s maybe-start+end + (let lp ((v knil) (i (- end 1))) + (if (>= i start) (lp (kons (string-ref s i) v) (- i 1)) + v)))) + +;;; (string-unfold p f g seed [base make-final]) +;;; This is the fundamental constructor for strings. +;;; - G is used to generate a series of "seed" values from the initial seed: +;;; SEED, (G SEED), (G^2 SEED), (G^3 SEED), ... +;;; - P tells us when to stop -- when it returns true when applied to one +;;; of these seed values. +;;; - F maps each seed value to the corresponding character +;;; in the result string. These chars are assembled into the +;;; string in a left-to-right order. +;;; - BASE is the optional initial/leftmost portion of the constructed string; +;;; it defaults to the empty string "". +;;; - MAKE-FINAL is applied to the terminal seed value (on which P returns +;;; true) to produce the final/rightmost portion of the constructed string. +;;; It defaults to (LAMBDA (X) ""). +;;; +;;; In other words, the following (simple, inefficient) definition holds: +;;; (define (string-unfold p f g seed base make-final) +;;; (string-append base +;;; (let recur ((seed seed)) +;;; (if (p seed) (make-final seed) +;;; (string-append (string (f seed)) +;;; (recur (g seed))))))) +;;; +;;; STRING-UNFOLD is a fairly powerful constructor -- you can use it to +;;; reverse a string, copy a string, convert a list to a string, read +;;; a port into a string, and so forth. Examples: +;;; (port->string port) = +;;; (string-unfold (compose eof-object? peek-char) +;;; read-char values port) +;;; +;;; (list->string lis) = (string-unfold null? car cdr lis) +;;; +;;; (tabulate-string f size) = (string-unfold (lambda (i) (= i size)) f add1 0) + +;;; A problem with the following simple formulation is that it pushes one +;;; stack frame for every char in the result string -- an issue if you are +;;; using it to read a 100kchar string. So we don't use it -- but I include +;;; it to give a clear, straightforward description of what the function +;;; does. + +;(define (string-unfold p f g seed base make-final) +; (let ((ans (let recur ((seed seed) (i (string-length base))) +; (if (p seed) +; (let* ((final (make-final seed)) +; (ans (make-string (+ i (string-length final))))) +; (string-copy! ans i final) +; ans) +; +; (let* ((c (f seed)) +; (s (recur (g seed) (+ i 1)))) +; (string-set! s i c) +; s))))) +; (string-copy! ans 0 base) +; ans)) + +;;; The strategy is to allocate a series of chunks into which we stash the +;;; chars as we generate them. Chunk size goes up in powers of two starting +;;; with 40 and levelling out at 4k, i.e. +;;; 40 40 80 160 320 640 1280 2560 4096 4096 4096 4096 4096... +;;; This should work pretty well for short strings, 1-line (80 char) strings, +;;; and longer ones. When done, we allocate an answer string and copy the +;;; chars over from the chunk buffers. + +(define (string-unfold p f g seed . base+make-final) + (check-arg procedure? p string-unfold) + (check-arg procedure? f string-unfold) + (check-arg procedure? g string-unfold) + (let-optionals* base+make-final + ((base "" (string? base)) + (make-final (lambda (x) "") (procedure? make-final))) + (let lp ((chunks '()) ; Previously filled chunks + (nchars 0) ; Number of chars in CHUNKS + (chunk (make-string 40)) ; Current chunk into which we write + (chunk-len 40) + (i 0) ; Number of chars written into CHUNK + (seed seed)) + (let lp2 ((i i) (seed seed)) + (if (not (p seed)) + (let ((c (f seed)) + (seed (g seed))) + (if (< i chunk-len) + (begin (string-set! chunk i c) + (lp2 (+ i 1) seed)) + + (let* ((nchars2 (+ chunk-len nchars)) + (chunk-len2 (min 4096 nchars2)) + (new-chunk (make-string chunk-len2))) + (string-set! new-chunk 0 c) + (lp (cons chunk chunks) (+ nchars chunk-len) + new-chunk chunk-len2 1 seed)))) + + ;; We're done. Make the answer string & install the bits. + (let* ((final (make-final seed)) + (flen (string-length final)) + (base-len (string-length base)) + (j (+ base-len nchars i)) + (ans (make-string (+ j flen)))) + (%string-copy! ans j final 0 flen) ; Install FINAL. + (let ((j (- j i))) + (%string-copy! ans j chunk 0 i) ; Install CHUNK[0,I). + (let lp ((j j) (chunks chunks)) ; Install CHUNKS. + (if (pair? chunks) + (let* ((chunk (car chunks)) + (chunks (cdr chunks)) + (chunk-len (string-length chunk)) + (j (- j chunk-len))) + (%string-copy! ans j chunk 0 chunk-len) + (lp j chunks))))) + (%string-copy! ans 0 base 0 base-len) ; Install BASE. + ans)))))) + +(define (string-unfold-right p f g seed . base+make-final) + (let-optionals* base+make-final + ((base "" (string? base)) + (make-final (lambda (x) "") (procedure? make-final))) + (let lp ((chunks '()) ; Previously filled chunks + (nchars 0) ; Number of chars in CHUNKS + (chunk (make-string 40)) ; Current chunk into which we write + (chunk-len 40) + (i 40) ; Number of chars available in CHUNK + (seed seed)) + (let lp2 ((i i) (seed seed)) ; Fill up CHUNK from right + (if (not (p seed)) ; to left. + (let ((c (f seed)) + (seed (g seed))) + (if (> i 0) + (let ((i (- i 1))) + (string-set! chunk i c) + (lp2 i seed)) + + (let* ((nchars2 (+ chunk-len nchars)) + (chunk-len2 (min 4096 nchars2)) + (new-chunk (make-string chunk-len2)) + (i (- chunk-len2 1))) + (string-set! new-chunk i c) + (lp (cons chunk chunks) (+ nchars chunk-len) + new-chunk chunk-len2 i seed)))) + + ;; We're done. Make the answer string & install the bits. + (let* ((final (make-final seed)) + (flen (string-length final)) + (base-len (string-length base)) + (chunk-used (- chunk-len i)) + (j (+ base-len nchars chunk-used)) + (ans (make-string (+ j flen)))) + (%string-copy! ans 0 final 0 flen) ; Install FINAL. + (%string-copy! ans flen chunk i chunk-len); Install CHUNK[I,). + (let lp ((j (+ flen chunk-used)) ; Install CHUNKS. + (chunks chunks)) + (if (pair? chunks) + (let* ((chunk (car chunks)) + (chunks (cdr chunks)) + (chunk-len (string-length chunk))) + (%string-copy! ans j chunk 0 chunk-len) + (lp (+ j chunk-len) chunks)) + (%string-copy! ans j base 0 base-len))); Install BASE. + ans)))))) + + +(define (string-for-each proc s . maybe-start+end) + (check-arg procedure? proc string-for-each) + (let-string-start+end (start end) string-for-each s maybe-start+end + (let lp ((i start)) + (if (< i end) + (begin (proc (string-ref s i)) + (lp (+ i 1))))))) + +(define (string-for-each-index proc s . maybe-start+end) + (check-arg procedure? proc string-for-each-index) + (let-string-start+end (start end) string-for-each-index s maybe-start+end + (let lp ((i start)) + (if (< i end) (begin (proc i) (lp (+ i 1))))))) + +(define (string-every criterion s . maybe-start+end) + (let-string-start+end (start end) string-every s maybe-start+end + (cond ((char? criterion) + (let lp ((i start)) + (or (>= i end) + (and (char=? criterion (string-ref s i)) + (lp (+ i 1)))))) + + ((char-set? criterion) + (let lp ((i start)) + (or (>= i end) + (and (char-set-contains? criterion (string-ref s i)) + (lp (+ i 1)))))) + + ((procedure? criterion) ; Slightly funky loop so that + (or (= start end) ; final (PRED S[END-1]) call + (let lp ((i start)) ; is a tail call. + (let ((c (string-ref s i)) + (i1 (+ i 1))) + (if (= i1 end) (criterion c) ; Tail call. + (and (criterion c) (lp i1))))))) + + (else (error "Second param is neither char-set, char, or predicate procedure." + string-every criterion))))) + + +(define (string-any criterion s . maybe-start+end) + (let-string-start+end (start end) string-any s maybe-start+end + (cond ((char? criterion) + (let lp ((i start)) + (and (< i end) + (or (char=? criterion (string-ref s i)) + (lp (+ i 1)))))) + + ((char-set? criterion) + (let lp ((i start)) + (and (< i end) + (or (char-set-contains? criterion (string-ref s i)) + (lp (+ i 1)))))) + + ((procedure? criterion) ; Slightly funky loop so that + (and (< start end) ; final (PRED S[END-1]) call + (let lp ((i start)) ; is a tail call. + (let ((c (string-ref s i)) + (i1 (+ i 1))) + (if (= i1 end) (criterion c) ; Tail call + (or (criterion c) (lp i1))))))) + + (else (error "Second param is neither char-set, char, or predicate procedure." + string-any criterion))))) + + +(define (string-tabulate proc len) + (check-arg procedure? proc string-tabulate) + (check-arg (lambda (val) (and (integer? val) (exact? val) (<= 0 val))) + len string-tabulate) + (let ((s (make-string len))) + (do ((i (- len 1) (- i 1))) + ((< i 0)) + (string-set! s i (proc i))) + s)) + + + +;;; string-prefix-length[-ci] s1 s2 [start1 end1 start2 end2] +;;; string-suffix-length[-ci] s1 s2 [start1 end1 start2 end2] +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Find the length of the common prefix/suffix. +;;; It is not required that the two substrings passed be of equal length. +;;; This was microcode in MIT Scheme -- a very tightly bummed primitive. +;;; %STRING-PREFIX-LENGTH is the core routine of all string-comparisons, +;;; so should be as tense as possible. + +(define (%string-prefix-length s1 start1 end1 s2 start2 end2) + (let* ((delta (min (- end1 start1) (- end2 start2))) + (end1 (+ start1 delta))) + + (if (and (eq? s1 s2) (= start1 start2)) ; EQ fast path + delta + + (let lp ((i start1) (j start2)) ; Regular path + (if (or (>= i end1) + (not (char=? (string-ref s1 i) + (string-ref s2 j)))) + (- i start1) + (lp (+ i 1) (+ j 1))))))) + +(define (%string-suffix-length s1 start1 end1 s2 start2 end2) + (let* ((delta (min (- end1 start1) (- end2 start2))) + (start1 (- end1 delta))) + + (if (and (eq? s1 s2) (= end1 end2)) ; EQ fast path + delta + + (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path + (if (or (< i start1) + (not (char=? (string-ref s1 i) + (string-ref s2 j)))) + (- (- end1 i) 1) + (lp (- i 1) (- j 1))))))) + +(define (%string-prefix-length-ci s1 start1 end1 s2 start2 end2) + (let* ((delta (min (- end1 start1) (- end2 start2))) + (end1 (+ start1 delta))) + + (if (and (eq? s1 s2) (= start1 start2)) ; EQ fast path + delta + + (let lp ((i start1) (j start2)) ; Regular path + (if (or (>= i end1) + (not (char-ci=? (string-ref s1 i) + (string-ref s2 j)))) + (- i start1) + (lp (+ i 1) (+ j 1))))))) + +(define (%string-suffix-length-ci s1 start1 end1 s2 start2 end2) + (let* ((delta (min (- end1 start1) (- end2 start2))) + (start1 (- end1 delta))) + + (if (and (eq? s1 s2) (= end1 end2)) ; EQ fast path + delta + + (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path + (if (or (< i start1) + (not (char-ci=? (string-ref s1 i) + (string-ref s2 j)))) + (- (- end1 i) 1) + (lp (- i 1) (- j 1))))))) + + +(define (string-prefix-length s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-prefix-length s1 s2 maybe-starts+ends + (%string-prefix-length s1 start1 end1 s2 start2 end2))) + +(define (string-suffix-length s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-suffix-length s1 s2 maybe-starts+ends + (%string-suffix-length s1 start1 end1 s2 start2 end2))) + +(define (string-prefix-length-ci s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-prefix-length-ci s1 s2 maybe-starts+ends + (%string-prefix-length-ci s1 start1 end1 s2 start2 end2))) + +(define (string-suffix-length-ci s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-suffix-length-ci s1 s2 maybe-starts+ends + (%string-suffix-length-ci s1 start1 end1 s2 start2 end2))) + + +;;; string-prefix? s1 s2 [start1 end1 start2 end2] +;;; string-suffix? s1 s2 [start1 end1 start2 end2] +;;; string-prefix-ci? s1 s2 [start1 end1 start2 end2] +;;; string-suffix-ci? s1 s2 [start1 end1 start2 end2] +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; These are all simple derivatives of the previous counting funs. + +(define (string-prefix? s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-prefix? s1 s2 maybe-starts+ends + (%string-prefix? s1 start1 end1 s2 start2 end2))) + +(define (string-suffix? s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-suffix? s1 s2 maybe-starts+ends + (%string-suffix? s1 start1 end1 s2 start2 end2))) + +(define (string-prefix-ci? s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-prefix-ci? s1 s2 maybe-starts+ends + (%string-prefix-ci? s1 start1 end1 s2 start2 end2))) + +(define (string-suffix-ci? s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-suffix-ci? s1 s2 maybe-starts+ends + (%string-suffix-ci? s1 start1 end1 s2 start2 end2))) + + +;;; Here are the internal routines that do the real work. + +(define (%string-prefix? s1 start1 end1 s2 start2 end2) + (let ((len1 (- end1 start1))) + (and (<= len1 (- end2 start2)) ; Quick check + (= (%string-prefix-length s1 start1 end1 + s2 start2 end2) + len1)))) + +(define (%string-suffix? s1 start1 end1 s2 start2 end2) + (let ((len1 (- end1 start1))) + (and (<= len1 (- end2 start2)) ; Quick check + (= len1 (%string-suffix-length s1 start1 end1 + s2 start2 end2))))) + +(define (%string-prefix-ci? s1 start1 end1 s2 start2 end2) + (let ((len1 (- end1 start1))) + (and (<= len1 (- end2 start2)) ; Quick check + (= len1 (%string-prefix-length-ci s1 start1 end1 + s2 start2 end2))))) + +(define (%string-suffix-ci? s1 start1 end1 s2 start2 end2) + (let ((len1 (- end1 start1))) + (and (<= len1 (- end2 start2)) ; Quick check + (= len1 (%string-suffix-length-ci s1 start1 end1 + s2 start2 end2))))) + + +;;; string-compare s1 s2 proc< proc= proc> [start1 end1 start2 end2] +;;; string-compare-ci s1 s2 proc< proc= proc> [start1 end1 start2 end2] +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Primitive string-comparison functions. +;;; Continuation order is different from MIT Scheme. +;;; Continuations are applied to s1's mismatch index; +;;; in the case of equality, this is END1. + +(define (%string-compare s1 start1 end1 s2 start2 end2 + proc< proc= proc>) + (let ((size1 (- end1 start1)) + (size2 (- end2 start2))) + (let ((match (%string-prefix-length s1 start1 end1 s2 start2 end2))) + (if (= match size1) + ((if (= match size2) proc= proc<) end1) + ((if (= match size2) + proc> + (if (char)) + (+ match start1)))))) + +(define (%string-compare-ci s1 start1 end1 s2 start2 end2 + proc< proc= proc>) + (let ((size1 (- end1 start1)) + (size2 (- end2 start2))) + (let ((match (%string-prefix-length-ci s1 start1 end1 s2 start2 end2))) + (if (= match size1) + ((if (= match size2) proc= proc<) end1) + ((if (= match size2) proc> + (if (char-ci)) + (+ start1 match)))))) + +(define (string-compare s1 s2 proc< proc= proc> . maybe-starts+ends) + (check-arg procedure? proc< string-compare) + (check-arg procedure? proc= string-compare) + (check-arg procedure? proc> string-compare) + (let-string-start+end2 (start1 end1 start2 end2) + string-compare s1 s2 maybe-starts+ends + (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>))) + +(define (string-compare-ci s1 s2 proc< proc= proc> . maybe-starts+ends) + (check-arg procedure? proc< string-compare-ci) + (check-arg procedure? proc= string-compare-ci) + (check-arg procedure? proc> string-compare-ci) + (let-string-start+end2 (start1 end1 start2 end2) + string-compare-ci s1 s2 maybe-starts+ends + (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>))) + + + +;;; string= string<> string-ci= string-ci<> +;;; string< string> string-ci< string-ci> +;;; string<= string>= string-ci<= string-ci>= +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Simple definitions in terms of the previous comparison funs. +;;; I sure hope the %STRING-COMPARE calls get integrated. + +(define (string= s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string= s1 s2 maybe-starts+ends + (and (= (- end1 start1) (- end2 start2)) ; Quick filter + (or (and (eq? s1 s2) (= start1 start2)) ; Fast path + (%string-compare s1 start1 end1 s2 start2 end2 ; Real test + (lambda (i) #f) + values + (lambda (i) #f)))))) + +(define (string<> s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string<> s1 s2 maybe-starts+ends + (or (not (= (- end1 start1) (- end2 start2))) ; Fast path + (and (not (and (eq? s1 s2) (= start1 start2))) ; Quick filter + (%string-compare s1 start1 end1 s2 start2 end2 ; Real test + values + (lambda (i) #f) + values))))) + +(define (string< s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string< s1 s2 maybe-starts+ends + (if (and (eq? s1 s2) (= start1 start2)) ; Fast path + (< end1 end2) + + (%string-compare s1 start1 end1 s2 start2 end2 ; Real test + values + (lambda (i) #f) + (lambda (i) #f))))) + +(define (string> s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string> s1 s2 maybe-starts+ends + (if (and (eq? s1 s2) (= start1 start2)) ; Fast path + (> end1 end2) + + (%string-compare s1 start1 end1 s2 start2 end2 ; Real test + (lambda (i) #f) + (lambda (i) #f) + values)))) + +(define (string<= s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string<= s1 s2 maybe-starts+ends + (if (and (eq? s1 s2) (= start1 start2)) ; Fast path + (<= end1 end2) + + (%string-compare s1 start1 end1 s2 start2 end2 ; Real test + values + values + (lambda (i) #f))))) + +(define (string>= s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string>= s1 s2 maybe-starts+ends + (if (and (eq? s1 s2) (= start1 start2)) ; Fast path + (>= end1 end2) + + (%string-compare s1 start1 end1 s2 start2 end2 ; Real test + (lambda (i) #f) + values + values)))) + +(define (string-ci= s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-ci= s1 s2 maybe-starts+ends + (and (= (- end1 start1) (- end2 start2)) ; Quick filter + (or (and (eq? s1 s2) (= start1 start2)) ; Fast path + (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test + (lambda (i) #f) + values + (lambda (i) #f)))))) + +(define (string-ci<> s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-ci<> s1 s2 maybe-starts+ends + (or (not (= (- end1 start1) (- end2 start2))) ; Fast path + (and (not (and (eq? s1 s2) (= start1 start2))) ; Quick filter + (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test + values + (lambda (i) #f) + values))))) + +(define (string-ci< s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-ci< s1 s2 maybe-starts+ends + (if (and (eq? s1 s2) (= start1 start2)) ; Fast path + (< end1 end2) + + (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test + values + (lambda (i) #f) + (lambda (i) #f))))) + +(define (string-ci> s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-ci> s1 s2 maybe-starts+ends + (if (and (eq? s1 s2) (= start1 start2)) ; Fast path + (> end1 end2) + + (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test + (lambda (i) #f) + (lambda (i) #f) + values)))) + +(define (string-ci<= s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-ci<= s1 s2 maybe-starts+ends + (if (and (eq? s1 s2) (= start1 start2)) ; Fast path + (<= end1 end2) + + (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test + values + values + (lambda (i) #f))))) + +(define (string-ci>= s1 s2 . maybe-starts+ends) + (let-string-start+end2 (start1 end1 start2 end2) + string-ci>= s1 s2 maybe-starts+ends + (if (and (eq? s1 s2) (= start1 start2)) ; Fast path + (>= end1 end2) + + (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test + (lambda (i) #f) + values + values)))) + + +;;; Hash +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in +;;; to keep the intermediate values small. (We do the calculation with just +;;; enough bits to represent BOUND, masking off high bits at each step in +;;; calculation. If this screws up any important properties of the hash +;;; function I'd like to hear about it. -Olin) +;;; +;;; If you keep BOUND small enough, the intermediate calculations will +;;; always be fixnums. How small is dependent on the underlying Scheme system; +;;; we use a default BOUND of 2^22 = 4194304, which should hack it in +;;; Schemes that give you at least 29 signed bits for fixnums. The core +;;; calculation that you don't want to overflow is, worst case, +;;; (+ 65535 (* 37 (- bound 1))) +;;; where 65535 is the max character code. Choose the default BOUND to be the +;;; biggest power of two that won't cause this expression to fixnum overflow, +;;; and everything will be copacetic. + +(define (%string-hash s char->int bound start end) + (let ((iref (lambda (s i) (char->int (string-ref s i)))) + ;; Compute a 111...1 mask that will cover BOUND-1: + (mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh? + (if (>= i bound) (- i 1) (lp (+ i i)))))) + (let lp ((i start) (ans 0)) + (if (>= i end) (modulo ans bound) + (lp (+ i 1) (bitwise-and mask (+ (* 37 ans) (iref s i)))))))) + +(define (string-hash s . maybe-bound+start+end) + (let-optionals* maybe-bound+start+end ((bound 4194304 (and (integer? bound) + (exact? bound) + (<= 0 bound))) + rest) + (let ((bound (if (zero? bound) 4194304 bound))) ; 0 means default. + (let-string-start+end (start end) string-hash s rest + (%string-hash s char->integer bound start end))))) + +(define (string-hash-ci s . maybe-bound+start+end) + (let-optionals* maybe-bound+start+end ((bound 4194304 (and (integer? bound) + (exact? bound) + (<= 0 bound))) + rest) + (let ((bound (if (zero? bound) 4194304 bound))) ; 0 means default. + (let-string-start+end (start end) string-hash-ci s rest + (%string-hash s (lambda (c) (char->integer (char-downcase c))) + bound start end))))) + +;;; Case hacking +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; string-upcase s [start end] +;;; string-upcase! s [start end] +;;; string-downcase s [start end] +;;; string-downcase! s [start end] +;;; +;;; string-titlecase s [start end] +;;; string-titlecase! s [start end] +;;; Capitalize every contiguous alpha sequence: capitalise +;;; first char, lowercase rest. + +(define (string-upcase s . maybe-start+end) + (let-string-start+end (start end) string-upcase s maybe-start+end + (%string-map char-upcase s start end))) + +(define (string-upcase! s . maybe-start+end) + (let-string-start+end (start end) string-upcase! s maybe-start+end + (%string-map! char-upcase s start end))) + +(define (string-downcase s . maybe-start+end) + (let-string-start+end (start end) string-downcase s maybe-start+end + (%string-map char-downcase s start end))) + +(define (string-downcase! s . maybe-start+end) + (let-string-start+end (start end) string-downcase! s maybe-start+end + (%string-map! char-downcase s start end))) + +(define (%string-titlecase! s start end) + (let lp ((i start)) + (cond ((string-index s char-cased? i end) => + (lambda (i) + (string-set! s i (char-titlecase (string-ref s i))) + (let ((i1 (+ i 1))) + (cond ((string-skip s char-cased? i1 end) => + (lambda (j) + (string-downcase! s i1 j) + (lp (+ j 1)))) + (else (string-downcase! s i1 end))))))))) + +(define (string-titlecase! s . maybe-start+end) + (let-string-start+end (start end) string-titlecase! s maybe-start+end + (%string-titlecase! s start end))) + +(define (string-titlecase s . maybe-start+end) + (let-string-start+end (start end) string-titlecase! s maybe-start+end + (let ((ans (substring s start end))) + (%string-titlecase! ans 0 (- end start)) + ans))) + + +;;; Cutting & pasting strings +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; string-take string nchars +;;; string-drop string nchars +;;; +;;; string-take-right string nchars +;;; string-drop-right string nchars +;;; +;;; string-pad string k [char start end] +;;; string-pad-right string k [char start end] +;;; +;;; string-trim string [char/char-set/pred start end] +;;; string-trim-right string [char/char-set/pred start end] +;;; string-trim-both string [char/char-set/pred start end] +;;; +;;; These trimmers invert the char-set meaning from MIT Scheme -- you +;;; say what you want to trim. + +(define (string-take s n) + (check-arg string? s string-take) + (check-arg (lambda (val) (and (integer? n) (exact? n) + (<= 0 n (string-length s)))) + n string-take) + (%substring/shared s 0 n)) + +(define (string-take-right s n) + (check-arg string? s string-take-right) + (let ((len (string-length s))) + (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len))) + n string-take-right) + (%substring/shared s (- len n) len))) + +(define (string-drop s n) + (check-arg string? s string-drop) + (let ((len (string-length s))) + (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len))) + n string-drop) + (%substring/shared s n len))) + +(define (string-drop-right s n) + (check-arg string? s string-drop-right) + (let ((len (string-length s))) + (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len))) + n string-drop-right) + (%substring/shared s 0 (- len n)))) + + +(define (string-trim s . criterion+start+end) + (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest) + (let-string-start+end (start end) string-trim s rest + (cond ((string-skip s criterion start end) => + (lambda (i) (%substring/shared s i end))) + (else ""))))) + +(define (string-trim-right s . criterion+start+end) + (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest) + (let-string-start+end (start end) string-trim-right s rest + (cond ((string-skip-right s criterion start end) => + (lambda (i) (%substring/shared s 0 (+ 1 i)))) + (else ""))))) + +(define (string-trim-both s . criterion+start+end) + (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest) + (let-string-start+end (start end) string-trim-both s rest + (cond ((string-skip s criterion start end) => + (lambda (i) + (%substring/shared s i (+ 1 (string-skip-right s criterion i end))))) + (else ""))))) + + +(define (string-pad-right s n . char+start+end) + (let-optionals* char+start+end ((char #\space (char? char)) rest) + (let-string-start+end (start end) string-pad-right s rest + (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n))) + n string-pad-right) + (let ((len (- end start))) + (if (<= n len) + (%substring/shared s start (+ start n)) + (let ((ans (make-string n char))) + (%string-copy! ans 0 s start end) + ans)))))) + +(define (string-pad s n . char+start+end) + (let-optionals* char+start+end ((char #\space (char? char)) rest) + (let-string-start+end (start end) string-pad s rest + (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n))) + n string-pad) + (let ((len (- end start))) + (if (<= n len) + (%substring/shared s (- end n) end) + (let ((ans (make-string n char))) + (%string-copy! ans (- n len) s start end) + ans)))))) + + + +;;; Filtering strings +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; string-delete char/char-set/pred string [start end] +;;; string-filter char/char-set/pred string [start end] +;;; +;;; If the criterion is a char or char-set, we scan the string twice with +;;; string-fold -- once to determine the length of the result string, +;;; and once to do the filtered copy. +;;; If the criterion is a predicate, we don't do this double-scan strategy, +;;; because the predicate might have side-effects or be very expensive to +;;; compute. So we preallocate a temp buffer pessimistically, and only do +;;; one scan over S. This is likely to be faster and more space-efficient +;;; than consing a list. + +(define (string-delete criterion s . maybe-start+end) + (let-string-start+end (start end) string-delete s maybe-start+end + (if (procedure? criterion) + (let* ((slen (- end start)) + (temp (make-string slen)) + (ans-len (string-fold (lambda (c i) + (if (criterion c) i + (begin (string-set! temp i c) + (+ i 1)))) + 0 s start end))) + (if (= ans-len slen) temp (substring temp 0 ans-len))) + + (let* ((cset (cond ((char-set? criterion) criterion) + ((char? criterion) (char-set criterion)) + (else (error "string-delete criterion not predicate, char or char-set" criterion)))) + (len (string-fold (lambda (c i) (if (char-set-contains? cset c) + i + (+ i 1))) + 0 s start end)) + (ans (make-string len))) + (string-fold (lambda (c i) (if (char-set-contains? cset c) + i + (begin (string-set! ans i c) + (+ i 1)))) + 0 s start end) + ans)))) + +(define (string-filter criterion s . maybe-start+end) + (let-string-start+end (start end) string-filter s maybe-start+end + (if (procedure? criterion) + (let* ((slen (- end start)) + (temp (make-string slen)) + (ans-len (string-fold (lambda (c i) + (if (criterion c) + (begin (string-set! temp i c) + (+ i 1)) + i)) + 0 s start end))) + (if (= ans-len slen) temp (substring temp 0 ans-len))) + + (let* ((cset (cond ((char-set? criterion) criterion) + ((char? criterion) (char-set criterion)) + (else (error "string-delete criterion not predicate, char or char-set" criterion)))) + + (len (string-fold (lambda (c i) (if (char-set-contains? cset c) + (+ i 1) + i)) + 0 s start end)) + (ans (make-string len))) + (string-fold (lambda (c i) (if (char-set-contains? cset c) + (begin (string-set! ans i c) + (+ i 1)) + i)) + 0 s start end) + ans)))) + + +;;; String search +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; string-index string char/char-set/pred [start end] +;;; string-index-right string char/char-set/pred [start end] +;;; string-skip string char/char-set/pred [start end] +;;; string-skip-right string char/char-set/pred [start end] +;;; string-count string char/char-set/pred [start end] +;;; There's a lot of replicated code here for efficiency. +;;; For example, the char/char-set/pred discrimination has +;;; been lifted above the inner loop of each proc. + +(define (string-index str criterion . maybe-start+end) + (let-string-start+end (start end) string-index str maybe-start+end + (cond ((char? criterion) + (let lp ((i start)) + (and (< i end) + (if (char=? criterion (string-ref str i)) i + (lp (+ i 1)))))) + ((char-set? criterion) + (let lp ((i start)) + (and (< i end) + (if (char-set-contains? criterion (string-ref str i)) i + (lp (+ i 1)))))) + ((procedure? criterion) + (let lp ((i start)) + (and (< i end) + (if (criterion (string-ref str i)) i + (lp (+ i 1)))))) + (else (error "Second param is neither char-set, char, or predicate procedure." + string-index criterion))))) + +(define (string-index-right str criterion . maybe-start+end) + (let-string-start+end (start end) string-index-right str maybe-start+end + (cond ((char? criterion) + (let lp ((i (- end 1))) + (and (>= i start) + (if (char=? criterion (string-ref str i)) i + (lp (- i 1)))))) + ((char-set? criterion) + (let lp ((i (- end 1))) + (and (>= i start) + (if (char-set-contains? criterion (string-ref str i)) i + (lp (- i 1)))))) + ((procedure? criterion) + (let lp ((i (- end 1))) + (and (>= i start) + (if (criterion (string-ref str i)) i + (lp (- i 1)))))) + (else (error "Second param is neither char-set, char, or predicate procedure." + string-index-right criterion))))) + +(define (string-skip str criterion . maybe-start+end) + (let-string-start+end (start end) string-skip str maybe-start+end + (cond ((char? criterion) + (let lp ((i start)) + (and (< i end) + (if (char=? criterion (string-ref str i)) + (lp (+ i 1)) + i)))) + ((char-set? criterion) + (let lp ((i start)) + (and (< i end) + (if (char-set-contains? criterion (string-ref str i)) + (lp (+ i 1)) + i)))) + ((procedure? criterion) + (let lp ((i start)) + (and (< i end) + (if (criterion (string-ref str i)) (lp (+ i 1)) + i)))) + (else (error "Second param is neither char-set, char, or predicate procedure." + string-skip criterion))))) + +(define (string-skip-right str criterion . maybe-start+end) + (let-string-start+end (start end) string-skip-right str maybe-start+end + (cond ((char? criterion) + (let lp ((i (- end 1))) + (and (>= i start) + (if (char=? criterion (string-ref str i)) + (lp (- i 1)) + i)))) + ((char-set? criterion) + (let lp ((i (- end 1))) + (and (>= i start) + (if (char-set-contains? criterion (string-ref str i)) + (lp (- i 1)) + i)))) + ((procedure? criterion) + (let lp ((i (- end 1))) + (and (>= i start) + (if (criterion (string-ref str i)) (lp (- i 1)) + i)))) + (else (error "CRITERION param is neither char-set or char." + string-skip-right criterion))))) + + +(define (string-count s criterion . maybe-start+end) + (let-string-start+end (start end) string-count s maybe-start+end + (cond ((char? criterion) + (do ((i start (+ i 1)) + (count 0 (if (char=? criterion (string-ref s i)) + (+ count 1) + count))) + ((>= i end) count))) + + ((char-set? criterion) + (do ((i start (+ i 1)) + (count 0 (if (char-set-contains? criterion (string-ref s i)) + (+ count 1) + count))) + ((>= i end) count))) + + ((procedure? criterion) + (do ((i start (+ i 1)) + (count 0 (if (criterion (string-ref s i)) (+ count 1) count))) + ((>= i end) count))) + + (else (error "CRITERION param is neither char-set or char." + string-count criterion))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; string-fill! string char [start end] +;;; +;;; string-copy! to tstart from [fstart fend] +;;; Guaranteed to work, even if s1 eq s2. + +(define (string-fill! s char . maybe-start+end) + (check-arg char? char string-fill!) + (let-string-start+end (start end) string-fill! s maybe-start+end + (do ((i (- end 1) (- i 1))) + ((< i start)) + (string-set! s i char)))) + +(define (string-copy! to tstart from . maybe-fstart+fend) + (let-string-start+end (fstart fend) string-copy! from maybe-fstart+fend + (check-arg integer? tstart string-copy!) + (check-substring-spec string-copy! to tstart (+ tstart (- fend fstart))) + (%string-copy! to tstart from fstart fend))) + +;;; Library-internal routine +(define (%string-copy! to tstart from fstart fend) + (if (> fstart tstart) + (do ((i fstart (+ i 1)) + (j tstart (+ j 1))) + ((>= i fend)) + (string-set! to j (string-ref from i))) + + (do ((i (- fend 1) (- i 1)) + (j (+ -1 tstart (- fend fstart)) (- j 1))) + ((< i fstart)) + (string-set! to j (string-ref from i))))) + + + +;;; Returns starting-position in STRING or #f if not true. +;;; This implementation is slow & simple. It is useful as a "spec" or for +;;; comparison testing with fancier implementations. +;;; See below for fast KMP version. + +;(define (string-contains string substring . maybe-starts+ends) +; (let-string-start+end2 (start1 end1 start2 end2) +; string-contains string substring maybe-starts+ends +; (let* ((len (- end2 start2)) +; (i-bound (- end1 len))) +; (let lp ((i start1)) +; (and (< i i-bound) +; (if (string= string substring i (+ i len) start2 end2) +; i +; (lp (+ i 1)))))))) + + +;;; Searching for an occurrence of a substring +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (string-contains text pattern . maybe-starts+ends) + (let-string-start+end2 (t-start t-end p-start p-end) + string-contains text pattern maybe-starts+ends + (%kmp-search pattern text char=? p-start p-end t-start t-end))) + +(define (string-contains-ci text pattern . maybe-starts+ends) + (let-string-start+end2 (t-start t-end p-start p-end) + string-contains-ci text pattern maybe-starts+ends + (%kmp-search pattern text char-ci=? p-start p-end t-start t-end))) + + +;;; Knuth-Morris-Pratt string searching +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; See +;;; "Fast pattern matching in strings" +;;; SIAM J. Computing 6(2):323-350 1977 +;;; D. E. Knuth, J. H. Morris and V. R. Pratt +;;; also described in +;;; "Pattern matching in strings" +;;; Alfred V. Aho +;;; Formal Language Theory - Perspectives and Open Problems +;;; Ronald V. Brook (editor) +;;; This algorithm is O(m + n) where m and n are the +;;; lengths of the pattern and string respectively + +;;; KMP search source[start,end) for PATTERN. Return starting index of +;;; leftmost match or #f. + +(define (%kmp-search pattern text c= p-start p-end t-start t-end) + (let ((plen (- p-end p-start)) + (rv (make-kmp-restart-vector pattern c= p-start p-end))) + + ;; The search loop. TJ & PJ are redundant state. + (let lp ((ti t-start) (pi 0) + (tj (- t-end t-start)) ; (- tlen ti) -- how many chars left. + (pj plen)) ; (- plen pi) -- how many chars left. + + (if (= pi plen) + (- ti plen) ; Win. + (and (<= pj tj) ; Lose. + (if (c= (string-ref text ti) ; Search. + (string-ref pattern (+ p-start pi))) + (lp (+ 1 ti) (+ 1 pi) (- tj 1) (- pj 1)) ; Advance. + + (let ((pi (vector-ref rv pi))) ; Retreat. + (if (= pi -1) + (lp (+ ti 1) 0 (- tj 1) plen) ; Punt. + (lp ti pi tj (- plen pi)))))))))) + +;;; (make-kmp-restart-vector pattern [c= start end]) -> integer-vector +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Compute the KMP restart vector RV for string PATTERN. If +;;; we have matched chars 0..i-1 of PATTERN against a search string S, and +;;; PATTERN[i] doesn't match S[k], then reset i := RV[i], and try again to +;;; match S[k]. If RV[i] = -1, then punt S[k] completely, and move on to +;;; S[k+1] and PATTERN[0] -- no possible match of PAT[0..i] contains S[k]. +;;; +;;; In other words, if you have matched the first i chars of PATTERN, but +;;; the i+1'th char doesn't match, RV[i] tells you what the next-longest +;;; prefix of PATTERN is that you have matched. +;;; +;;; - C= (default CHAR=?) is used to compare characters for equality. +;;; Pass in CHAR-CI=? for case-folded string search. +;;; +;;; - START & END restrict the pattern to the indicated substring; the +;;; returned vector will be of length END - START. The numbers stored +;;; in the vector will be values in the range [0,END-START) -- that is, +;;; they are valid indices into the restart vector; you have to add START +;;; to them to use them as indices into PATTERN. +;;; +;;; I've split this out as a separate function in case other constant-string +;;; searchers might want to use it. +;;; +;;; E.g.: +;;; a b d a b x +;;; #(-1 0 0 -1 1 2) + +(define (make-kmp-restart-vector pattern . maybe-c=+start+end) + (let-optionals* maybe-c=+start+end + ((c= char=? (procedure? c=)) + ((start end) (lambda (args) + (string-parse-start+end make-kmp-restart-vector + pattern args)))) + (let* ((rvlen (- end start)) + (rv (make-vector rvlen -1))) + (if (> rvlen 0) + (let ((rvlen-1 (- rvlen 1)) + (c0 (string-ref pattern start))) + + ;; Here's the main loop. We have set rv[0] ... rv[i]. + ;; K = I + START -- it is the corresponding index into PATTERN. + (let lp1 ((i 0) (j -1) (k start)) + (if (< i rvlen-1) + ;; lp2 invariant: + ;; pat[(k-j) .. k-1] matches pat[start .. start+j-1] + ;; or j = -1. + (let lp2 ((j j)) + (cond ((= j -1) + (let ((i1 (+ 1 i))) + (if (not (c= (string-ref pattern (+ k 1)) c0)) + (vector-set! rv i1 0)) + (lp1 i1 0 (+ k 1)))) + ;; pat[(k-j) .. k] matches pat[start..start+j]. + ((c= (string-ref pattern k) (string-ref pattern (+ j start))) + (let* ((i1 (+ 1 i)) + (j1 (+ 1 j))) + (vector-set! rv i1 j1) + (lp1 i1 j1 (+ k 1)))) + + (else (lp2 (vector-ref rv j))))))))) + rv))) + + +;;; We've matched I chars from PAT. C is the next char from the search string. +;;; Return the new I after handling C. +;;; +;;; The pattern is (VECTOR-LENGTH RV) chars long, beginning at index PAT-START +;;; in PAT (PAT-START is usually 0). The I chars of the pattern we've matched +;;; are +;;; PAT[PAT-START .. PAT-START + I]. +;;; +;;; It's *not* an oversight that there is no friendly error checking or +;;; defaulting of arguments. This is a low-level, inner-loop procedure +;;; that we want integrated/inlined into the point of call. + +(define (kmp-step pat rv c i c= p-start) + (let lp ((i i)) + (if (c= c (string-ref pat (+ i p-start))) ; Match => + (+ i 1) ; Done. + (let ((i (vector-ref rv i))) ; Back up in PAT. + (if (= i -1) 0 ; Can't back up further. + (lp i)))))) ; Keep trying for match. + +;;; Zip through S[start,end), looking for a match of PAT. Assume we've +;;; already matched the first I chars of PAT when we commence at S[start]. +;;; - <0: If we find a match *ending* at index J, return -J. +;;; - >=0: If we get to the end of the S[start,end) span without finding +;;; a complete match, return the number of chars from PAT we'd matched +;;; when we ran off the end. +;;; +;;; This is useful for searching *across* buffers -- that is, when your +;;; input comes in chunks of text. We hand-integrate the KMP-STEP loop +;;; for speed. + +(define (string-kmp-partial-search pat rv s i . c=+p-start+s-start+s-end) + (check-arg vector? rv string-kmp-partial-search) + (let-optionals* c=+p-start+s-start+s-end + ((c= char=? (procedure? c=)) + (p-start 0 (and (integer? p-start) (exact? p-start) (<= 0 p-start))) + ((s-start s-end) (lambda (args) + (string-parse-start+end string-kmp-partial-search + s args)))) + (let ((patlen (vector-length rv))) + (check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i) (< i patlen))) + i string-kmp-partial-search) + + ;; Enough prelude. Here's the actual code. + (let lp ((si s-start) ; An index into S. + (vi i)) ; An index into RV. + (cond ((= vi patlen) (- si)) ; Win. + ((= si s-end) vi) ; Ran off the end. + (else ; Match s[si] & loop. + (let ((c (string-ref s si))) + (lp (+ si 1) + (let lp2 ((vi vi)) ; This is just KMP-STEP. + (if (c= c (string-ref pat (+ vi p-start))) + (+ vi 1) + (let ((vi (vector-ref rv vi))) + (if (= vi -1) 0 + (lp2 vi))))))))))))) + + +;;; Misc +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (string-null? s) +;;; (string-reverse s [start end]) +;;; (string-reverse! s [start end]) +;;; (reverse-list->string clist) +;;; (string->list s [start end]) + +(define (string-null? s) (zero? (string-length s))) + +(define (string-reverse s . maybe-start+end) + (let-string-start+end (start end) string-reverse s maybe-start+end + (let* ((len (- end start)) + (ans (make-string len))) + (do ((i start (+ i 1)) + (j (- len 1) (- j 1))) + ((< j 0)) + (string-set! ans j (string-ref s i))) + ans))) + +(define (string-reverse! s . maybe-start+end) + (let-string-start+end (start end) string-reverse! s maybe-start+end + (do ((i (- end 1) (- i 1)) + (j start (+ j 1))) + ((<= i j)) + (let ((ci (string-ref s i))) + (string-set! s i (string-ref s j)) + (string-set! s j ci))))) + + +(define (reverse-list->string clist) + (let* ((len (length clist)) + (s (make-string len))) + (do ((i (- len 1) (- i 1)) (clist clist (cdr clist))) + ((not (pair? clist))) + (string-set! s i (car clist))) + s)) + + +;(define (string->list s . maybe-start+end) +; (apply string-fold-right cons '() s maybe-start+end)) + +(define (string->list s . maybe-start+end) + (let-string-start+end (start end) string->list s maybe-start+end + (do ((i (- end 1) (- i 1)) + (ans '() (cons (string-ref s i) ans))) + ((< i start) ans)))) + +;;; Defined by R5RS, so commented out here. +;(define (list->string lis) (string-unfold null? car cdr lis)) + + +;;; string-concatenate string-list -> string +;;; string-concatenate/shared string-list -> string +;;; string-append/shared s ... -> string +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; STRING-APPEND/SHARED has license to return a string that shares storage +;;; with any of its arguments. In particular, if there is only one non-empty +;;; string amongst its parameters, it is permitted to return that string as +;;; its result. STRING-APPEND, by contrast, always allocates new storage. +;;; +;;; STRING-CONCATENATE & STRING-CONCATENATE/SHARED are passed a list of +;;; strings, which they concatenate into a result string. STRING-CONCATENATE +;;; always allocates a fresh string; STRING-CONCATENATE/SHARED may (or may +;;; not) return a result that shares storage with any of its arguments. In +;;; particular, if it is applied to a singleton list, it is permitted to +;;; return the car of that list as its value. + +(define (string-append/shared . strings) (string-concatenate/shared strings)) + +(define (string-concatenate/shared strings) + (let lp ((strings strings) (nchars 0) (first #f)) + (cond ((pair? strings) ; Scan the args, add up total + (let* ((string (car strings)) ; length, remember 1st + (tail (cdr strings)) ; non-empty string. + (slen (string-length string))) + (if (zero? slen) + (lp tail nchars first) + (lp tail (+ nchars slen) (or first strings))))) + + ((zero? nchars) "") + + ;; Just one non-empty string! Return it. + ((= nchars (string-length (car first))) (car first)) + + (else (let ((ans (make-string nchars))) + (let lp ((strings first) (i 0)) + (if (pair? strings) + (let* ((s (car strings)) + (slen (string-length s))) + (%string-copy! ans i s 0 slen) + (lp (cdr strings) (+ i slen))))) + ans))))) + + +; Alas, Scheme 48's APPLY blows up if you have many, many arguments. +;(define (string-concatenate strings) (apply string-append strings)) + +;;; Here it is written out. I avoid using REDUCE to add up string lengths +;;; to avoid non-R5RS dependencies. +(define (string-concatenate strings) + (let* ((total (do ((strings strings (cdr strings)) + (i 0 (+ i (string-length (car strings))))) + ((not (pair? strings)) i))) + (ans (make-string total))) + (let lp ((i 0) (strings strings)) + (if (pair? strings) + (let* ((s (car strings)) + (slen (string-length s))) + (%string-copy! ans i s 0 slen) + (lp (+ i slen) (cdr strings))))) + ans)) + + +;;; Defined by R5RS, so commented out here. +;(define (string-append . strings) (string-concatenate strings)) + +;;; string-concatenate-reverse string-list [final-string end] -> string +;;; string-concatenate-reverse/shared string-list [final-string end] -> string +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Return +;;; (string-concatenate +;;; (reverse +;;; (cons (substring final-string 0 end) string-list))) + +(define (string-concatenate-reverse string-list . maybe-final+end) + (let-optionals* maybe-final+end ((final "" (string? final)) + (end (string-length final) + (and (integer? end) + (exact? end) + (<= 0 end (string-length final))))) + (let ((len (let lp ((sum 0) (lis string-list)) + (if (pair? lis) + (lp (+ sum (string-length (car lis))) (cdr lis)) + sum)))) + + (%finish-string-concatenate-reverse len string-list final end)))) + +(define (string-concatenate-reverse/shared string-list . maybe-final+end) + (let-optionals* maybe-final+end ((final "" (string? final)) + (end (string-length final) + (and (integer? end) + (exact? end) + (<= 0 end (string-length final))))) + ;; Add up the lengths of all the strings in STRING-LIST; also get a + ;; pointer NZLIST into STRING-LIST showing where the first non-zero-length + ;; string starts. + (let lp ((len 0) (nzlist #f) (lis string-list)) + (if (pair? lis) + (let ((slen (string-length (car lis)))) + (lp (+ len slen) + (if (or nzlist (zero? slen)) nzlist lis) + (cdr lis))) + + (cond ((zero? len) (substring/shared final 0 end)) + + ;; LEN > 0, so NZLIST is non-empty. + + ((and (zero? end) (= len (string-length (car nzlist)))) + (car nzlist)) + + (else (%finish-string-concatenate-reverse len nzlist final end))))))) + +(define (%finish-string-concatenate-reverse len string-list final end) + (let ((ans (make-string (+ end len)))) + (%string-copy! ans len final 0 end) + (let lp ((i len) (lis string-list)) + (if (pair? lis) + (let* ((s (car lis)) + (lis (cdr lis)) + (slen (string-length s)) + (i (- i slen))) + (%string-copy! ans i s 0 slen) + (lp i lis)))) + ans)) + + + + +;;; string-replace s1 s2 start1 end1 [start2 end2] -> string +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Replace S1[START1,END1) with S2[START2,END2). + +(define (string-replace s1 s2 start1 end1 . maybe-start+end) + (check-substring-spec string-replace s1 start1 end1) + (let-string-start+end (start2 end2) string-replace s2 maybe-start+end + (let* ((slen1 (string-length s1)) + (sublen2 (- end2 start2)) + (alen (+ (- slen1 (- end1 start1)) sublen2)) + (ans (make-string alen))) + (%string-copy! ans 0 s1 0 start1) + (%string-copy! ans start1 s2 start2 end2) + (%string-copy! ans (+ start1 sublen2) s1 end1 slen1) + ans))) + + +;;; string-tokenize s [token-set start end] -> list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Break S up into a list of token strings, where a token is a maximal +;;; non-empty contiguous sequence of chars belonging to TOKEN-SET. +;;; (string-tokenize "hello, world") => ("hello," "world") + +(define (string-tokenize s . token-chars+start+end) + (let-optionals* token-chars+start+end + ((token-chars char-set:graphic (char-set? token-chars)) rest) + (let-string-start+end (start end) string-tokenize s rest + (let lp ((i end) (ans '())) + (cond ((and (< start i) (string-index-right s token-chars start i)) => + (lambda (tend-1) + (let ((tend (+ 1 tend-1))) + (cond ((string-skip-right s token-chars start tend-1) => + (lambda (tstart-1) + (lp tstart-1 + (cons (substring s (+ 1 tstart-1) tend) + ans)))) + (else (cons (substring s start tend) ans)))))) + (else ans)))))) + + +;;; xsubstring s from [to start end] -> string +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; S is a string; START and END are optional arguments that demarcate +;;; a substring of S, defaulting to 0 and the length of S (e.g., the whole +;;; string). Replicate this substring up and down index space, in both the +;; positive and negative directions. For example, if S = "abcdefg", START=3, +;;; and END=6, then we have the conceptual bidirectionally-infinite string +;;; ... d e f d e f d e f d e f d e f d e f d e f ... +;;; ... -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 ... +;;; XSUBSTRING returns the substring of this string beginning at index FROM, +;;; and ending at TO (which defaults to FROM+(END-START)). +;;; +;;; You can use XSUBSTRING in many ways: +;;; - To rotate a string left: (xsubstring "abcdef" 2) => "cdefab" +;;; - To rotate a string right: (xsubstring "abcdef" -2) => "efabcd" +;;; - To replicate a string: (xsubstring "abc" 0 7) => "abcabca" +;;; +;;; Note that +;;; - The FROM/TO indices give a half-open range -- the characters from +;;; index FROM up to, but not including index TO. +;;; - The FROM/TO indices are not in terms of the index space for string S. +;;; They are in terms of the replicated index space of the substring +;;; defined by S, START, and END. +;;; +;;; It is an error if START=END -- although this is allowed by special +;;; dispensation when FROM=TO. + +(define (xsubstring s from . maybe-to+start+end) + (check-arg (lambda (val) (and (integer? val) (exact? val))) + from xsubstring) + (receive (to start end) + (if (pair? maybe-to+start+end) + (let-string-start+end (start end) xsubstring s (cdr maybe-to+start+end) + (let ((to (car maybe-to+start+end))) + (check-arg (lambda (val) (and (integer? val) + (exact? val) + (<= from val))) + to xsubstring) + (values to start end))) + (let ((slen (string-length (check-arg string? s xsubstring)))) + (values (+ from slen) 0 slen))) + (let ((slen (- end start)) + (anslen (- to from))) + (cond ((zero? anslen) "") + ((zero? slen) (error "Cannot replicate empty (sub)string" + xsubstring s from to start end)) + + ((= 1 slen) ; Fast path for 1-char replication. + (make-string anslen (string-ref s start))) + + ;; Selected text falls entirely within one span. + ((= (floor (/ from slen)) (floor (/ to slen))) + (substring s (+ start (modulo from slen)) + (+ start (modulo to slen)))) + + ;; Selected text requires multiple spans. + (else (let ((ans (make-string anslen))) + (%multispan-repcopy! ans 0 s from to start end) + ans)))))) + + +;;; string-xcopy! target tstart s sfrom [sto start end] -> unspecific +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Exactly the same as xsubstring, but the extracted text is written +;;; into the string TARGET starting at index TSTART. +;;; This operation is not defined if (EQ? TARGET S) -- you cannot copy +;;; a string on top of itself. + +(define (string-xcopy! target tstart s sfrom . maybe-sto+start+end) + (check-arg (lambda (val) (and (integer? val) (exact? val))) + sfrom string-xcopy!) + (receive (sto start end) + (if (pair? maybe-sto+start+end) + (let-string-start+end (start end) string-xcopy! s (cdr maybe-sto+start+end) + (let ((sto (car maybe-sto+start+end))) + (check-arg (lambda (val) (and (integer? val) (exact? val))) + sto string-xcopy!) + (values sto start end))) + (let ((slen (string-length s))) + (values (+ sfrom slen) 0 slen))) + + (let* ((tocopy (- sto sfrom)) + (tend (+ tstart tocopy)) + (slen (- end start))) + (check-substring-spec string-xcopy! target tstart tend) + (cond ((zero? tocopy)) + ((zero? slen) (error "Cannot replicate empty (sub)string" + string-xcopy! + target tstart s sfrom sto start end)) + + ((= 1 slen) ; Fast path for 1-char replication. + (string-fill! target (string-ref s start) tstart tend)) + + ;; Selected text falls entirely within one span. + ((= (floor (/ sfrom slen)) (floor (/ sto slen))) + (%string-copy! target tstart s + (+ start (modulo sfrom slen)) + (+ start (modulo sto slen)))) + + ;; Multi-span copy. + (else (%multispan-repcopy! target tstart s sfrom sto start end)))))) + +;;; This is the core copying loop for XSUBSTRING and STRING-XCOPY! +;;; Internal -- not exported, no careful arg checking. +(define (%multispan-repcopy! target tstart s sfrom sto start end) + (let* ((slen (- end start)) + (i0 (+ start (modulo sfrom slen))) + (total-chars (- sto sfrom))) + + ;; Copy the partial span @ the beginning + (%string-copy! target tstart s i0 end) + + (let* ((ncopied (- end i0)) ; We've copied this many. + (nleft (- total-chars ncopied)) ; # chars left to copy. + (nspans (quotient nleft slen))) ; # whole spans to copy + + ;; Copy the whole spans in the middle. + (do ((i (+ tstart ncopied) (+ i slen)) ; Current target index. + (nspans nspans (- nspans 1))) ; # spans to copy + ((zero? nspans) + ;; Copy the partial-span @ the end & we're done. + (%string-copy! target i s start (+ start (- total-chars (- i tstart))))) + + (%string-copy! target i s start end))))); Copy a whole span. + + + +;;; (string-join string-list [delimiter grammar]) => string +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Paste strings together using the delimiter string. +;;; +;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz" +;;; +;;; DELIMITER defaults to a single space " " +;;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix} +;;; and defaults to 'infix. +;;; +;;; I could rewrite this more efficiently -- precompute the length of the +;;; answer string, then allocate & fill it in iteratively. Using +;;; STRING-CONCATENATE is less efficient. + +(define (string-join strings . delim+grammar) + (let-optionals* delim+grammar ((delim " " (string? delim)) + (grammar 'infix)) + (let ((buildit (lambda (lis final) + (let recur ((lis lis)) + (if (pair? lis) + (cons delim (cons (car lis) (recur (cdr lis)))) + final))))) + + (cond ((pair? strings) + (string-concatenate + (case grammar + + ((infix strict-infix) + (cons (car strings) (buildit (cdr strings) '()))) + + ((prefix) (buildit strings '())) + + ((suffix) + (cons (car strings) (buildit (cdr strings) (list delim)))) + + (else (error "Illegal join grammar" + grammar string-join))))) + + ((not (null? strings)) + (error "STRINGS parameter not list." strings string-join)) + + ;; STRINGS is () + + ((eq? grammar 'strict-infix) + (error "Empty list cannot be joined with STRICT-INFIX grammar." + string-join)) + + (else ""))))) ; Special-cased for infix grammar. + + +;;; Porting & performance-tuning notes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; See the section at the beginning of this file on external dependencies. +;;; +;;; The biggest issue with respect to porting is the LET-OPTIONALS* macro. +;;; There are many, many optional arguments in this library; the complexity +;;; of parsing, defaulting & type-testing these parameters is handled with the +;;; aid of this macro. There are about 15 uses of LET-OPTIONALS*. You can +;;; rewrite the uses, port the hairy macro definition (which is implemented +;;; using a Clinger-Rees low-level explicit-renaming macro system), or port +;;; the simple, high-level definition, which is less efficient. +;;; +;;; There is a fair amount of argument checking. This is, strictly speaking, +;;; unnecessary -- the actual body of the procedures will blow up if, say, a +;;; START/END index is improper. However, the error message will not be as +;;; good as if the error were caught at the "higher level." Also, a very, very +;;; smart Scheme compiler may be able to exploit having the type checks done +;;; early, so that the actual body of the procedures can assume proper values. +;;; This isn't likely; this kind of compiler technology isn't common any +;;; longer. +;;; +;;; The overhead of optional-argument parsing is irritating. The optional +;;; arguments must be consed into a rest list on entry, and then parsed out. +;;; Function call should be a matter of a few register moves and a jump; it +;;; should not involve heap allocation! Your Scheme system may have a superior +;;; non-R5RS optional-argument system that can eliminate this overhead. If so, +;;; then this is a prime candidate for optimising these procedures, +;;; *especially* the many optional START/END index parameters. +;;; +;;; Note that optional arguments are also a barrier to procedure integration. +;;; If your Scheme system permits you to specify alternate entry points +;;; for a call when the number of optional arguments is known in a manner +;;; that enables inlining/integration, this can provide performance +;;; improvements. +;;; +;;; There is enough *explicit* error checking that *all* string-index +;;; operations should *never* produce a bounds error. Period. Feel like +;;; living dangerously? *Big* performance win to be had by replacing +;;; STRING-REF's and STRING-SET!'s with unsafe equivalents in the loops. +;;; Similarly, fixnum-specific operators can speed up the arithmetic done on +;;; the index values in the inner loops. The only arguments that are not +;;; completely error checked are +;;; - string lists (complete checking requires time proportional to the +;;; length of the list) +;;; - procedure arguments, such as char->char maps & predicates. +;;; There is no way to check the range & domain of procedures in Scheme. +;;; Procedures that take these parameters cannot fully check their +;;; arguments. But all other types to all other procedures are fully +;;; checked. +;;; +;;; This does open up the alternate possibility of simply *removing* these +;;; checks, and letting the safe primitives raise the errors. On a dumb +;;; Scheme system, this would provide speed (by eliminating the redundant +;;; error checks) at the cost of error-message clarity. +;;; +;;; See the comments preceding the hash function code for notes on tuning +;;; the default bound so that the code never overflows your implementation's +;;; fixnum size into bignum calculation. +;;; +;;; In an interpreted Scheme, some of these procedures, or the internal +;;; routines with % prefixes, are excellent candidates for being rewritten +;;; in C. Consider STRING-HASH, %STRING-COMPARE, the +;;; %STRING-{SUF,PRE}FIX-LENGTH routines, STRING-COPY!, STRING-INDEX & +;;; STRING-SKIP (char-set & char cases), SUBSTRING and SUBSTRING/SHARED, +;;; %KMP-SEARCH, and %MULTISPAN-REPCOPY!. +;;; +;;; It would also be nice to have the ability to mark some of these +;;; routines as candidates for inlining/integration. +;;; +;;; All the %-prefixed routines in this source code are written +;;; to be called internally to this library. They do *not* perform +;;; friendly error checks on the inputs; they assume everything is +;;; proper. They also do not take optional arguments. These two properties +;;; save calling overhead and enable procedure integration -- but they +;;; are not appropriate for exported routines. + + +;;; Copyright details +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The prefix/suffix and comparison routines in this code had (extremely +;;; distant) origins in MIT Scheme's string lib, and was substantially +;;; reworked by Olin Shivers (shivers@ai.mit.edu) 9/98. As such, it is +;;; covered by MIT Scheme's open source copyright. See below for details. +;;; +;;; The KMP string-search code was influenced by implementations written +;;; by Stephen Bevan, Brian Dehneyer and Will Fitzgerald. However, this +;;; version was written from scratch by myself. +;;; +;;; The remainder of this code was written from scratch by myself for scsh. +;;; The scsh copyright is a BSD-style open source copyright. See below for +;;; details. +;;; -Olin Shivers + +;;; MIT Scheme copyright terms +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This material was developed by the Scheme project at the Massachusetts +;;; Institute of Technology, Department of Electrical Engineering and +;;; Computer Science. Permission to copy and modify this software, to +;;; redistribute either the original software or a modified version, and +;;; to use this software for any purpose is granted, subject to the +;;; following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright notice +;;; in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions that +;;; they make, so that these may be included in future releases; and (b) +;;; to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the usual +;;; standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation of +;;; this software will be error-free, and MIT is under no obligation to +;;; provide any services, by way of maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this material, +;;; there shall be no use of the name of the Massachusetts Institute of +;;; Technology nor of any adaptation thereof in any advertising, +;;; promotional, or sales literature without prior written consent from +;;; MIT in each case. + +;;; Scsh copyright terms +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the authors may not be used to endorse or promote products +;;; derived from this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/functional-tests/srfi/s13/strings.sls b/functional-tests/srfi/s13/strings.sls new file mode 100644 index 0000000..bde7f46 --- /dev/null +++ b/functional-tests/srfi/s13/strings.sls @@ -0,0 +1,85 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s13 strings) + (export + string-map string-map! + string-fold string-unfold + string-fold-right string-unfold-right + string-tabulate string-for-each string-for-each-index + string-every string-any + string-hash string-hash-ci + string-compare string-compare-ci + string= string< string> string<= string>= string<> + string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<> + string-downcase string-upcase string-titlecase + string-downcase! string-upcase! string-titlecase! + string-take string-take-right + string-drop string-drop-right + string-pad string-pad-right + string-trim string-trim-right string-trim-both + string-filter string-delete + string-index string-index-right + string-skip string-skip-right + string-count + string-prefix-length string-prefix-length-ci + string-suffix-length string-suffix-length-ci + string-prefix? string-prefix-ci? + string-suffix? string-suffix-ci? + string-contains string-contains-ci + string-copy! substring/shared + string-reverse string-reverse! reverse-list->string + string-concatenate string-concatenate/shared string-concatenate-reverse + string-concatenate-reverse/shared + string-append/shared + xsubstring string-xcopy! + string-null? + string-join + string-tokenize + string-replace + ; R5RS extended: + string->list string-copy string-fill! + ; R5RS re-exports: + string? make-string string-length string-ref string-set! + string string-append list->string + ; Low-level routines: + #;(make-kmp-restart-vector string-kmp-partial-search kmp-step + string-parse-start+end + string-parse-final-start+end + let-string-start+end + check-substring-spec + substring-spec-ok?) + ) + (import + (except (rnrs) string-copy string-for-each string->list + string-upcase string-downcase string-titlecase string-hash) + (except (rnrs mutable-strings) string-fill!) + (rnrs r5rs) + (srfi s23 error tricks) + (srfi s8 receive) + (srfi s14 char-sets) + (srfi private let-opt) + (srfi private include)) + + + (define-syntax check-arg + (lambda (stx) + (syntax-case stx () + [(_ pred val caller) + (and (identifier? #'val) (identifier? #'caller)) + #'(unless (pred val) + (assertion-violation 'caller "check-arg failed" val))]))) + + (define (char-cased? c) + (char-upper-case? (char-upcase c))) + + ;; (SRFI-23-error->R6RS "(library (srfi s13 strings))" + ;; (include/resolve ("srfi" "%3a13") "srfi-13.scm")) + + (SRFI-23-error->R6RS "(library (srfi s13 strings))" + (include/resolve ("srfi" "s13") "srfi-13.scm")) +) diff --git a/functional-tests/srfi/s14/char-sets.sls b/functional-tests/srfi/s14/char-sets.sls new file mode 100644 index 0000000..0d0aa92 --- /dev/null +++ b/functional-tests/srfi/s14/char-sets.sls @@ -0,0 +1,66 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s14 char-sets) + (export + ; Predicates & comparison + char-set? char-set= char-set<= char-set-hash + ; Iterating over character sets + char-set-cursor char-set-ref char-set-cursor-next end-of-char-set? + char-set-fold char-set-unfold char-set-unfold! + char-set-for-each char-set-map + ; Creating character sets + char-set-copy char-set + list->char-set string->char-set + list->char-set! string->char-set! + char-set-filter ucs-range->char-set + char-set-filter! ucs-range->char-set! + ->char-set + ; Querying character sets + char-set->list char-set->string + char-set-size char-set-count char-set-contains? + char-set-every char-set-any + ; Character-set algebra + char-set-adjoin char-set-delete + char-set-adjoin! char-set-delete! + char-set-complement char-set-union char-set-intersection + char-set-complement! char-set-union! char-set-intersection! + char-set-difference char-set-xor char-set-diff+intersection + char-set-difference! char-set-xor! char-set-diff+intersection! + ; Standard character sets + char-set:lower-case char-set:upper-case char-set:title-case + char-set:letter char-set:digit char-set:letter+digit + char-set:graphic char-set:printing char-set:whitespace + char-set:iso-control char-set:punctuation char-set:symbol + char-set:hex-digit char-set:blank char-set:ascii + char-set:empty char-set:full + ) + (import + (except (rnrs) define-record-type) + (rnrs mutable-strings) + (rnrs r5rs) + (srfi s23 error tricks) + (srfi s9 records) + (srfi private let-opt) + (srfi private include)) + + (define (%latin1->char i) + (integer->char i)) + + (define (%char->latin1 c) + (char->integer c)) + + (define-syntax check-arg + (lambda (stx) + (syntax-case stx () + [(_ pred val caller) + (identifier? #'val) + #'(unless (pred val) + (assertion-violation caller "check-arg failed" val))]))) + + (SRFI-23-error->R6RS "(library (srfi s14 char-sets))" + (include/resolve ("srfi" "s14") "srfi-14.scm"))) diff --git a/functional-tests/srfi/s14/srfi-14.scm b/functional-tests/srfi/s14/srfi-14.scm new file mode 100644 index 0000000..4e78dd8 --- /dev/null +++ b/functional-tests/srfi/s14/srfi-14.scm @@ -0,0 +1,806 @@ +;;; SRFI-14 character-sets library -*- Scheme -*- +;;; +;;; - Ported from MIT Scheme runtime by Brian D. Carlstrom. +;;; - Massively rehacked & extended by Olin Shivers 6/98. +;;; - Massively redesigned and rehacked 5/2000 during SRFI process. +;;; At this point, the code bears the following relationship to the +;;; MIT Scheme code: "This is my grandfather's axe. My father replaced +;;; the head, and I have replaced the handle." Nonetheless, we preserve +;;; the MIT Scheme copyright: +;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology +;;; The MIT Scheme license is a "free software" license. See the end of +;;; this file for the tedious details. + +;;; Exports: +;;; char-set? char-set= char-set<= +;;; char-set-hash +;;; char-set-cursor char-set-ref char-set-cursor-next end-of-char-set? +;;; char-set-fold char-set-unfold char-set-unfold! +;;; char-set-for-each char-set-map +;;; char-set-copy char-set +;;; +;;; list->char-set string->char-set +;;; list->char-set! string->char-set! +;;; +;;; filterchar-set ucs-range->char-set ->char-set +;;; filterchar-set! ucs-range->char-set! +;;; +;;; char-set->list char-set->string +;;; +;;; char-set-size char-set-count char-set-contains? +;;; char-set-every char-set-any +;;; +;;; char-set-adjoin char-set-delete +;;; char-set-adjoin! char-set-delete! +;;; + +;;; char-set-complement char-set-union char-set-intersection +;;; char-set-complement! char-set-union! char-set-intersection! +;;; +;;; char-set-difference char-set-xor char-set-diff+intersection +;;; char-set-difference! char-set-xor! char-set-diff+intersection! +;;; +;;; char-set:lower-case char-set:upper-case char-set:title-case +;;; char-set:letter char-set:digit char-set:letter+digit +;;; char-set:graphic char-set:printing char-set:whitespace +;;; char-set:iso-control char-set:punctuation char-set:symbol +;;; char-set:hex-digit char-set:blank char-set:ascii +;;; char-set:empty char-set:full + +;;; Imports +;;; This code has the following non-R5RS dependencies: +;;; - ERROR +;;; - %LATIN1->CHAR %CHAR->LATIN1 +;;; - LET-OPTIONALS* and :OPTIONAL macros for parsing, checking & defaulting +;;; optional arguments from rest lists. +;;; - BITWISE-AND for CHAR-SET-HASH +;;; - The SRFI-19 DEFINE-RECORD-TYPE record macro +;;; - A simple CHECK-ARG procedure: +;;; (lambda (pred val caller) (if (not (pred val)) (error val caller))) + +;;; This is simple code, not great code. Char sets are represented as 256-char +;;; strings. If char I is ASCII/Latin-1 0, then it isn't in the set; if char I +;;; is ASCII/Latin-1 1, then it is in the set. +;;; - Should be rewritten to use bit strings or byte vecs. +;;; - Is Latin-1 specific. Would certainly have to be rewritten for Unicode. + +;;; See the end of the file for porting and performance-tuning notes. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-record-type :char-set + (make-char-set s) + char-set? + (s char-set:s)) + + +(define (%string-copy s) (substring s 0 (string-length s))) + +;;; Parse, type-check & default a final optional BASE-CS parameter from +;;; a rest argument. Return a *fresh copy* of the underlying string. +;;; The default is the empty set. The PROC argument is to help us +;;; generate informative error exceptions. + +(define (%default-base maybe-base proc) + (if (pair? maybe-base) + (let ((bcs (car maybe-base)) + (tail (cdr maybe-base))) + (if (null? tail) + (if (char-set? bcs) (%string-copy (char-set:s bcs)) + (assertion-violation proc "BASE-CS parameter not a char-set" bcs)) + (assertion-violation proc + "Expected final base char set -- too many parameters" maybe-base))) + (make-string 256 (%latin1->char 0)))) + +;;; If CS is really a char-set, do CHAR-SET:S, otw report an error msg on +;;; behalf of our caller, PROC. This procedure exists basically to provide +;;; explicit error-checking & reporting. + +(define (%char-set:s/check cs proc) + (let lp ((cs cs)) + (if (char-set? cs) (char-set:s cs) + (lp (assertion-violation proc "Not a char-set" cs))))) + + + +;;; These internal functions hide a lot of the dependency on the +;;; underlying string representation of char sets. They should be +;;; inlined if possible. + +(define (si=0? s i) (zero? (%char->latin1 (string-ref s i)))) +(define (si=1? s i) (not (si=0? s i))) +(define c0 (%latin1->char 0)) +(define c1 (%latin1->char 1)) +(define (si s i) (%char->latin1 (string-ref s i))) +(define (%set0! s i) (string-set! s i c0)) +(define (%set1! s i) (string-set! s i c1)) + +;;; These do various "s[i] := s[i] op val" operations -- see +;;; %CHAR-SET-ALGEBRA. They are used to implement the various +;;; set-algebra procedures. +(define (setv! s i v) (string-set! s i (%latin1->char v))) ; SET to a Value. +(define (%not! s i v) (setv! s i (- 1 v))) +(define (%and! s i v) (if (zero? v) (%set0! s i))) +(define (%or! s i v) (if (not (zero? v)) (%set1! s i))) +(define (%minus! s i v) (if (not (zero? v)) (%set0! s i))) +(define (%xor! s i v) (if (not (zero? v)) (setv! s i (- 1 (si s i))))) + + +(define (char-set-copy cs) + (make-char-set (%string-copy (%char-set:s/check cs 'char-set-copy)))) + +(define (char-set= . rest) + (or (null? rest) + (let* ((cs1 (car rest)) + (rest (cdr rest)) + (s1 (%char-set:s/check cs1 'char-set=))) + (let lp ((rest rest)) + (or (not (pair? rest)) + (and (string=? s1 (%char-set:s/check (car rest) 'char-set=)) + (lp (cdr rest)))))))) + +(define (char-set<= . rest) + (or (null? rest) + (let ((cs1 (car rest)) + (rest (cdr rest))) + (let lp ((s1 (%char-set:s/check cs1 'char-set<=)) (rest rest)) + (or (not (pair? rest)) + (let ((s2 (%char-set:s/check (car rest) 'char-set<=)) + (rest (cdr rest))) + (if (eq? s1 s2) (lp s2 rest) ; Fast path + (let lp2 ((i 255)) ; Real test + (if (< i 0) (lp s2 rest) + (and (<= (si s1 i) (si s2 i)) + (lp2 (- i 1)))))))))))) + +;;; Hash +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in +;;; to keep the intermediate values small. (We do the calculation with just +;;; enough bits to represent BOUND, masking off high bits at each step in +;;; calculation. If this screws up any important properties of the hash +;;; function I'd like to hear about it. -Olin) +;;; +;;; If you keep BOUND small enough, the intermediate calculations will +;;; always be fixnums. How small is dependent on the underlying Scheme system; +;;; we use a default BOUND of 2^22 = 4194304, which should hack it in +;;; Schemes that give you at least 29 signed bits for fixnums. The core +;;; calculation that you don't want to overflow is, worst case, +;;; (+ 65535 (* 37 (- bound 1))) +;;; where 65535 is the max character code. Choose the default BOUND to be the +;;; biggest power of two that won't cause this expression to fixnum overflow, +;;; and everything will be copacetic. + +(define (char-set-hash cs . maybe-bound) + (let* ((bound (:optional maybe-bound 4194304 (lambda (n) (and (integer? n) + (exact? n) + (<= 0 n))))) + (bound (if (zero? bound) 4194304 bound)) ; 0 means default. + (s (%char-set:s/check cs 'char-set-hash)) + ;; Compute a 111...1 mask that will cover BOUND-1: + (mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh? + (if (>= i bound) (- i 1) (lp (+ i i)))))) + + (let lp ((i 255) (ans 0)) + (if (< i 0) (modulo ans bound) + (lp (- i 1) + (if (si=0? s i) ans + (bitwise-and mask (+ (* 37 ans) i)))))))) + + +(define (char-set-contains? cs char) + (check-arg char? char 'char-set-contains?) + (si=1? (%char-set:s/check cs 'char-set-contains?) + (%char->latin1 char))) + +(define (char-set-size cs) + (let ((s (%char-set:s/check cs 'char-set-size))) + (let lp ((i 255) (size 0)) + (if (< i 0) size + (lp (- i 1) (+ size (si s i))))))) + +(define (char-set-count pred cset) + (check-arg procedure? pred 'char-set-count) + (let ((s (%char-set:s/check cset 'char-set-count))) + (let lp ((i 255) (count 0)) + (if (< i 0) count + (lp (- i 1) + (if (and (si=1? s i) (pred (%latin1->char i))) + (+ count 1) + count)))))) + + +;;; -- Adjoin & delete + +(define (%set-char-set set proc cs chars) + (let ((s (%string-copy (%char-set:s/check cs proc)))) + (for-each (lambda (c) (set s (%char->latin1 c))) + chars) + (make-char-set s))) + +(define (%set-char-set! set proc cs chars) + (let ((s (%char-set:s/check cs proc))) + (for-each (lambda (c) (set s (%char->latin1 c))) + chars)) + cs) + +(define (char-set-adjoin cs . chars) + (%set-char-set %set1! 'char-set-adjoin cs chars)) +(define (char-set-adjoin! cs . chars) + (%set-char-set! %set1! 'char-set-adjoin! cs chars)) +(define (char-set-delete cs . chars) + (%set-char-set %set0! 'char-set-delete cs chars)) +(define (char-set-delete! cs . chars) + (%set-char-set! %set0! 'char-set-delete! cs chars)) + + +;;; Cursors +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Simple implementation. A cursors is an integer index into the +;;; mark vector, and -1 for the end-of-char-set cursor. +;;; +;;; If we represented char sets as a bit set, we could do the following +;;; trick to pick the lowest bit out of the set: +;;; (count-bits (xor (- cset 1) cset)) +;;; (But first mask out the bits already scanned by the cursor first.) + +(define (char-set-cursor cset) + (%char-set-cursor-next cset 256 'char-set-cursor)) + +(define (end-of-char-set? cursor) (< cursor 0)) + +(define (char-set-ref cset cursor) (%latin1->char cursor)) + +(define (char-set-cursor-next cset cursor) + (check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i 255))) cursor + 'char-set-cursor-next) + (%char-set-cursor-next cset cursor 'char-set-cursor-next)) + +(define (%char-set-cursor-next cset cursor proc) ; Internal + (let ((s (%char-set:s/check cset proc))) + (let lp ((cur cursor)) + (let ((cur (- cur 1))) + (if (or (< cur 0) (si=1? s cur)) cur + (lp cur)))))) + + +;;; -- for-each map fold unfold every any + +(define (char-set-for-each proc cs) + (check-arg procedure? proc 'char-set-for-each) + (let ((s (%char-set:s/check cs 'char-set-for-each))) + (let lp ((i 255)) + (cond ((>= i 0) + (if (si=1? s i) (proc (%latin1->char i))) + (lp (- i 1))))))) + +(define (char-set-map proc cs) + (check-arg procedure? proc 'char-set-map) + (let ((s (%char-set:s/check cs 'char-set-map)) + (ans (make-string 256 c0))) + (let lp ((i 255)) + (cond ((>= i 0) + (if (si=1? s i) + (%set1! ans (%char->latin1 (proc (%latin1->char i))))) + (lp (- i 1))))) + (make-char-set ans))) + +(define (char-set-fold kons knil cs) + (check-arg procedure? kons 'char-set-fold) + (let ((s (%char-set:s/check cs 'char-set-fold))) + (let lp ((i 255) (ans knil)) + (if (< i 0) ans + (lp (- i 1) + (if (si=0? s i) ans + (kons (%latin1->char i) ans))))))) + +(define (char-set-every pred cs) + (check-arg procedure? pred 'char-set-every) + (let ((s (%char-set:s/check cs 'char-set-every))) + (let lp ((i 255)) + (or (< i 0) + (and (or (si=0? s i) (pred (%latin1->char i))) + (lp (- i 1))))))) + +(define (char-set-any pred cs) + (check-arg procedure? pred 'char-set-any) + (let ((s (%char-set:s/check cs 'char-set-any))) + (let lp ((i 255)) + (and (>= i 0) + (or (and (si=1? s i) (pred (%latin1->char i))) + (lp (- i 1))))))) + + +(define (%char-set-unfold! proc p f g s seed) + (check-arg procedure? p proc) + (check-arg procedure? f proc) + (check-arg procedure? g proc) + (let lp ((seed seed)) + (cond ((not (p seed)) ; P says we are done. + (%set1! s (%char->latin1 (f seed))) ; Add (F SEED) to set. + (lp (g seed)))))) ; Loop on (G SEED). + +(define (char-set-unfold p f g seed . maybe-base) + (let ((bs (%default-base maybe-base 'char-set-unfold))) + (%char-set-unfold! 'char-set-unfold p f g bs seed) + (make-char-set bs))) + +(define (char-set-unfold! p f g seed base-cset) + (%char-set-unfold! 'char-set-unfold! p f g + (%char-set:s/check base-cset 'char-set-unfold!) + seed) + base-cset) + + + +;;; list <--> char-set + +(define (%list->char-set! chars s) + (for-each (lambda (char) (%set1! s (%char->latin1 char))) + chars)) + +(define (char-set . chars) + (let ((s (make-string 256 c0))) + (%list->char-set! chars s) + (make-char-set s))) + +(define (list->char-set chars . maybe-base) + (let ((bs (%default-base maybe-base 'list->char-set))) + (%list->char-set! chars bs) + (make-char-set bs))) + +(define (list->char-set! chars base-cs) + (%list->char-set! chars (%char-set:s/check base-cs 'list->char-set!)) + base-cs) + + +(define (char-set->list cs) + (let ((s (%char-set:s/check cs 'char-set->list))) + (let lp ((i 255) (ans '())) + (if (< i 0) ans + (lp (- i 1) + (if (si=0? s i) ans + (cons (%latin1->char i) ans))))))) + + + +;;; string <--> char-set + +(define (%string->char-set! str bs proc) + (check-arg string? str proc) + (do ((i (- (string-length str) 1) (- i 1))) + ((< i 0)) + (%set1! bs (%char->latin1 (string-ref str i))))) + +(define (string->char-set str . maybe-base) + (let ((bs (%default-base maybe-base 'string->char-set))) + (%string->char-set! str bs 'string->char-set) + (make-char-set bs))) + +(define (string->char-set! str base-cs) + (%string->char-set! str (%char-set:s/check base-cs 'string->char-set!) + 'string->char-set!) + base-cs) + + +(define (char-set->string cs) + (let* ((s (%char-set:s/check cs 'char-set->string)) + (ans (make-string (char-set-size cs)))) + (let lp ((i 255) (j 0)) + (if (< i 0) ans + (let ((j (if (si=0? s i) j + (begin (string-set! ans j (%latin1->char i)) + (+ j 1))))) + (lp (- i 1) j)))))) + + +;;; -- UCS-range -> char-set + +(define (%ucs-range->char-set! lower upper error? bs proc) + (check-arg (lambda (x) (and (integer? x) (exact? x) (<= 0 x))) lower proc) + (check-arg (lambda (x) (and (integer? x) (exact? x) (<= lower x))) upper proc) + + (if (and (< lower upper) (< 256 upper) error?) + (assertion-violation proc + "Requested UCS range contains unavailable characters -- this implementation only supports Latin-1" + lower upper)) + + (let lp ((i (- (min upper 256) 1))) + (cond ((<= lower i) (%set1! bs i) (lp (- i 1)))))) + +(define (ucs-range->char-set lower upper . rest) + (let-optionals* rest ((error? #f) rest) + (let ((bs (%default-base rest 'ucs-range->char-set))) + (%ucs-range->char-set! lower upper error? bs 'ucs-range->char-set) + (make-char-set bs)))) + +(define (ucs-range->char-set! lower upper error? base-cs) + (%ucs-range->char-set! lower upper error? + (%char-set:s/check base-cs 'ucs-range->char-set!) + 'ucs-range->char-set) + base-cs) + + +;;; -- predicate -> char-set + +(define (%char-set-filter! pred ds bs proc) + (check-arg procedure? pred proc) + (let lp ((i 255)) + (cond ((>= i 0) + (if (and (si=1? ds i) (pred (%latin1->char i))) + (%set1! bs i)) + (lp (- i 1)))))) + +(define (char-set-filter predicate domain . maybe-base) + (let ((bs (%default-base maybe-base 'char-set-filter))) + (%char-set-filter! predicate + (%char-set:s/check domain 'char-set-filter!) + bs + 'char-set-filter) + (make-char-set bs))) + +(define (char-set-filter! predicate domain base-cs) + (%char-set-filter! predicate + (%char-set:s/check domain 'char-set-filter!) + (%char-set:s/check base-cs 'char-set-filter!) + 'char-set-filter!) + base-cs) + + +;;; {string, char, char-set, char predicate} -> char-set + +(define (->char-set x) + (cond ((char-set? x) x) + ((string? x) (string->char-set x)) + ((char? x) (char-set x)) + (else (error "Not a charset, string or char." x)))) + + + +;;; Set algebra +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The exported ! procs are "linear update" -- allowed, but not required, to +;;; side-effect their first argument when computing their result. In other +;;; words, you must use them as if they were completely functional, just like +;;; their non-! counterparts, and you must additionally ensure that their +;;; first arguments are "dead" at the point of call. In return, we promise a +;;; more efficient result, plus allowing you to always assume char-sets are +;;; unchangeable values. + +;;; Apply P to each index and its char code in S: (P I VAL). +;;; Used by the set-algebra ops. + +(define (%string-iter p s) + (let lp ((i (- (string-length s) 1))) + (cond ((>= i 0) + (p i (%char->latin1 (string-ref s i))) + (lp (- i 1)))))) + +;;; String S represents some initial char-set. (OP s i val) does some +;;; kind of s[i] := s[i] op val update. Do +;;; S := S OP CSETi +;;; for all the char-sets in the list CSETS. The n-ary set-algebra ops +;;; all use this internal proc. + +(define (%char-set-algebra s csets op proc) + (for-each (lambda (cset) + (let ((s2 (%char-set:s/check cset proc))) + (let lp ((i 255)) + (cond ((>= i 0) + (op s i (si s2 i)) + (lp (- i 1))))))) + csets)) + + +;;; -- Complement + +(define (char-set-complement cs) + (let ((s (%char-set:s/check cs 'char-set-complement)) + (ans (make-string 256))) + (%string-iter (lambda (i v) (%not! ans i v)) s) + (make-char-set ans))) + +(define (char-set-complement! cset) + (let ((s (%char-set:s/check cset 'char-set-complement!))) + (%string-iter (lambda (i v) (%not! s i v)) s)) + cset) + + +;;; -- Union + +(define (char-set-union! cset1 . csets) + (%char-set-algebra (%char-set:s/check cset1 'char-set-union!) + csets %or! 'char-set-union!) + cset1) + +(define (char-set-union . csets) + (if (pair? csets) + (let ((s (%string-copy (%char-set:s/check (car csets) 'char-set-union)))) + (%char-set-algebra s (cdr csets) %or! 'char-set-union) + (make-char-set s)) + (char-set-copy char-set:empty))) + + +;;; -- Intersection + +(define (char-set-intersection! cset1 . csets) + (%char-set-algebra (%char-set:s/check cset1 'char-set-intersection!) + csets %and! 'char-set-intersection!) + cset1) + +(define (char-set-intersection . csets) + (if (pair? csets) + (let ((s (%string-copy (%char-set:s/check (car csets) 'char-set-intersection)))) + (%char-set-algebra s (cdr csets) %and! 'char-set-intersection) + (make-char-set s)) + (char-set-copy char-set:full))) + + +;;; -- Difference + +(define (char-set-difference! cset1 . csets) + (%char-set-algebra (%char-set:s/check cset1 'char-set-difference!) + csets %minus! 'char-set-difference!) + cset1) + +(define (char-set-difference cs1 . csets) + (if (pair? csets) + (let ((s (%string-copy (%char-set:s/check cs1 'char-set-difference)))) + (%char-set-algebra s csets %minus! 'char-set-difference) + (make-char-set s)) + (char-set-copy cs1))) + + +;;; -- Xor + +(define (char-set-xor! cset1 . csets) + (%char-set-algebra (%char-set:s/check cset1 'char-set-xor!) + csets %xor! 'char-set-xor!) + cset1) + +(define (char-set-xor . csets) + (if (pair? csets) + (let ((s (%string-copy (%char-set:s/check (car csets) 'char-set-xor)))) + (%char-set-algebra s (cdr csets) %xor! 'char-set-xor) + (make-char-set s)) + (char-set-copy char-set:empty))) + + +;;; -- Difference & intersection + +(define (%char-set-diff+intersection! diff int csets proc) + (for-each (lambda (cs) + (%string-iter (lambda (i v) + (if (not (zero? v)) + (cond ((si=1? diff i) + (%set0! diff i) + (%set1! int i))))) + (%char-set:s/check cs proc))) + csets)) + +(define (char-set-diff+intersection! cs1 cs2 . csets) + (let ((s1 (%char-set:s/check cs1 'char-set-diff+intersection!)) + (s2 (%char-set:s/check cs2 'char-set-diff+intersection!))) + (%string-iter (lambda (i v) (if (zero? v) + (%set0! s2 i) + (if (si=1? s2 i) (%set0! s1 i)))) + s1) + (%char-set-diff+intersection! s1 s2 csets 'char-set-diff+intersection!)) + (values cs1 cs2)) + +(define (char-set-diff+intersection cs1 . csets) + (let ((diff (string-copy (%char-set:s/check cs1 'char-set-diff+intersection))) + (int (make-string 256 c0))) + (%char-set-diff+intersection! diff int csets 'char-set-diff+intersection) + (values (make-char-set diff) (make-char-set int)))) + + +;;;; System character sets +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; These definitions are for Latin-1. +;;; +;;; If your Scheme implementation allows you to mark the underlying strings +;;; as immutable, you should do so -- it would be very, very bad if a client's +;;; buggy code corrupted these constants. + +(define char-set:empty (char-set)) +(define char-set:full (char-set-complement char-set:empty)) + +(define char-set:lower-case + (let* ((a-z (ucs-range->char-set #x61 #x7B)) + (latin1 (ucs-range->char-set! #xdf #xf7 #t a-z)) + (latin2 (ucs-range->char-set! #xf8 #x100 #t latin1))) + (char-set-adjoin! latin2 (%latin1->char #xb5)))) + +(define char-set:upper-case + (let ((A-Z (ucs-range->char-set #x41 #x5B))) + ;; Add in the Latin-1 upper-case chars. + (ucs-range->char-set! #xd8 #xdf #t + (ucs-range->char-set! #xc0 #xd7 #t A-Z)))) + +(define char-set:title-case char-set:empty) + +(define char-set:letter + (let ((u/l (char-set-union char-set:upper-case char-set:lower-case))) + (char-set-adjoin! u/l + (%latin1->char #xaa) ; FEMININE ORDINAL INDICATOR + (%latin1->char #xba)))) ; MASCULINE ORDINAL INDICATOR + +(define char-set:digit (string->char-set "0123456789")) +(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF")) + +(define char-set:letter+digit + (char-set-union char-set:letter char-set:digit)) + +(define char-set:punctuation + (let ((ascii (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")) + (latin-1-chars (map %latin1->char '(#xA1 ; INVERTED EXCLAMATION MARK + #xAB ; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK + #xAD ; SOFT HYPHEN + #xB7 ; MIDDLE DOT + #xBB ; RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK + #xBF)))) ; INVERTED QUESTION MARK + (list->char-set! latin-1-chars ascii))) + +(define char-set:symbol + (let ((ascii (string->char-set "$+<=>^`|~")) + (latin-1-chars (map %latin1->char '(#x00A2 ; CENT SIGN + #x00A3 ; POUND SIGN + #x00A4 ; CURRENCY SIGN + #x00A5 ; YEN SIGN + #x00A6 ; BROKEN BAR + #x00A7 ; SECTION SIGN + #x00A8 ; DIAERESIS + #x00A9 ; COPYRIGHT SIGN + #x00AC ; NOT SIGN + #x00AE ; REGISTERED SIGN + #x00AF ; MACRON + #x00B0 ; DEGREE SIGN + #x00B1 ; PLUS-MINUS SIGN + #x00B4 ; ACUTE ACCENT + #x00B6 ; PILCROW SIGN + #x00B8 ; CEDILLA + #x00D7 ; MULTIPLICATION SIGN + #x00F7)))) ; DIVISION SIGN + (list->char-set! latin-1-chars ascii))) + + +(define char-set:graphic + (char-set-union char-set:letter+digit char-set:punctuation char-set:symbol)) + +(define char-set:whitespace + (list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION + #x0A ; LINE FEED + #x0B ; VERTICAL TABULATION + #x0C ; FORM FEED + #x0D ; CARRIAGE RETURN + #x20 ; SPACE + #xA0)))) + +(define char-set:printing (char-set-union char-set:whitespace char-set:graphic)) ; NO-BREAK SPACE + +(define char-set:blank + (list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION + #x20 ; SPACE + #xA0)))) ; NO-BREAK SPACE + + +(define char-set:iso-control + (ucs-range->char-set! #x7F #xA0 #t (ucs-range->char-set 0 32))) + +(define char-set:ascii (ucs-range->char-set 0 128)) + + +;;; Porting & performance-tuning notes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; See the section at the beginning of this file on external dependencies. +;;; +;;; First and foremost, rewrite this code to use bit vectors of some sort. +;;; This will give big speedup and memory savings. +;;; +;;; - LET-OPTIONALS* macro. +;;; This is only used once. You can rewrite the use, port the hairy macro +;;; definition (which is implemented using a Clinger-Rees low-level +;;; explicit-renaming macro system), or port the simple, high-level +;;; definition, which is less efficient. +;;; +;;; - :OPTIONAL macro +;;; Very simply defined using an R5RS high-level macro. +;;; +;;; Implementations that can arrange for the base char sets to be immutable +;;; should do so. (E.g., Scheme 48 allows one to mark a string as immutable, +;;; which can be used to protect the underlying strings.) It would be very, +;;; very bad if a client's buggy code corrupted these constants. +;;; +;;; There is a fair amount of argument checking. This is, strictly speaking, +;;; unnecessary -- the actual body of the procedures will blow up if an +;;; illegal value is passed in. However, the error message will not be as good +;;; as if the error were caught at the "higher level." Also, a very, very +;;; smart Scheme compiler may be able to exploit having the type checks done +;;; early, so that the actual body of the procedures can assume proper values. +;;; This isn't likely; this kind of compiler technology isn't common any +;;; longer. +;;; +;;; The overhead of optional-argument parsing is irritating. The optional +;;; arguments must be consed into a rest list on entry, and then parsed out. +;;; Function call should be a matter of a few register moves and a jump; it +;;; should not involve heap allocation! Your Scheme system may have a superior +;;; non-R5RS optional-argument system that can eliminate this overhead. If so, +;;; then this is a prime candidate for optimising these procedures, +;;; *especially* the many optional BASE-CS parameters. +;;; +;;; Note that optional arguments are also a barrier to procedure integration. +;;; If your Scheme system permits you to specify alternate entry points +;;; for a call when the number of optional arguments is known in a manner +;;; that enables inlining/integration, this can provide performance +;;; improvements. +;;; +;;; There is enough *explicit* error checking that *all* internal operations +;;; should *never* produce a type or index-range error. Period. Feel like +;;; living dangerously? *Big* performance win to be had by replacing string +;;; and record-field accessors and setters with unsafe equivalents in the +;;; code. Similarly, fixnum-specific operators can speed up the arithmetic +;;; done on the index values in the inner loops. The only arguments that are +;;; not completely error checked are +;;; - string lists (complete checking requires time proportional to the +;;; length of the list) +;;; - procedure arguments, such as char->char maps & predicates. +;;; There is no way to check the range & domain of procedures in Scheme. +;;; Procedures that take these parameters cannot fully check their +;;; arguments. But all other types to all other procedures are fully +;;; checked. +;;; +;;; This does open up the alternate possibility of simply *removing* these +;;; checks, and letting the safe primitives raise the errors. On a dumb +;;; Scheme system, this would provide speed (by eliminating the redundant +;;; error checks) at the cost of error-message clarity. +;;; +;;; In an interpreted Scheme, some of these procedures, or the internal +;;; routines with % prefixes, are excellent candidates for being rewritten +;;; in C. +;;; +;;; It would also be nice to have the ability to mark some of these +;;; routines as candidates for inlining/integration. +;;; +;;; See the comments preceding the hash function code for notes on tuning +;;; the default bound so that the code never overflows your implementation's +;;; fixnum size into bignum calculation. +;;; +;;; All the %-prefixed routines in this source code are written +;;; to be called internally to this library. They do *not* perform +;;; friendly error checks on the inputs; they assume everything is +;;; proper. They also do not take optional arguments. These two properties +;;; save calling overhead and enable procedure integration -- but they +;;; are not appropriate for exported routines. + +;;; Copyright notice +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the Massachusetts +;;; Institute of Technology, Department of Electrical Engineering and +;;; Computer Science. Permission to copy and modify this software, to +;;; redistribute either the original software or a modified version, and +;;; to use this software for any purpose is granted, subject to the +;;; following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright notice +;;; in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions that +;;; they make, so that these may be included in future releases; and (b) +;;; to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the usual +;;; standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation of +;;; this software will be error-free, and MIT is under no obligation to +;;; provide any services, by way of maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this material, +;;; there shall be no use of the name of the Massachusetts Institute of +;;; Technology nor of any adaptation thereof in any advertising, +;;; promotional, or sales literature without prior written consent from +;;; MIT in each case. diff --git a/functional-tests/srfi/s19/srfi-19.scm b/functional-tests/srfi/s19/srfi-19.scm new file mode 100644 index 0000000..74bb344 --- /dev/null +++ b/functional-tests/srfi/s19/srfi-19.scm @@ -0,0 +1,1476 @@ +;; SRFI-19: Time Data Types and Procedures. +;; +;; Modified by Derick Eddington to be included into the (srfi :19 time) R6RS library. +;; TODO: For implementations which have threads, +;; the thread timing stuff can probably be made to work. +;; +;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved. +;; +;; This document and translations of it may be copied and furnished to others, +;; and derivative works that comment on or otherwise explain it or assist in its +;; implementation may be prepared, copied, published and distributed, in whole or +;; in part, without restriction of any kind, provided that the above copyright +;; notice and this paragraph are included on all such copies and derivative works. +;; However, this document itself may not be modified in any way, such as by +;; removing the copyright notice or references to the Scheme Request For +;; Implementation process or editors, except as needed for the purpose of +;; developing SRFIs in which case the procedures for copyrights defined in the SRFI +;; process must be followed, or as required to translate it into languages other +;; than English. +;; +;; The limited permissions granted above are perpetual and will not be revoked +;; by the authors or their successors or assigns. +;; +;; This document and the information contained herein is provided on an "AS IS" +;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE +;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF +;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. + + +;; -- Bug fixes. +;; +;; MAKE-TIME had parameters seconds and nanoseconds reversed; change all +;; references in file to match. Will F: 2002-10-15 +;; +;; DATE-YEAR-DAY returned the wrong day; tm:year-day fixed to do the right +;; thing. Will F: 2002-10-15 +;; It also called an undefined error procedure. +;; +;; DISPLAYING procedure removed. Will F: 2002-10-15. +;; +;; TM:NANO constant corrected. 2002-11-04. +;; +;; The following fixes by Will Fitzgerald, February, 2003. +;; -- Thanks to Steven Ma and others. +;; +;; (CURRENT-TIME 'TIME-THREAD) added. +;; +;; TIME-RESOLUTION for TIME-PROCESS added. +;; +;; TIME comparison procedures (time=?, etc. fixed. +;; +;; Corrected errors in converting between TAI and UTC time. +;; +;; TAI and UTC date converters no longer look at leap seconds, +;; which was an error. +;; +;; corrections to calls to tm:time-error +;; +;; timezone offset not used in date->time-utc and date->julian-day +;; +;; typos in tm:integer-reader-exact, tm:string->date, +;; time-monotonic->time-utc!, tm:char->int fixed +;; +;; corrected "~k", "~f" formatting for date->string (includes fix for +;; "~4" +;; +;; 'split-real' fixed. +;; +;; fixed julian-day->time-utc and variants. +;; +;; changes 2003-02-26, based on comments by Martin Gasbichler. +;; +;; moronic, overly complicated COPY-TIME procedure changed +;; to simple version suggested by Martin Gasbichler. +;; +;; To provide more portability, changed #\Space to #\space +;; and #\tab to #\Tab to (integer->char 9) +;; +;; changed arity-3 calls to / and - to arity 2 calls (again, +;; for more general portability). +;; +;; split-real fixed again -- by removing it, and using +;; 'fractional part'. Will Fitzgerald 5/16/2003. +;; -------------------------------------------------------------- + +(define-syntax receive + (syntax-rules () + ((receive formals expression body ...) + (call-with-values (lambda () expression) + (lambda formals body ...))))) + +;;; -- we want receive later on for a couple of small things +;; + +;; :OPTIONAL is nice, too + +(define-syntax :optional + (syntax-rules () + ((_ val default-value) + (if (null? val) default-value (car val))))) + +(define time-tai 'time-tai) +(define time-utc 'time-utc) +(define time-monotonic 'time-monotonic) +#|(define time-thread 'time-thread) +(define time-process 'time-process)|# +(define time-duration 'time-duration) + +;; example of extension (MZScheme specific) +;(define time-gc 'time-gc) + +;;-- LOCALE dependent constants + +(define tm:locale-number-separator ".") + +(define tm:locale-abbr-weekday-vector (vector "Sun" "Mon" "Tue" "Wed" + "Thu" "Fri" "Sat")) +(define tm:locale-long-weekday-vector (vector "Sunday" "Monday" + "Tuesday" "Wednesday" + "Thursday" "Friday" + "Saturday")) +;; note empty string in 0th place. +(define tm:locale-abbr-month-vector (vector "" "Jan" "Feb" "Mar" + "Apr" "May" "Jun" "Jul" + "Aug" "Sep" "Oct" "Nov" + "Dec")) +(define tm:locale-long-month-vector (vector "" "January" "February" + "March" "April" "May" + "June" "July" "August" + "September" "October" + "November" "December")) + +(define tm:locale-pm "PM") +(define tm:locale-am "AM") + +;; See date->string +(define tm:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y") +(define tm:locale-short-date-format "~m/~d/~y") +(define tm:locale-time-format "~H:~M:~S") +(define tm:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z") +;;-- Miscellaneous Constants. +;;-- only the tm:tai-epoch-in-jd might need changing if +;; a different epoch is used. + +(define tm:nano (expt 10 9)) +(define tm:sid 86400) ; seconds in a day +(define tm:sihd 43200) ; seconds in a half day +(define tm:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' + + +;;; A Very simple Error system for the time procedures +;;; +(define tm:time-error-types + '((invalid-clock-type . "invalid clock type") + (unsupported-clock-type . "unsupported clock type") + (incompatible-time-types . "incompatible time types") + (not-duration . "not duration") + (dates-are-immutable . "dates are immutable") + (bad-date-format-string . "bad date format string") + (bad-date-template-string . "bad date template string") + (invalid-month-specification . "invalid month specification") + )) + +(define (tm:time-error caller type value) + (cond + [(assoc type tm:time-error-types) + => + (lambda (p) + (if value + (error caller (cdr p) value) + (error caller (cdr p))))] + [else + (error caller "(library (srfi :19 time)) internal error: unsupported error type" type)])) + + +;; A table of leap seconds +;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat +;; and update as necessary. +;; this procedures reads the file in the abover +;; format and creates the leap second table +;; it also calls the almost standard, but not R5 procedures read-line +;; & open-input-string +;; ie (set! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat")) + +(define (tm:read-tai-utc-data filename) + (define (convert-jd jd) + (* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm:sid)) + (define (convert-sec sec) + (inexact->exact sec)) + (let ( (port (open-input-file filename)) + (table '()) ) + (let loop ((line (read-line port))) + (if (not (eq? line eof)) + (begin + (let* ( (data (read (open-input-string (string-append "(" line ")")))) + (year (car data)) + (jd (cadddr (cdr data))) + (secs (cadddr (cdddr data))) ) + (if (>= year 1972) + (set! table (cons (cons (convert-jd jd) (convert-sec secs)) table))) + (loop (read-line port)))))) + table)) + +;; each entry is ( utc seconds since epoch . # seconds to add for tai ) +;; note they go higher to lower, and end in 1972. +(define tm:leap-second-table + '((1136073600 . 33) + (915148800 . 32) + (867715200 . 31) + (820454400 . 30) + (773020800 . 29) + (741484800 . 28) + (709948800 . 27) + (662688000 . 26) + (631152000 . 25) + (567993600 . 24) + (489024000 . 23) + (425865600 . 22) + (394329600 . 21) + (362793600 . 20) + (315532800 . 19) + (283996800 . 18) + (252460800 . 17) + (220924800 . 16) + (189302400 . 15) + (157766400 . 14) + (126230400 . 13) + (94694400 . 12) + (78796800 . 11) + (63072000 . 10))) + +(define (read-leap-second-table filename) + (set! tm:leap-second-table (tm:read-tai-utc-data filename)) + (values)) + + +(define (tm:leap-second-delta utc-seconds) + (letrec ( (lsd (lambda (table) + (cond + ((>= utc-seconds (caar table)) + (cdar table)) + (else (lsd (cdr table)))))) ) + (if (< utc-seconds (* (- 1972 1970) 365 tm:sid)) 0 + (lsd tm:leap-second-table)))) + +;; going from tai seconds to utc seconds ... +(define (tm:leap-second-neg-delta tai-seconds) + (letrec ( (lsd (lambda (table) + (cond ((null? table) 0) + ((<= (cdar table) (- tai-seconds (caar table))) + (cdar table)) + (else (lsd (cdr table)))))) ) + (if (< tai-seconds (* (- 1972 1970) 365 tm:sid)) 0 + (lsd tm:leap-second-table)))) + + +;;; the time structure; creates the accessors, too. +;;; wf: changed to match srfi documentation. + +(define-record-type time + (fields + (mutable type) + (mutable nanosecond) + (mutable second))) + +;; thanks, Martin Gasbichler ... + +(define (copy-time time) + (make-time (time-type time) + (time-nanosecond time) ; original had this mistakenly swapped with time-second + (time-second time))) + + +;;; current-time + +;;; specific time getters. + +;; I'm not sure why the original was using time-nanoseconds +;; as 10000 * the milliseconds + +(define (tm:get-time-of-day) + (let ([ct (host:current-time)]) + (values (host:time-second ct) + (host:time-nanosecond ct)))) + +(define (tm:current-time-utc) + (receive (seconds nanos) (tm:get-time-of-day) + (make-time time-utc nanos seconds))) + +(define (tm:current-time-tai) + (receive (seconds nanos) (tm:get-time-of-day) + (make-time time-tai + nanos + (+ seconds (tm:leap-second-delta seconds)) ))) + +#|(define (tm:current-time-ms-time time-type proc) + (let ((current-ms (proc))) + (make-time time-type + XXX + ZZZ + ))) |# + +;; -- we define it to be the same as tai. +;; a different implemation of current-time-montonic +;; will require rewriting all of the time-monotonic converters, +;; of course. + +(define (tm:current-time-monotonic) + (receive (seconds nanos) (tm:get-time-of-day) + (make-time time-monotonic + nanos + (+ seconds (tm:leap-second-delta seconds)) ))) + + +#|(define (tm:current-time-thread) + (tm:current-time-ms-time time-process current-process-milliseconds)) + +(define (tm:current-time-process) + (tm:current-time-ms-time time-process current-process-milliseconds)) + +(define (tm:current-time-gc) + (tm:current-time-ms-time time-gc current-gc-milliseconds)) |# + +(define (current-time . clock-type) + (let ( (clock-type (:optional clock-type time-utc)) ) + (cond + ((eq? clock-type time-tai) (tm:current-time-tai)) + ((eq? clock-type time-utc) (tm:current-time-utc)) + ((eq? clock-type time-monotonic) (tm:current-time-monotonic)) + #|((eq? clock-type time-thread) (tm:current-time-thread)) + ((eq? clock-type time-process) (tm:current-time-process)) + ((eq? clock-type time-gc) (tm:current-time-gc))|# + (else (tm:time-error 'current-time 'invalid-clock-type clock-type))))) + + +;; -- time resolution +;; this is the resolution of the clock in nanoseconds. +;; this will be implementation specific. +(define (time-resolution . clock-type) + (let ((clock-type (:optional clock-type time-utc))) + (cond + ((eq? clock-type time-tai) host:time-resolution) + ((eq? clock-type time-utc) host:time-resolution) + ((eq? clock-type time-monotonic) host:time-resolution) + #|((eq? clock-type time-thread) host:time-resolution) + ((eq? clock-type time-process) host:time-resolution) + ((eq? clock-type time-gc) host:time-resolution)|# + (else (tm:time-error 'time-resolution 'invalid-clock-type clock-type))))) + +;; -- time comparisons + +(define (tm:time-compare-check time1 time2 caller) + (if (or (not (and (time? time1) (time? time2))) + (not (eq? (time-type time1) (time-type time2)))) + (tm:time-error caller 'incompatible-time-types #f) + #t)) + +(define (time=? time1 time2) + (tm:time-compare-check time1 time2 'time=?) + (and (= (time-second time1) (time-second time2)) + (= (time-nanosecond time1) (time-nanosecond time2)))) + +(define (time>? time1 time2) + (tm:time-compare-check time1 time2 'time>?) + (or (> (time-second time1) (time-second time2)) + (and (= (time-second time1) (time-second time2)) + (> (time-nanosecond time1) (time-nanosecond time2))))) + +(define (time=? time1 time2) + (tm:time-compare-check time1 time2 'time>=?) + (or (>= (time-second time1) (time-second time2)) + (and (= (time-second time1) (time-second time2)) + (>= (time-nanosecond time1) (time-nanosecond time2))))) + +(define (time<=? time1 time2) + (tm:time-compare-check time1 time2 'time<=?) + (or (<= (time-second time1) (time-second time2)) + (and (= (time-second time1) (time-second time2)) + (<= (time-nanosecond time1) (time-nanosecond time2))))) + +;; -- time arithmetic + +(define (tm:time->nanoseconds time) + #|(define (sign1 n) ; must be code rot + (if (negative? n) -1 1))|# + (+ (* (time-second time) tm:nano) + (time-nanosecond time))) + +(define (tm:nanoseconds->time time-type nanoseconds) + (make-time time-type + (remainder nanoseconds tm:nano) + (quotient nanoseconds tm:nano))) + +(define (tm:nanoseconds->values nanoseconds) + (div-and-mod nanoseconds tm:nano)) + +(define (tm:time-difference time1 time2 time3) + (if (or (not (and (time? time1) (time? time2))) + (not (eq? (time-type time1) (time-type time2)))) + (tm:time-error 'time-difference 'incompatible-time-types #f)) + (time-type-set! time3 time-duration) + (if (time=? time1 time2) + (begin + (time-second-set! time3 0) + (time-nanosecond-set! time3 0)) + (receive + (secs nanos) + (tm:nanoseconds->values (- (tm:time->nanoseconds time1) + (tm:time->nanoseconds time2))) + (time-second-set! time3 secs) + (time-nanosecond-set! time3 nanos))) + time3) + +(define (time-difference time1 time2) + (tm:time-difference time1 time2 (make-time #f #f #f))) + +(define (time-difference! time1 time2) + (tm:time-difference time1 time2 time1)) + +(define (tm:add-duration time1 duration time3) + (if (not (and (time? time1) (time? duration))) + (tm:time-error 'add-duration 'incompatible-time-types #f)) + (if (not (eq? (time-type duration) time-duration)) + (tm:time-error 'add-duration 'not-duration duration) + (let ( (sec-plus (+ (time-second time1) (time-second duration))) + (nsec-plus (+ (time-nanosecond time1) (time-nanosecond duration))) ) + (let ((r (remainder nsec-plus tm:nano)) + (q (quotient nsec-plus tm:nano))) + ; (time-type-set! time3 (time-type time1)) + (if (negative? r) + (begin + (time-second-set! time3 (+ sec-plus q -1)) + (time-nanosecond-set! time3 (+ tm:nano r))) + (begin + (time-second-set! time3 (+ sec-plus q)) + (time-nanosecond-set! time3 r))) + time3)))) + +(define (add-duration time1 duration) + (tm:add-duration time1 duration (make-time (time-type time1) #f #f))) + +(define (add-duration! time1 duration) + (tm:add-duration time1 duration time1)) + +(define (tm:subtract-duration time1 duration time3) + (if (not (and (time? time1) (time? duration))) + (tm:time-error 'add-duration 'incompatible-time-types #f)) + (if (not (eq? (time-type duration) time-duration)) + (tm:time-error 'tm:subtract-duration 'not-duration duration) + (let ( (sec-minus (- (time-second time1) (time-second duration))) + (nsec-minus (- (time-nanosecond time1) (time-nanosecond duration))) ) + (let ((r (remainder nsec-minus tm:nano)) + (q (quotient nsec-minus tm:nano))) + (if (negative? r) + (begin + (time-second-set! time3 (- sec-minus q 1)) + (time-nanosecond-set! time3 (+ tm:nano r))) + (begin + (time-second-set! time3 (- sec-minus q)) + (time-nanosecond-set! time3 r))) + time3)))) + +(define (subtract-duration time1 duration) + (tm:subtract-duration time1 duration (make-time (time-type time1) #f #f))) + +(define (subtract-duration! time1 duration) + (tm:subtract-duration time1 duration time1)) + + +;; -- converters between types. + +(define (tm:time-tai->time-utc! time-in time-out caller) + (if (not (eq? (time-type time-in) time-tai)) + (tm:time-error caller 'incompatible-time-types time-in)) + (time-type-set! time-out time-utc) + (time-nanosecond-set! time-out (time-nanosecond time-in)) + (time-second-set! time-out (- (time-second time-in) + (tm:leap-second-neg-delta + (time-second time-in)))) + time-out) + +(define (time-tai->time-utc time-in) + (tm:time-tai->time-utc! time-in (make-time #f #f #f) 'time-tai->time-utc)) + + +(define (time-tai->time-utc! time-in) + (tm:time-tai->time-utc! time-in time-in 'time-tai->time-utc!)) + + +(define (tm:time-utc->time-tai! time-in time-out caller) + (if (not (eq? (time-type time-in) time-utc)) + (tm:time-error caller 'incompatible-time-types time-in)) + (time-type-set! time-out time-tai) + (time-nanosecond-set! time-out (time-nanosecond time-in)) + (time-second-set! time-out (+ (time-second time-in) + (tm:leap-second-delta + (time-second time-in)))) + time-out) + + +(define (time-utc->time-tai time-in) + (tm:time-utc->time-tai! time-in (make-time #f #f #f) 'time-utc->time-tai)) + +(define (time-utc->time-tai! time-in) + (tm:time-utc->time-tai! time-in time-in 'time-utc->time-tai!)) + +;; -- these depend on time-monotonic having the same definition as time-tai! +(define (time-monotonic->time-utc time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (tm:time-error 'time-monotoinc->time-utc 'incompatible-time-types time-in)) + (let ((ntime (copy-time time-in))) + (time-type-set! ntime time-tai) + (tm:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) + +(define (time-monotonic->time-utc! time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (tm:time-error 'time-monotonic->time-utc! 'incompatible-time-types time-in)) + (time-type-set! time-in time-tai) + (tm:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc)) + +(define (time-monotonic->time-tai time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (tm:time-error 'time-monotonic->time-tai 'incompatible-time-types time-in)) + (let ((ntime (copy-time time-in))) + (time-type-set! ntime time-tai) + ntime)) + +(define (time-monotonic->time-tai! time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (tm:time-error 'time-monotonic->time-tai! 'incompatible-time-types time-in)) + (time-type-set! time-in time-tai) + time-in) + +(define (time-utc->time-monotonic time-in) + (if (not (eq? (time-type time-in) time-utc)) + (tm:time-error 'time-utc->time-monotonic 'incompatible-time-types time-in)) + (let ((ntime (tm:time-utc->time-tai! time-in (make-time #f #f #f) + 'time-utc->time-monotonic))) + (time-type-set! ntime time-monotonic) + ntime)) + + +(define (time-utc->time-monotonic! time-in) + (if (not (eq? (time-type time-in) time-utc)) + (tm:time-error 'time-utc->time-montonic! 'incompatible-time-types time-in)) + (let ((ntime (tm:time-utc->time-tai! time-in time-in + 'time-utc->time-monotonic!))) + (time-type-set! ntime time-monotonic) + ntime)) + + +(define (time-tai->time-monotonic time-in) + (if (not (eq? (time-type time-in) time-tai)) + (tm:time-error 'time-tai->time-monotonic 'incompatible-time-types time-in)) + (let ((ntime (copy-time time-in))) + (time-type-set! ntime time-monotonic) + ntime)) + +(define (time-tai->time-monotonic! time-in) + (if (not (eq? (time-type time-in) time-tai)) + (tm:time-error 'time-tai->time-monotonic! 'incompatible-time-types time-in)) + (time-type-set! time-in time-monotonic) + time-in) + + +;; -- date structures + +(define-record-type date + (fields + (mutable nanosecond) + (mutable second) + (mutable minute) + (mutable hour) + (mutable day) + (mutable month) + (mutable year) + (mutable zone-offset))) + +;; redefine setters (in Ikarus version, only to keep names the same in below code) +(define tm:set-date-nanosecond! date-nanosecond-set!) +(define tm:set-date-second! date-second-set!) +(define tm:set-date-minute! date-minute-set!) +(define tm:set-date-hour! date-hour-set!) +(define tm:set-date-day! date-day-set!) +(define tm:set-date-month! date-month-set!) +(define tm:set-date-year! date-year-set!) +(define tm:set-date-zone-offset! date-zone-offset-set!) + +;; gives the julian day which starts at noon. +(define (tm:encode-julian-day-number day month year) + (let* ((a (quotient (- 14 month) 12)) + (y (- (- (+ year 4800) a) (if (negative? year) -1 0))) + (m (- (+ month (* 12 a)) 3))) + (+ day + (quotient (+ (* 153 m) 2) 5) + (* 365 y) + (quotient y 4) + (- (quotient y 100)) + (quotient y 400) + -32045))) + +(define (tm:char-pos char str index len) + (cond + ((>= index len) #f) + ((char=? (string-ref str index) char) + index) + (else + (tm:char-pos char str (+ index 1) len)))) + + +(define (tm:fractional-part r) + (if (integer? r) "0" + (let ((str (number->string (exact->inexact r)))) + (let ((ppos (tm:char-pos #\. str 0 (string-length str)))) + (substring str (+ ppos 1) (string-length str)))))) + + +;; gives the seconds/date/month/year +(define (tm:decode-julian-day-number jdn) + (let* ((days (truncate jdn)) + (a (+ days 32044)) + (b (quotient (+ (* 4 a) 3) 146097)) + (c (- a (quotient (* 146097 b) 4))) + (d (quotient (+ (* 4 c) 3) 1461)) + (e (- c (quotient (* 1461 d) 4))) + (m (quotient (+ (* 5 e) 2) 153)) + (y (+ (* 100 b) d -4800 (quotient m 10)))) + (values ; seconds date month year + (* (- jdn days) tm:sid) + (+ e (- (quotient (+ (* 153 m) 2) 5)) 1) + (+ m 3 (* -12 (quotient m 10))) + (if (>= 0 y) (- y 1) y)) + )) + + +(define (tm:local-tz-offset) + (host:time-gmt-offset (host:current-time))) + +;; special thing -- ignores nanos +(define (tm:time->julian-day-number seconds tz-offset) + (+ (/ (+ seconds + tz-offset + tm:sihd) + tm:sid) + tm:tai-epoch-in-jd)) + +(define (tm:find proc l) + (if (null? l) + #f + (if (proc (car l)) + #t + (tm:find proc (cdr l))))) + +(define (tm:tai-before-leap-second? second) + (tm:find (lambda (x) + (= second (- (+ (car x) (cdr x)) 1))) + tm:leap-second-table)) + +(define (tm:time->date time tz-offset ttype) + (if (not (eq? (time-type time) ttype)) + (tm:time-error 'time->date 'incompatible-time-types time)) + (let* ( (offset (:optional tz-offset (tm:local-tz-offset))) ) + (receive (secs date month year) + (tm:decode-julian-day-number + (tm:time->julian-day-number (time-second time) offset)) + (let* ( (hours (quotient secs (* 60 60))) + (rem (remainder secs (* 60 60))) + (minutes (quotient rem 60)) + (seconds (remainder rem 60)) ) + (make-date (time-nanosecond time) + seconds + minutes + hours + date + month + year + offset))))) + +(define (time-tai->date time . tz-offset) + (if (tm:tai-before-leap-second? (time-second time)) + ;; if it's *right* before the leap, we need to pretend to subtract a second ... + (let ((d (tm:time->date (subtract-duration! (time-tai->time-utc time) (make-time time-duration 0 1)) tz-offset time-utc))) + (tm:set-date-second! d 60) + d) + (tm:time->date (time-tai->time-utc time) tz-offset time-utc))) + +(define (time-utc->date time . tz-offset) + (tm:time->date time tz-offset time-utc)) + +;; again, time-monotonic is the same as time tai +(define (time-monotonic->date time . tz-offset) + (tm:time->date time tz-offset time-monotonic)) + +(define (date->time-utc date) + (let ( (nanosecond (date-nanosecond date)) + (second (date-second date)) + (minute (date-minute date)) + (hour (date-hour date)) + (day (date-day date)) + (month (date-month date)) + (year (date-year date)) + (offset (date-zone-offset date)) ) + (let ( (jdays (- (tm:encode-julian-day-number day month year) + tm:tai-epoch-in-jd)) ) + (make-time + time-utc + nanosecond + (+ (* (- jdays 1/2) 24 60 60) + (* hour 60 60) + (* minute 60) + second + (- offset)) + )))) + +(define (date->time-tai d) + (if (= (date-second d) 60) + (subtract-duration! (time-utc->time-tai! (date->time-utc d)) (make-time time-duration 0 1)) + (time-utc->time-tai! (date->time-utc d)))) + +(define (date->time-monotonic date) + (time-utc->time-monotonic! (date->time-utc date))) + + +(define (tm:leap-year? year) + (or (= (modulo year 400) 0) + (and (= (modulo year 4) 0) (not (= (modulo year 100) 0))))) + +(define (leap-year? date) + (tm:leap-year? (date-year date))) + +;; tm:year-day fixed: adding wrong number of days. +(define tm:month-assoc '((0 . 0) (1 . 31) (2 . 59) (3 . 90) (4 . 120) + (5 . 151) (6 . 181) (7 . 212) (8 . 243) + (9 . 273) (10 . 304) (11 . 334))) + +(define (tm:year-day day month year) + (let ((days-pr (assoc (- month 1) tm:month-assoc))) + (if (not days-pr) + (tm:time-error 'date-year-day 'invalid-month-specification month)) + (if (and (tm:leap-year? year) (> month 2)) + (+ day (cdr days-pr) 1) + (+ day (cdr days-pr))))) + +(define (date-year-day date) + (tm:year-day (date-day date) (date-month date) (date-year date))) + +;; from calendar faq +(define (tm:week-day day month year) + (let* ((a (quotient (- 14 month) 12)) + (y (- year a)) + (m (+ month (* 12 a) -2))) + (modulo (+ day y (quotient y 4) (- (quotient y 100)) + (quotient y 400) (quotient (* 31 m) 12)) + 7))) + +(define (date-week-day date) + (tm:week-day (date-day date) (date-month date) (date-year date))) + +(define (tm:days-before-first-week date day-of-week-starting-week) + (let* ( (first-day (make-date 0 0 0 0 + 1 + 1 + (date-year date) + #f)) + (fdweek-day (date-week-day first-day)) ) + (modulo (- day-of-week-starting-week fdweek-day) + 7))) + +(define (date-week-number date day-of-week-starting-week) + (quotient (- (date-year-day date) + (tm:days-before-first-week date day-of-week-starting-week)) + 7)) + +(define (current-date . tz-offset) + (time-utc->date (current-time time-utc) + (:optional tz-offset (tm:local-tz-offset)))) + +;; given a 'two digit' number, find the year within 50 years +/- +(define (tm:natural-year n) + (let* ( (current-year (date-year (current-date))) + (current-century (* (quotient current-year 100) 100)) ) + (cond + ((>= n 100) n) + ((< n 0) n) + ((<= (- (+ current-century n) current-year) 50) + (+ current-century n)) + (else + (+ (- current-century 100) n))))) + +(define (date->julian-day date) + (let ( (nanosecond (date-nanosecond date)) + (second (date-second date)) + (minute (date-minute date)) + (hour (date-hour date)) + (day (date-day date)) + (month (date-month date)) + (year (date-year date)) + (offset (date-zone-offset date)) ) + (+ (tm:encode-julian-day-number day month year) + (- 1/2) + (+ (/ (+ (* hour 60 60) + (* minute 60) + second + (/ nanosecond tm:nano) + (- offset)) + tm:sid))))) + +(define (date->modified-julian-day date) + (- (date->julian-day date) + 4800001/2)) + + +(define (time-utc->julian-day time) + (if (not (eq? (time-type time) time-utc)) + (tm:time-error 'time-utc->julian-day 'incompatible-time-types time)) + (+ (/ (+ (time-second time) (/ (time-nanosecond time) tm:nano)) + tm:sid) + tm:tai-epoch-in-jd)) + +(define (time-utc->modified-julian-day time) + (- (time-utc->julian-day time) + 4800001/2)) + +(define (time-tai->julian-day time) + (if (not (eq? (time-type time) time-tai)) + (tm:time-error 'time-tai->julian-day 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (tm:leap-second-delta (time-second time))) + (/ (time-nanosecond time) tm:nano)) + tm:sid) + tm:tai-epoch-in-jd)) + +(define (time-tai->modified-julian-day time) + (- (time-tai->julian-day time) + 4800001/2)) + +;; this is the same as time-tai->julian-day +(define (time-monotonic->julian-day time) + (if (not (eq? (time-type time) time-monotonic)) + (tm:time-error 'time-monotonic->julian-day 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (tm:leap-second-delta (time-second time))) + (/ (time-nanosecond time) tm:nano)) + tm:sid) + tm:tai-epoch-in-jd)) + + +(define (time-monotonic->modified-julian-day time) + (- (time-monotonic->julian-day time) + 4800001/2)) + + +(define (julian-day->time-utc jdn) + (let ( (nanosecs (* tm:nano tm:sid (- jdn tm:tai-epoch-in-jd))) ) + (make-time time-utc + (remainder nanosecs tm:nano) + (floor (/ nanosecs tm:nano))))) + +(define (julian-day->time-tai jdn) + (time-utc->time-tai! (julian-day->time-utc jdn))) + +(define (julian-day->time-monotonic jdn) + (time-utc->time-monotonic! (julian-day->time-utc jdn))) + +(define (julian-day->date jdn . tz-offset) + (let ((offset (:optional tz-offset (tm:local-tz-offset)))) + (time-utc->date (julian-day->time-utc jdn) offset))) + +(define (modified-julian-day->date jdn . tz-offset) + (let ((offset (:optional tz-offset (tm:local-tz-offset)))) + (julian-day->date (+ jdn 4800001/2) offset))) + +(define (modified-julian-day->time-utc jdn) + (julian-day->time-utc (+ jdn 4800001/2))) + +(define (modified-julian-day->time-tai jdn) + (julian-day->time-tai (+ jdn 4800001/2))) + +(define (modified-julian-day->time-monotonic jdn) + (julian-day->time-monotonic (+ jdn 4800001/2))) + +(define (current-julian-day) + (time-utc->julian-day (current-time time-utc))) + +(define (current-modified-julian-day) + (time-utc->modified-julian-day (current-time time-utc))) + +;; returns a string rep. of number N, of minimum LENGTH, +;; padded with character PAD-WITH. If PAD-WITH if #f, +;; no padding is done, and it's as if number->string was used. +;; if string is longer than LENGTH, it's as if number->string was used. + +(define (tm:padding n pad-with length) + (let* ( (str (number->string n)) + (str-len (string-length str)) ) + (if (or (> str-len length) + (not pad-with)) + str + (let* ( (new-str (make-string length pad-with)) + (new-str-offset (- (string-length new-str) + str-len)) ) + (do ((i 0 (+ i 1))) + ((>= i (string-length str))) + (string-set! new-str (+ new-str-offset i) + (string-ref str i))) + new-str)))) + +(define (tm:last-n-digits i n) + (abs (remainder i (expt 10 n)))) + +(define (tm:locale-abbr-weekday n) + (vector-ref tm:locale-abbr-weekday-vector n)) + +(define (tm:locale-long-weekday n) + (vector-ref tm:locale-long-weekday-vector n)) + +(define (tm:locale-abbr-month n) + (vector-ref tm:locale-abbr-month-vector n)) + +(define (tm:locale-long-month n) + (vector-ref tm:locale-long-month-vector n)) + +(define (tm:vector-find needle haystack comparator) + (let ((len (vector-length haystack))) + (define (tm:vector-find-int index) + (cond + ((>= index len) #f) + ((comparator needle (vector-ref haystack index)) index) + (else (tm:vector-find-int (+ index 1))))) + (tm:vector-find-int 0))) + +(define (tm:locale-abbr-weekday->index string) + (tm:vector-find string tm:locale-abbr-weekday-vector string=?)) + +(define (tm:locale-long-weekday->index string) + (tm:vector-find string tm:locale-long-weekday-vector string=?)) + +(define (tm:locale-abbr-month->index string) + (tm:vector-find string tm:locale-abbr-month-vector string=?)) + +(define (tm:locale-long-month->index string) + (tm:vector-find string tm:locale-long-month-vector string=?)) + + + +;; do nothing. +;; Your implementation might want to do something... +;; +(define (tm:locale-print-time-zone date port) + (values)) + +;; Again, locale specific. +(define (tm:locale-am/pm hr) + (if (> hr 11) tm:locale-pm tm:locale-am)) + +(define (tm:tz-printer offset port) + (cond + ((= offset 0) (display "Z" port)) + ((negative? offset) (display "-" port)) + (else (display "+" port))) + (if (not (= offset 0)) + (let ( (hours (abs (quotient offset (* 60 60)))) + (minutes (abs (quotient (remainder offset (* 60 60)) 60))) ) + (display (tm:padding hours #\0 2) port) + (display (tm:padding minutes #\0 2) port)))) + +;; A table of output formatting directives. +;; the first time is the format char. +;; the second is a procedure that takes the date, a padding character +;; (which might be #f), and the output port. +;; +(define tm:directives + (list + (cons #\~ (lambda (date pad-with port) (display #\~ port))) + + (cons #\a (lambda (date pad-with port) + (display (tm:locale-abbr-weekday (date-week-day date)) + port))) + (cons #\A (lambda (date pad-with port) + (display (tm:locale-long-weekday (date-week-day date)) + port))) + (cons #\b (lambda (date pad-with port) + (display (tm:locale-abbr-month (date-month date)) + port))) + (cons #\B (lambda (date pad-with port) + (display (tm:locale-long-month (date-month date)) + port))) + (cons #\c (lambda (date pad-with port) + (display (date->string date tm:locale-date-time-format) port))) + (cons #\d (lambda (date pad-with port) + (display (tm:padding (date-day date) + #\0 2) + port))) + (cons #\D (lambda (date pad-with port) + (display (date->string date "~m/~d/~y") port))) + (cons #\e (lambda (date pad-with port) + (display (tm:padding (date-day date) + #\space 2) + port))) + (cons #\f (lambda (date pad-with port) + (if (> (date-nanosecond date) + tm:nano) + (display (tm:padding (+ (date-second date) 1) + pad-with 2) + port) + (display (tm:padding (date-second date) + pad-with 2) + port)) + (let* ((ns (tm:fractional-part (/ + (date-nanosecond date) + tm:nano 1.0))) + (le (string-length ns))) + (if (> le 2) + (begin + (display tm:locale-number-separator port) + (display (substring ns 2 le) port)))))) + (cons #\h (lambda (date pad-with port) + (display (date->string date "~b") port))) + (cons #\H (lambda (date pad-with port) + (display (tm:padding (date-hour date) + pad-with 2) + port))) + (cons #\I (lambda (date pad-with port) + (let ((hr (date-hour date))) + (if (> hr 12) + (display (tm:padding (- hr 12) + pad-with 2) + port) + (display (tm:padding hr + pad-with 2) + port))))) + (cons #\j (lambda (date pad-with port) + (display (tm:padding (date-year-day date) + pad-with 3) + port))) + (cons #\k (lambda (date pad-with port) + (display (tm:padding (date-hour date) + #\0 2) + port))) + (cons #\l (lambda (date pad-with port) + (let ((hr (if (> (date-hour date) 12) + (- (date-hour date) 12) (date-hour date)))) + (display (tm:padding hr #\space 2) + port)))) + (cons #\m (lambda (date pad-with port) + (display (tm:padding (date-month date) + pad-with 2) + port))) + (cons #\M (lambda (date pad-with port) + (display (tm:padding (date-minute date) + pad-with 2) + port))) + (cons #\n (lambda (date pad-with port) + (newline port))) + (cons #\N (lambda (date pad-with port) + (display (tm:padding (date-nanosecond date) + pad-with 9) + port))) + (cons #\p (lambda (date pad-with port) + (display (tm:locale-am/pm (date-hour date)) port))) + (cons #\r (lambda (date pad-with port) + (display (date->string date "~I:~M:~S ~p") port))) + (cons #\s (lambda (date pad-with port) + (display (time-second (date->time-utc date)) port))) + (cons #\S (lambda (date pad-with port) + (if (> (date-nanosecond date) + tm:nano) + (display (tm:padding (+ (date-second date) 1) + pad-with 2) + port) + (display (tm:padding (date-second date) + pad-with 2) + port)))) + (cons #\t (lambda (date pad-with port) + (display (integer->char 9) port))) + (cons #\T (lambda (date pad-with port) + (display (date->string date "~H:~M:~S") port))) + (cons #\U (lambda (date pad-with port) + (if (> (tm:days-before-first-week date 0) 0) + (display (tm:padding (+ (date-week-number date 0) 1) + #\0 2) port) + (display (tm:padding (date-week-number date 0) + #\0 2) port)))) + (cons #\V (lambda (date pad-with port) + (display (tm:padding (date-week-number date 1) + #\0 2) port))) + (cons #\w (lambda (date pad-with port) + (display (date-week-day date) port))) + (cons #\x (lambda (date pad-with port) + (display (date->string date tm:locale-short-date-format) port))) + (cons #\X (lambda (date pad-with port) + (display (date->string date tm:locale-time-format) port))) + (cons #\W (lambda (date pad-with port) + (if (> (tm:days-before-first-week date 1) 0) + (display (tm:padding (+ (date-week-number date 1) 1) + #\0 2) port) + (display (tm:padding (date-week-number date 1) + #\0 2) port)))) + (cons #\y (lambda (date pad-with port) + (display (tm:padding (tm:last-n-digits + (date-year date) 2) + pad-with + 2) + port))) + (cons #\Y (lambda (date pad-with port) + (display (date-year date) port))) + (cons #\z (lambda (date pad-with port) + (tm:tz-printer (date-zone-offset date) port))) + (cons #\Z (lambda (date pad-with port) + (tm:locale-print-time-zone date port))) + (cons #\1 (lambda (date pad-with port) + (display (date->string date "~Y-~m-~d") port))) + (cons #\2 (lambda (date pad-with port) + (display (date->string date "~k:~M:~S~z") port))) + (cons #\3 (lambda (date pad-with port) + (display (date->string date "~k:~M:~S") port))) + (cons #\4 (lambda (date pad-with port) + (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port))) + (cons #\5 (lambda (date pad-with port) + (display (date->string date "~Y-~m-~dT~k:~M:~S") port))) + )) + + +(define (tm:get-formatter char) + (let ( (associated (assoc char tm:directives)) ) + (if associated (cdr associated) #f))) + +(define (tm:date-printer date index format-string str-len port) + (if (>= index str-len) + (values) + (let ( (current-char (string-ref format-string index)) ) + (if (not (char=? current-char #\~)) + (begin + (display current-char port) + (tm:date-printer date (+ index 1) format-string str-len port)) + + (if (= (+ index 1) str-len) ; bad format string. + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (let ( (pad-char? (string-ref format-string (+ index 1))) ) + (cond + ((char=? pad-char? #\-) + (if (= (+ index 2) str-len) ; bad format string. + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (let ( (formatter (tm:get-formatter + (string-ref format-string + (+ index 2)))) ) + (if (not formatter) + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (begin + (formatter date #f port) + (tm:date-printer date (+ index 3) + format-string str-len port)))))) + + ((char=? pad-char? #\_) + (if (= (+ index 2) str-len) ; bad format string. + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (let ( (formatter (tm:get-formatter + (string-ref format-string + (+ index 2)))) ) + (if (not formatter) + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (begin + (formatter date #\space port) + (tm:date-printer date (+ index 3) + format-string str-len port)))))) + (else + (let ( (formatter (tm:get-formatter + (string-ref format-string + (+ index 1)))) ) + (if (not formatter) + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (begin + (formatter date #\0 port) + (tm:date-printer date (+ index 2) + format-string str-len port)))))))))))) + + +(define (date->string date . format-string) + (let ( (str-port (open-output-string)) + (fmt-str (:optional format-string "~c")) ) + (tm:date-printer date 0 fmt-str (string-length fmt-str) str-port) + (get-output-string str-port))) + +(define (tm:char->int ch) + (cond + ((char=? ch #\0) 0) + ((char=? ch #\1) 1) + ((char=? ch #\2) 2) + ((char=? ch #\3) 3) + ((char=? ch #\4) 4) + ((char=? ch #\5) 5) + ((char=? ch #\6) 6) + ((char=? ch #\7) 7) + ((char=? ch #\8) 8) + ((char=? ch #\9) 9) + (else (tm:time-error 'string->date 'bad-date-template-string + (list "Non-integer character" ch ))))) + +;; read an integer upto n characters long on port; upto -> #f if any length +(define (tm:integer-reader upto port) + (define (accum-int port accum nchars) + (let ((ch (peek-char port))) + (if (or (eof-object? ch) + (not (char-numeric? ch)) + (and upto (>= nchars upto ))) + accum + (accum-int port (+ (* accum 10) (tm:char->int (read-char + port))) (+ + nchars 1))))) + (accum-int port 0 0)) + +(define (tm:make-integer-reader upto) + (lambda (port) + (tm:integer-reader upto port))) + +;; read an fractional integer upto n characters long on port; upto -> #f if any length +;; +;; The return value is normalized to upto decimal places. For example, if upto is 9 and +;; the string read is "123", the return value is 123000000. +(define (tm:fractional-integer-reader upto port) + (define (accum-int port accum nchars) + (let ((ch (peek-char port))) + (if (or (eof-object? ch) + (not (char-numeric? ch)) + (and upto (>= nchars upto ))) + (* accum (expt 10 (- upto nchars))) + (accum-int port (+ (* accum 10) (tm:char->int (read-char port))) (+ nchars 1))))) + (accum-int port 0 0)) + +(define (tm:make-fractional-integer-reader upto) + (lambda (port) + (tm:fractional-integer-reader upto port))) + + +;; read *exactly* n characters and convert to integer; could be padded +(define (tm:integer-reader-exact n port) + (let ( (padding-ok #t) ) + (define (accum-int port accum nchars) + (let ((ch (peek-char port))) + (cond + ((>= nchars n) accum) + ((eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + "Premature ending to integer read.")) + ((char-numeric? ch) + (set! padding-ok #f) + (accum-int port (+ (* accum 10) (tm:char->int (read-char + port))) + (+ nchars 1))) + (padding-ok + (read-char port) ; consume padding + (accum-int port accum (+ nchars 1))) + (else ; padding where it shouldn't be + (tm:time-error 'string->date 'bad-date-template-string + "Non-numeric characters in integer read."))))) + (accum-int port 0 0))) + + +(define (tm:make-integer-exact-reader n) + (lambda (port) + (tm:integer-reader-exact n port))) + +(define (tm:zone-reader port) + (let ( (offset 0) + (positive? #f) ) + (let ( (ch (read-char port)) ) + (if (eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone +/-" ch))) + (if (or (char=? ch #\Z) (char=? ch #\z)) + 0 + (begin + (cond + ((char=? ch #\+) (set! positive? #t)) + ((char=? ch #\-) (set! positive? #f)) + (else + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone +/-" ch)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (* (tm:char->int ch) + 10 60 60))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (tm:char->int ch) + 60 60)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (tm:char->int ch) + 10 60)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (tm:char->int ch) + 60)))) + (if positive? offset (- offset))))))) + +;; looking at a char, read the char string, run thru indexer, return index +(define (tm:locale-reader port indexer) + (let ( (string-port (open-output-string)) ) + (define (read-char-string) + (let ((ch (peek-char port))) + (if (char-alphabetic? ch) + (begin (write-char (read-char port) string-port) + (read-char-string)) + (get-output-string string-port)))) + (let* ( (str (read-char-string)) + (index (indexer str)) ) + (if index index (tm:time-error 'string->date + 'bad-date-template-string + (list "Invalid string for " indexer)))))) + +(define (tm:make-locale-reader indexer) + (lambda (port) + (tm:locale-reader port indexer))) + +(define (tm:make-char-id-reader char) + (lambda (port) + (if (char=? char (read-char port)) + char + (tm:time-error 'string->date + 'bad-date-template-string + "Invalid character match.")))) + +;; A List of formatted read directives. +;; Each entry is a list. +;; 1. the character directive; +;; a procedure, which takes a character as input & returns +;; 2. #t as soon as a character on the input port is acceptable +;; for input, +;; 3. a port reader procedure that knows how to read the current port +;; for a value. Its one parameter is the port. +;; 4. a action procedure, that takes the value (from 3.) and some +;; object (here, always the date) and (probably) side-effects it. +;; In some cases (e.g., ~A) the action is to do nothing + +(define tm:read-directives + (let ( (ireader4 (tm:make-integer-reader 4)) + (ireader2 (tm:make-integer-reader 2)) + (fireader9 (tm:make-fractional-integer-reader 9)) + (ireaderf (tm:make-integer-reader #f)) + (eireader2 (tm:make-integer-exact-reader 2)) + (eireader4 (tm:make-integer-exact-reader 4)) + (locale-reader-abbr-weekday (tm:make-locale-reader + tm:locale-abbr-weekday->index)) + (locale-reader-long-weekday (tm:make-locale-reader + tm:locale-long-weekday->index)) + (locale-reader-abbr-month (tm:make-locale-reader + tm:locale-abbr-month->index)) + (locale-reader-long-month (tm:make-locale-reader + tm:locale-long-month->index)) + (char-fail (lambda (ch) #t)) + (do-nothing (lambda (val object) (values))) + ) + + (list + (list #\~ char-fail (tm:make-char-id-reader #\~) do-nothing) + (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing) + (list #\A char-alphabetic? locale-reader-long-weekday do-nothing) + (list #\b char-alphabetic? locale-reader-abbr-month + (lambda (val object) + (tm:set-date-month! object val))) + (list #\B char-alphabetic? locale-reader-long-month + (lambda (val object) + (tm:set-date-month! object val))) + (list #\d char-numeric? ireader2 (lambda (val object) + (tm:set-date-day! + object val))) + (list #\e char-fail eireader2 (lambda (val object) + (tm:set-date-day! object val))) + (list #\h char-alphabetic? locale-reader-abbr-month + (lambda (val object) + (tm:set-date-month! object val))) + (list #\H char-numeric? ireader2 (lambda (val object) + (tm:set-date-hour! object val))) + (list #\k char-fail eireader2 (lambda (val object) + (tm:set-date-hour! object val))) + (list #\m char-numeric? ireader2 (lambda (val object) + (tm:set-date-month! object val))) + (list #\M char-numeric? ireader2 (lambda (val object) + (tm:set-date-minute! + object val))) + (list #\N char-numeric? fireader9 (lambda (val object) + (tm:set-date-nanosecond! object val))) + (list #\S char-numeric? ireader2 (lambda (val object) + (tm:set-date-second! object val))) + (list #\y char-fail eireader2 + (lambda (val object) + (tm:set-date-year! object (tm:natural-year val)))) + (list #\Y char-numeric? ireader4 (lambda (val object) + (tm:set-date-year! object val))) + (list #\z (lambda (c) + (or (char=? c #\Z) + (char=? c #\z) + (char=? c #\+) + (char=? c #\-))) + tm:zone-reader (lambda (val object) + (tm:set-date-zone-offset! object val))) + ))) + +(define (tm:string->date date index format-string str-len port template-string) + (define (skip-until port skipper) + (let ((ch (peek-char port))) + (if (eof-object? ch) + (tm:time-error 'string->date 'bad-date-format-string template-string) + (if (not (skipper ch)) + (begin (read-char port) (skip-until port skipper)))))) + (if (>= index str-len) + (begin + (values)) + (let ( (current-char (string-ref format-string index)) ) + (if (not (char=? current-char #\~)) + (let ((port-char (read-char port))) + (if (or (eof-object? port-char) + (not (char=? current-char port-char))) + (tm:time-error 'string->date 'bad-date-format-string template-string)) + (tm:string->date date (+ index 1) format-string str-len port template-string)) + ;; otherwise, it's an escape, we hope + (if (> (+ index 1) str-len) + (tm:time-error 'string->date 'bad-date-format-string template-string) + (let* ( (format-char (string-ref format-string (+ index 1))) + (format-info (assoc format-char tm:read-directives)) ) + (if (not format-info) + (tm:time-error 'string->date 'bad-date-format-string template-string) + (begin + (let ((skipper (cadr format-info)) + (reader (caddr format-info)) + (actor (cadddr format-info))) + (skip-until port skipper) + (let ((val (reader port))) + (if (eof-object? val) + (tm:time-error 'string->date 'bad-date-format-string template-string) + (actor val date))) + (tm:string->date date (+ index 2) format-string str-len port template-string)))))))))) + +(define (string->date input-string template-string) + (define (tm:date-ok? date) + (and (date-nanosecond date) + (date-second date) + (date-minute date) + (date-hour date) + (date-day date) + (date-month date) + (date-year date) + (date-zone-offset date))) + (let ( (newdate (make-date 0 0 0 0 #f #f #f (tm:local-tz-offset))) ) + (tm:string->date newdate + 0 + template-string + (string-length template-string) + (open-input-string input-string) + template-string) + (if (tm:date-ok? newdate) + newdate + (tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string))))) + diff --git a/functional-tests/srfi/s19/time.sls b/functional-tests/srfi/s19/time.sls new file mode 100644 index 0000000..8520c67 --- /dev/null +++ b/functional-tests/srfi/s19/time.sls @@ -0,0 +1,58 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s19 time) + (export + time make-time time? time-type time-nanosecond time-second + date make-date date? date-nanosecond date-second date-minute + date-hour date-day date-month date-year date-zone-offset + time-tai time-utc time-monotonic + #|time-thread time-process|# time-duration + read-leap-second-table copy-time current-time + time-resolution time=? time>? time=? time<=? + time-difference time-difference! add-duration + add-duration! subtract-duration subtract-duration! + time-tai->time-utc time-tai->time-utc! time-utc->time-tai + time-utc->time-tai! time-monotonic->time-utc + time-monotonic->time-utc! time-monotonic->time-tai + time-monotonic->time-tai! time-utc->time-monotonic + time-utc->time-monotonic! time-tai->time-monotonic + time-tai->time-monotonic! time-tai->date time-utc->date + time-monotonic->date date->time-utc date->time-tai + date->time-monotonic leap-year? date-year-day + date-week-day date-week-number current-date + date->julian-day date->modified-julian-day + time-utc->julian-day time-utc->modified-julian-day + time-tai->julian-day time-tai->modified-julian-day + time-monotonic->julian-day + time-monotonic->modified-julian-day julian-day->time-utc + julian-day->time-tai julian-day->time-monotonic + julian-day->date modified-julian-day->date + modified-julian-day->time-utc + modified-julian-day->time-tai + modified-julian-day->time-monotonic current-julian-day + current-modified-julian-day date->string string->date) + (import + (rnrs) + (rnrs r5rs) + (rnrs mutable-strings) + (srfi s19 time compat) + (srfi s6 basic-string-ports) + (srfi private include)) + + (define read-line + (case-lambda + [() + (get-line (current-input-port))] + [(port) + (get-line port)])) + + (define eof (eof-object)) + + (include/resolve ("srfi" "s19") "srfi-19.scm") +) + diff --git a/functional-tests/srfi/s19/time/compat.chezscheme.sls b/functional-tests/srfi/s19/time/compat.chezscheme.sls new file mode 100644 index 0000000..8700769 --- /dev/null +++ b/functional-tests/srfi/s19/time/compat.chezscheme.sls @@ -0,0 +1,26 @@ + +(library (srfi s19 time compat) + + (export format + host:time-resolution + host:current-time + host:time-nanosecond + host:time-second + host:time-gmt-offset) + + (import (chezscheme) + (prefix (only (chezscheme) + current-time + time-nanosecond + time-second) + host:)) + + (define host:time-resolution 1000) + + ;; (define (host:time-gmt-offset t) + ;; (date-zone-offset t)) + + (define (host:time-gmt-offset t) + (date-zone-offset (time-utc->date t))) + + ) diff --git a/functional-tests/srfi/s23/error.sls b/functional-tests/srfi/s23/error.sls new file mode 100644 index 0000000..4104054 --- /dev/null +++ b/functional-tests/srfi/s23/error.sls @@ -0,0 +1,16 @@ +#!r6rs +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +(library (srfi s23 error) + (export + error) + (import + (rename (rnrs base) (error rnrs:error))) + + (define (error . args) + (apply rnrs:error #F args)) +) diff --git a/functional-tests/srfi/s23/error/tricks.sls b/functional-tests/srfi/s23/error/tricks.sls new file mode 100644 index 0000000..df28f08 --- /dev/null +++ b/functional-tests/srfi/s23/error/tricks.sls @@ -0,0 +1,43 @@ +#!r6rs +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +(library (srfi s23 error tricks) + (export + SRFI-23-error->R6RS) + (import + (rnrs)) + + (define-syntax error-wrap + (lambda (stx) + (syntax-case stx () + ((_ ctxt signal expr ...) + (with-syntax ((e (datum->syntax #'ctxt 'error))) + #'(let-syntax ((e (identifier-syntax signal))) + expr ...)))))) + + (define (AV who) + (lambda args (apply assertion-violation who args))) + + (define-syntax SRFI-23-error->R6RS + (lambda (stx) + (syntax-case stx () + ((ctxt ewho expr ...) + (with-syntax ((e (datum->syntax #'ctxt 'error)) + (d (datum->syntax #'ctxt 'define))) + #'(let-syntax ((e (identifier-syntax (AV 'ewho))) + (d (lambda (stx) + (syntax-case stx () + ((kw (id . formals) . body) + (identifier? #'id) + #'(error-wrap kw (AV 'id) + (d (id . formals) . body))) + ((kw id . r) + (identifier? #'id) + #'(error-wrap kw (AV 'id) + (d id . r))))))) + expr ...)))))) +) diff --git a/functional-tests/srfi/s27/random-bits.sls b/functional-tests/srfi/s27/random-bits.sls new file mode 100644 index 0000000..4505ec8 --- /dev/null +++ b/functional-tests/srfi/s27/random-bits.sls @@ -0,0 +1,30 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s27 random-bits) + (export random-integer + random-real + default-random-source + make-random-source + random-source? + random-source-state-ref + random-source-state-set! + random-source-randomize! + random-source-pseudo-randomize! + random-source-make-integers + random-source-make-reals) + + (import (rnrs) + (rnrs r5rs) + (only (srfi s19 time) time-nanosecond current-time) + (srfi s23 error tricks) + (srfi private include) + ) + + (SRFI-23-error->R6RS "(library (srfi s27 random-bits))" + (include/resolve ("srfi" "s27") "random.ss")) + ) diff --git a/functional-tests/srfi/s27/random.ss b/functional-tests/srfi/s27/random.ss new file mode 100644 index 0000000..40e3030 --- /dev/null +++ b/functional-tests/srfi/s27/random.ss @@ -0,0 +1,584 @@ +;; R6RS port of the Scheme48 reference implementation of SRFI-27 + +; MODULE DEFINITION FOR SRFI-27 +; ============================= +; +; Sebastian.Egner@philips.com, Mar-2002, in Scheme 48 0.57 + +; 1. The core generator is implemented in 'mrg32k3a-a.scm'. +; 2. The generic parts of the interface are in 'mrg32k3a.scm'. +; 3. The non-generic parts (record type, time, error) are here. + +; history of this file: +; SE, 22-Mar-2002: initial version +; SE, 27-Mar-2002: checked again +; JS, 06-Dec-2007: R6RS port + +(define-record-type :random-source + (fields state-ref + state-set! + randomize! + pseudo-randomize! + make-integers + make-reals)) + +(define :random-source-make make-:random-source) +(define state-ref :random-source-state-ref) +(define state-set! :random-source-state-set!) +(define randomize! :random-source-randomize!) +(define pseudo-randomize! :random-source-pseudo-randomize!) +(define make-integers :random-source-make-integers) +(define make-reals :random-source-make-reals) + +(define (:random-source-current-time) + (time-nanosecond (current-time))) + + +;;; mrg32k3a-a.ss + +; 54-BIT INTEGER IMPLEMENTATION OF THE "MRG32K3A"-GENERATOR +; ========================================================= +; +; Sebastian.Egner@philips.com, Mar-2002. +; +; This file is an implementation of Pierre L'Ecuyer's MRG32k3a +; pseudo random number generator. Please refer to 'mrg32k3a.scm' +; for more information. +; +; compliance: +; Scheme R5RS with integers covering at least {-2^53..2^53-1}. +; +; history of this file: +; SE, 18-Mar-2002: initial version +; SE, 22-Mar-2002: comments adjusted, range added +; SE, 25-Mar-2002: pack/unpack just return their argument + +; the actual generator + +(define (mrg32k3a-random-m1 state) + (let ((x11 (vector-ref state 0)) + (x12 (vector-ref state 1)) + (x13 (vector-ref state 2)) + (x21 (vector-ref state 3)) + (x22 (vector-ref state 4)) + (x23 (vector-ref state 5))) + (let ((x10 (modulo (- (* 1403580 x12) (* 810728 x13)) 4294967087)) + (x20 (modulo (- (* 527612 x21) (* 1370589 x23)) 4294944443))) + (vector-set! state 0 x10) + (vector-set! state 1 x11) + (vector-set! state 2 x12) + (vector-set! state 3 x20) + (vector-set! state 4 x21) + (vector-set! state 5 x22) + (modulo (- x10 x20) 4294967087)))) + +; interface to the generic parts of the generator + +(define (mrg32k3a-pack-state unpacked-state) + unpacked-state) + +(define (mrg32k3a-unpack-state state) + state) + +(define (mrg32k3a-random-range) ; m1 + 4294967087) + +(define (mrg32k3a-random-integer state range) ; rejection method + (let* ((q (quotient 4294967087 range)) + (qn (* q range))) + (do ((x (mrg32k3a-random-m1 state) (mrg32k3a-random-m1 state))) + ((< x qn) (quotient x q))))) + +(define (mrg32k3a-random-real state) ; normalization is 1/(m1+1) + (* 0.0000000002328306549295728 (+ 1.0 (mrg32k3a-random-m1 state)))) + + +;;; mrg32k3a.ss + +; GENERIC PART OF MRG32k3a-GENERATOR FOR SRFI-27 +; ============================================== +; +; Sebastian.Egner@philips.com, 2002. +; +; This is the generic R5RS-part of the implementation of the MRG32k3a +; generator to be used in SRFI-27. It is based on a separate implementation +; of the core generator (presumably in native code) and on code to +; provide essential functionality not available in R5RS (see below). +; +; compliance: +; Scheme R5RS with integer covering at least {-2^53..2^53-1}. +; In addition, +; SRFI-23: error +; +; history of this file: +; SE, 22-Mar-2002: refactored from earlier versions +; SE, 25-Mar-2002: pack/unpack need not allocate +; SE, 27-Mar-2002: changed interface to core generator +; SE, 10-Apr-2002: updated spec of mrg32k3a-random-integer + +; Generator +; ========= +; +; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive +; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n} +; defined by the two recursive generators +; +; x[1,n] = ( a12 x[1,n-2] + a13 x[1,n-3]) mod m1, +; x[2,n] = (a21 x[2,n-1] + a23 x[2,n-3]) mod m2, +; +; where the constants are +; m1 = 4294967087 = 2^32 - 209 modulus of 1st component +; m2 = 4294944443 = 2^32 - 22853 modulus of 2nd component +; a12 = 1403580 recursion coefficients +; a13 = -810728 +; a21 = 527612 +; a23 = -1370589 +; +; The generator passes all tests of G. Marsaglia's Diehard testsuite. +; Its period is (m1^3 - 1)(m2^3 - 1)/2 which is nearly 2^191. +; L'Ecuyer reports: "This generator is well-behaved in all dimensions +; up to at least 45: ..." [with respect to the spectral test, SE]. +; +; The period is maximal for all values of the seed as long as the +; state of both recursive generators is not entirely zero. +; +; As the successor state is a linear combination of previous +; states, it is possible to advance the generator by more than one +; iteration by applying a linear transformation. The following +; publication provides detailed information on how to do that: +; +; [1] P. L'Ecuyer, R. Simard, E. J. Chen, W. D. Kelton: +; An Object-Oriented Random-Number Package With Many Long +; Streams and Substreams. 2001. +; To appear in Operations Research. +; +; Arithmetics +; =========== +; +; The MRG32k3a generator produces values in {0..2^32-209-1}. All +; subexpressions of the actual generator fit into {-2^53..2^53-1}. +; The code below assumes that Scheme's "integer" covers this range. +; In addition, it is assumed that floating point literals can be +; read and there is some arithmetics with inexact numbers. +; +; However, for advancing the state of the generator by more than +; one step at a time, the full range {0..2^32-209-1} is needed. + + +; Required: Backbone Generator +; ============================ +; +; At this point in the code, the following procedures are assumed +; to be defined to execute the core generator: +; +; (mrg32k3a-pack-state unpacked-state) -> packed-state +; (mrg32k3a-unpack-state packed-state) -> unpacked-state +; pack/unpack a state of the generator. The core generator works +; on packed states, passed as an explicit argument, only. This +; allows native code implementations to store their state in a +; suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22) +; with integer x_ij. Pack/unpack need not allocate new objects +; in case packed and unpacked states are identical. +; +; (mrg32k3a-random-range) -> m-max +; (mrg32k3a-random-integer packed-state range) -> x in {0..range-1} +; advance the state of the generator and return the next random +; range-limited integer. +; Note that the state is not necessarily advanced by just one +; step because we use the rejection method to avoid any problems +; with distribution anomalies. +; The range argument must be an exact integer in {1..m-max}. +; It can be assumed that range is a fixnum if the Scheme system +; has such a number representation. +; +; (mrg32k3a-random-real packed-state) -> x in (0,1) +; advance the state of the generator and return the next random +; real number between zero and one (both excluded). The type of +; the result should be a flonum if possible. + +; Required: Record Data Type +; ========================== +; +; At this point in the code, the following procedures are assumed +; to be defined to create and access a new record data type: +; +; (:random-source-make a0 a1 a2 a3 a4 a5) -> s +; constructs a new random source object s consisting of the +; objects a0 .. a5 in this order. +; +; (:random-source? obj) -> bool +; tests if a Scheme object is a :random-source. +; +; (:random-source-state-ref s) -> a0 +; (:random-source-state-set! s) -> a1 +; (:random-source-randomize! s) -> a2 +; (:random-source-pseudo-randomize! s) -> a3 +; (:random-source-make-integers s) -> a4 +; (:random-source-make-reals s) -> a5 +; retrieve the values in the fields of the object s. + +; Required: Current Time as an Integer +; ==================================== +; +; At this point in the code, the following procedure is assumed +; to be defined to obtain a value that is likely to be different +; for each invokation of the Scheme system: +; +; (:random-source-current-time) -> x +; an integer that depends on the system clock. It is desired +; that the integer changes as fast as possible. + + +; Accessing the State +; =================== + +(define (mrg32k3a-state-ref packed-state) + (cons 'lecuyer-mrg32k3a + (vector->list (mrg32k3a-unpack-state packed-state)))) + +(define (mrg32k3a-state-set external-state) + + (define (check-value x m) + (if (and (integer? x) + (exact? x) + (<= 0 x (- m 1))) + #t + (error "illegal value" x))) + + (if (and (list? external-state) + (= (length external-state) 7) + (eq? (car external-state) 'lecuyer-mrg32k3a)) + (let ((s (cdr external-state))) + (check-value (list-ref s 0) mrg32k3a-m1) + (check-value (list-ref s 1) mrg32k3a-m1) + (check-value (list-ref s 2) mrg32k3a-m1) + (check-value (list-ref s 3) mrg32k3a-m2) + (check-value (list-ref s 4) mrg32k3a-m2) + (check-value (list-ref s 5) mrg32k3a-m2) + (if (or (zero? (+ (list-ref s 0) (list-ref s 1) (list-ref s 2))) + (zero? (+ (list-ref s 3) (list-ref s 4) (list-ref s 5)))) + (error "illegal degenerate state" external-state)) + (mrg32k3a-pack-state (list->vector s))) + (error "malformed state" external-state))) + + +; Pseudo-Randomization +; ==================== +; +; Reference [1] above shows how to obtain many long streams and +; substream from the backbone generator. +; +; The idea is that the generator is a linear operation on the state. +; Hence, we can express this operation as a 3x3-matrix acting on the +; three most recent states. Raising the matrix to the k-th power, we +; obtain the operation to advance the state by k steps at once. The +; virtual streams and substreams are now simply parts of the entire +; periodic sequence (which has period around 2^191). +; +; For the implementation it is necessary to compute with matrices in +; the ring (Z/(m1*m1)*Z)^(3x3). By the Chinese-Remainder Theorem, this +; is isomorphic to ((Z/m1*Z) x (Z/m2*Z))^(3x3). We represent such a pair +; of matrices +; [ [[x00 x01 x02], +; [x10 x11 x12], +; [x20 x21 x22]], mod m1 +; [[y00 y01 y02], +; [y10 y11 y12], +; [y20 y21 y22]] mod m2] +; as a vector of length 18 of the integers as writen above: +; #(x00 x01 x02 x10 x11 x12 x20 x21 x22 +; y00 y01 y02 y10 y11 y12 y20 y21 y22) +; +; As the implementation should only use the range {-2^53..2^53-1}, the +; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32, +; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0 +; where w = 2^16. In this case, all operations fit the range because +; w^2 mod m is a small number. If proper multiprecision integers are +; available this is not necessary, but pseudo-randomize! is an expected +; to be called only occasionally so we do not provide this implementation. + +(define mrg32k3a-m1 4294967087) ; modulus of component 1 +(define mrg32k3a-m2 4294944443) ; modulus of component 2 + +(define mrg32k3a-initial-state ; 0 3 6 9 12 15 of A^16, see below + '#( 1062452522 + 2961816100 + 342112271 + 2854655037 + 3321940838 + 3542344109)) + +(define mrg32k3a-generators #f) ; computed when needed + +(define (mrg32k3a-pseudo-randomize-state i j) + + (define (product A B) ; A*B in ((Z/m1*Z) x (Z/m2*Z))^(3x3) + + (define w 65536) ; wordsize to split {0..2^32-1} + (define w-sqr1 209) ; w^2 mod m1 + (define w-sqr2 22853) ; w^2 mod m2 + + (define (lc i0 i1 i2 j0 j1 j2 m w-sqr) ; linear combination + (let ((a0h (quotient (vector-ref A i0) w)) + (a0l (modulo (vector-ref A i0) w)) + (a1h (quotient (vector-ref A i1) w)) + (a1l (modulo (vector-ref A i1) w)) + (a2h (quotient (vector-ref A i2) w)) + (a2l (modulo (vector-ref A i2) w)) + (b0h (quotient (vector-ref B j0) w)) + (b0l (modulo (vector-ref B j0) w)) + (b1h (quotient (vector-ref B j1) w)) + (b1l (modulo (vector-ref B j1) w)) + (b2h (quotient (vector-ref B j2) w)) + (b2l (modulo (vector-ref B j2) w))) + (modulo + (+ (* (+ (* a0h b0h) + (* a1h b1h) + (* a2h b2h)) + w-sqr) + (* (+ (* a0h b0l) + (* a0l b0h) + (* a1h b1l) + (* a1l b1h) + (* a2h b2l) + (* a2l b2h)) + w) + (* a0l b0l) + (* a1l b1l) + (* a2l b2l)) + m))) + + (vector + (lc 0 1 2 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_00 mod m1 + (lc 0 1 2 1 4 7 mrg32k3a-m1 w-sqr1) ; (A*B)_01 + (lc 0 1 2 2 5 8 mrg32k3a-m1 w-sqr1) + (lc 3 4 5 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_10 + (lc 3 4 5 1 4 7 mrg32k3a-m1 w-sqr1) + (lc 3 4 5 2 5 8 mrg32k3a-m1 w-sqr1) + (lc 6 7 8 0 3 6 mrg32k3a-m1 w-sqr1) + (lc 6 7 8 1 4 7 mrg32k3a-m1 w-sqr1) + (lc 6 7 8 2 5 8 mrg32k3a-m1 w-sqr1) + (lc 9 10 11 9 12 15 mrg32k3a-m2 w-sqr2) ; (A*B)_00 mod m2 + (lc 9 10 11 10 13 16 mrg32k3a-m2 w-sqr2) + (lc 9 10 11 11 14 17 mrg32k3a-m2 w-sqr2) + (lc 12 13 14 9 12 15 mrg32k3a-m2 w-sqr2) + (lc 12 13 14 10 13 16 mrg32k3a-m2 w-sqr2) + (lc 12 13 14 11 14 17 mrg32k3a-m2 w-sqr2) + (lc 15 16 17 9 12 15 mrg32k3a-m2 w-sqr2) + (lc 15 16 17 10 13 16 mrg32k3a-m2 w-sqr2) + (lc 15 16 17 11 14 17 mrg32k3a-m2 w-sqr2))) + + (define (power A e) ; A^e + (cond + ((zero? e) + '#(1 0 0 0 1 0 0 0 1 1 0 0 0 1 0 0 0 1)) + ((= e 1) + A) + ((even? e) + (power (product A A) (quotient e 2))) + (else + (product (power A (- e 1)) A)))) + + (define (power-power A b) ; A^(2^b) + (if (zero? b) + A + (power-power (product A A) (- b 1)))) + + (define A ; the MRG32k3a recursion + '#( 0 1403580 4294156359 + 1 0 0 + 0 1 0 + 527612 0 4293573854 + 1 0 0 + 0 1 0)) + + ; check arguments + (if (not (and (integer? i) + (exact? i) + (integer? j) + (exact? j))) + (error "i j must be exact integer" i j)) + + ; precompute A^(2^127) and A^(2^76) only once + + (if (not mrg32k3a-generators) + (set! mrg32k3a-generators + (list (power-power A 127) + (power-power A 76) + (power A 16)))) + + ; compute M = A^(16 + i*2^127 + j*2^76) + (let ((M (product + (list-ref mrg32k3a-generators 2) + (product + (power (list-ref mrg32k3a-generators 0) + (modulo i (expt 2 28))) + (power (list-ref mrg32k3a-generators 1) + (modulo j (expt 2 28))))))) + (mrg32k3a-pack-state + (vector + (vector-ref M 0) + (vector-ref M 3) + (vector-ref M 6) + (vector-ref M 9) + (vector-ref M 12) + (vector-ref M 15))))) + +; True Randomization +; ================== +; +; The value obtained from the system time is feed into a very +; simple pseudo random number generator. This in turn is used +; to obtain numbers to randomize the state of the MRG32k3a +; generator, avoiding period degeneration. + +(define (mrg32k3a-randomize-state state) + ;; G. Marsaglia's simple 16-bit generator with carry + (let* ((m 65536) + (x (modulo (:random-source-current-time) m))) + (define (random-m) + (let ((y (modulo x m))) + (set! x (+ (* 30903 y) (quotient x m))) + y)) + (define (random n) ; m < n < m^2 + (modulo (+ (* (random-m) m) (random-m)) n)) + + ; modify the state + (let ((m1 mrg32k3a-m1) + (m2 mrg32k3a-m2) + (s (mrg32k3a-unpack-state state))) + (mrg32k3a-pack-state + (vector + (+ 1 (modulo (+ (vector-ref s 0) (random (- m1 1))) (- m1 1))) + (modulo (+ (vector-ref s 1) (random m1)) m1) + (modulo (+ (vector-ref s 2) (random m1)) m1) + (+ 1 (modulo (+ (vector-ref s 3) (random (- m2 1))) (- m2 1))) + (modulo (+ (vector-ref s 4) (random m2)) m2) + (modulo (+ (vector-ref s 5) (random m2)) m2)))))) + + +; Large Integers +; ============== +; +; To produce large integer random deviates, for n > m-max, we first +; construct large random numbers in the range {0..m-max^k-1} for some +; k such that m-max^k >= n and then use the rejection method to choose +; uniformly from the range {0..n-1}. + +(define mrg32k3a-m-max + (mrg32k3a-random-range)) + +(define (mrg32k3a-random-power state k) ; n = m-max^k, k >= 1 + (if (= k 1) + (mrg32k3a-random-integer state mrg32k3a-m-max) + (+ (* (mrg32k3a-random-power state (- k 1)) mrg32k3a-m-max) + (mrg32k3a-random-integer state mrg32k3a-m-max)))) + +(define (mrg32k3a-random-large state n) ; n > m-max + (do ((k 2 (+ k 1)) + (mk (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max))) + ((>= mk n) + (let* ((mk-by-n (quotient mk n)) + (a (* mk-by-n n))) + (do ((x (mrg32k3a-random-power state k) + (mrg32k3a-random-power state k))) + ((< x a) (quotient x mk-by-n))))))) + + +; Multiple Precision Reals +; ======================== +; +; To produce multiple precision reals we produce a large integer value +; and convert it into a real value. This value is then normalized. +; The precision goal is unit <= 1/(m^k + 1), or 1/unit - 1 <= m^k. +; If you know more about the floating point number types of the +; Scheme system, this can be improved. + +(define (mrg32k3a-random-real-mp state unit) + (do ((k 1 (+ k 1)) + (u (- (/ 1 unit) 1) (/ u mrg32k3a-m1))) + ((<= u 1) + (/ (exact->inexact (+ (mrg32k3a-random-power state k) 1)) + (exact->inexact (+ (expt mrg32k3a-m-max k) 1)))))) + + +; Provide the Interface as Specified in the SRFI +; ============================================== +; +; An object of type random-source is a record containing the procedures +; as components. The actual state of the generator is stored in the +; binding-time environment of make-random-source. + +(define (make-random-source) + (let ((state (mrg32k3a-pack-state ; make a new copy + (list->vector (vector->list mrg32k3a-initial-state))))) + (:random-source-make + (lambda () + (mrg32k3a-state-ref state)) + (lambda (new-state) + (set! state (mrg32k3a-state-set new-state))) + (lambda () + (set! state (mrg32k3a-randomize-state state))) + (lambda (i j) + (set! state (mrg32k3a-pseudo-randomize-state i j))) + (lambda () + (lambda (n) + (cond + ((not (and (integer? n) (exact? n) (positive? n))) + (error "range must be exact positive integer" n)) + ((<= n mrg32k3a-m-max) + (mrg32k3a-random-integer state n)) + (else + (mrg32k3a-random-large state n))))) + (lambda args + (cond + ((null? args) + (lambda () + (mrg32k3a-random-real state))) + ((null? (cdr args)) + (let ((unit (car args))) + (cond + ((not (and (real? unit) (< 0 unit 1))) + (error "unit must be real in (0,1)" unit)) + ((<= (- (/ 1 unit) 1) mrg32k3a-m1) + (lambda () + (mrg32k3a-random-real state))) + (else + (lambda () + (mrg32k3a-random-real-mp state unit)))))) + (else + (error "illegal arguments" args))))))) + +(define random-source? + :random-source?) + +(define (random-source-state-ref s) + ((:random-source-state-ref s))) + +(define (random-source-state-set! s state) + ((:random-source-state-set! s) state)) + +(define (random-source-randomize! s) + ((:random-source-randomize! s))) + +(define (random-source-pseudo-randomize! s i j) + ((:random-source-pseudo-randomize! s) i j)) + +; --- + +(define (random-source-make-integers s) + ((:random-source-make-integers s))) + +(define (random-source-make-reals s . unit) + (apply (:random-source-make-reals s) unit)) + +; --- + +(define default-random-source + (make-random-source)) + +(define random-integer + (random-source-make-integers default-random-source)) + +(define random-real + (random-source-make-reals default-random-source)) diff --git a/functional-tests/srfi/s27/readme b/functional-tests/srfi/s27/readme new file mode 100644 index 0000000..36848fe --- /dev/null +++ b/functional-tests/srfi/s27/readme @@ -0,0 +1,67 @@ +REFERENCE IMPLEMENTATIONS FOR SRFI-27 "Sources of Random Bits" +============================================================== + +Sebastian.Egner@philips.com, 10-Apr-2002. + +Files +----- + + readme - this file + mrg32k3a.scm - generic parts of P. L' Ecuyer's MRG32k3a PRGN + mrg32k3a-a.scm - core generator in Scheme integers + mrg32k3a-b.c - core generator in C doubles for Scheme 48 + mrg32k3a-c.scm - core generator in Gambit [Scheme] flonums + srfi-27-a.scm - Scheme 48 package definition for Scheme-only impl. + srfi-27-b.scm - Scheme 48 package definition for C/Scheme impl. + srfi-27-c.scm - Gambit definition for Scheme-only impl. + conftest.scm - confidence tests for the implementation + +Implementations +--------------- + +The implementation has been factored into three parts. +One part implements the core generator, one part provides +the more generic functionality as specified in the SRFI, +and one part combines the parts and provides the interface +as specified in the SRFI. + +a) A Scheme-only implementation for Scheme 48 0.57: + srfi-27-a.scm + mrg32k3a-a.scm + mrg32k3a.scm + + This implementation uses 54-bit Scheme integers for all + arithmetics of the generator. The result are Scheme integers + and inexact Scheme numbers when floating point values are + requested. + + The implementation is slow but tries to stay away from + unportable features as much as possible. + +b) An implementation in Scheme 48 0.57 and ANSI-C: + srfi-27-b.scm + mrg32k3a-b.scm + mrg32k3a.scm + + This is a more realistic implementation using C's (double) + datatype for the core generator and 54-bit Scheme integers + for the more infrequent operations on the state like the + random-source-pseudo-randomize! operation. + + This implementation is meant as an example for a realistic + native code implementation of the SRFI. Performance is good. + +c) A Scheme-only implementation for Gambit 3.0: + srfi-27-c.scm + mrg32k3a-c.scm + mrg32k3a.scm + + This implementation uses Gambit's 64-bit flonums. It is + entirely written in Scheme but uses a few special features + of the Gambit system to tell the compiler. + + This implementation is meant as an example for a realistic + Scheme implementation using flonums in Scheme and no C-code. + Performance is good when the code is used in compiled form; + the implementation has been optimized by Brad Lucier. This + has resulted in a subtantial performance gain. diff --git a/functional-tests/srfi/s6/basic-string-ports.mzscheme.sls b/functional-tests/srfi/s6/basic-string-ports.mzscheme.sls new file mode 100644 index 0000000..8ca2a13 --- /dev/null +++ b/functional-tests/srfi/s6/basic-string-ports.mzscheme.sls @@ -0,0 +1,43 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s6 basic-string-ports) + (export + (rename (open-string-input-port open-input-string)) + open-output-string + get-output-string) + (import + (rnrs) + (only (scheme base) make-weak-hasheq hash-ref hash-set!)) + + (define accumed-ht (make-weak-hasheq)) + + (define (open-output-string) + (letrec ([sop + (make-custom-textual-output-port + "string-output-port" + (lambda (string start count) ; write! + (when (positive? count) + (let ([al (hash-ref accumed-ht sop)]) + (hash-set! accumed-ht sop + (cons (substring string start (+ start count)) al)))) + count) + #f ; get-position TODO? + #f ; set-position! TODO? + #f #| closed TODO? |# )]) + (hash-set! accumed-ht sop '()) + sop)) + + (define (get-output-string sop) + (if (output-port? sop) + (cond [(hash-ref accumed-ht sop #f) + => (lambda (al) (apply string-append (reverse al)))] + [else + (assertion-violation 'get-output-string "not a string-output-port" sop)]) + (assertion-violation 'get-output-string "not an output-port" sop))) + +) diff --git a/functional-tests/srfi/s6/basic-string-ports.sls b/functional-tests/srfi/s6/basic-string-ports.sls new file mode 100644 index 0000000..4064250 --- /dev/null +++ b/functional-tests/srfi/s6/basic-string-ports.sls @@ -0,0 +1,20 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s6 basic-string-ports) + (export + open-input-string + open-output-string + get-output-string) + (import + (rnrs base) + (only (rnrs io ports) open-string-input-port) + (srfi s6 basic-string-ports compat)) + + (define (open-input-string str) + (open-string-input-port str)) +) diff --git a/functional-tests/srfi/s6/basic-string-ports/compat.chezscheme.sls b/functional-tests/srfi/s6/basic-string-ports/compat.chezscheme.sls new file mode 100644 index 0000000..3d7438e --- /dev/null +++ b/functional-tests/srfi/s6/basic-string-ports/compat.chezscheme.sls @@ -0,0 +1,6 @@ + +(library (srfi s6 basic-string-ports compat) + + (export open-output-string get-output-string) + + (import (only (chezscheme) open-output-string get-output-string))) \ No newline at end of file diff --git a/functional-tests/srfi/s64/testing.scm b/functional-tests/srfi/s64/testing.scm new file mode 100644 index 0000000..3d087e1 --- /dev/null +++ b/functional-tests/srfi/s64/testing.scm @@ -0,0 +1,993 @@ +;; Copyright (c) 2005, 2006 Per Bothner +;; +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(cond-expand + (r6rs) + (chicken + (require-extension syntax-case)) + (guile + (use-modules (ice-9 syncase) (srfi srfi-9) + ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7 + (srfi srfi-39))) + (sisc + (require-extension (srfi 9 34 35 39))) + (kawa + (module-compile-options warn-undefined-variable: #t + warn-invoke-unknown-method: #t) + (provide 'srfi-64) + (provide 'testing) + (require 'srfi-34) + (require 'srfi-35)) + (else () + )) + +(cond-expand + (r6rs + (define-syntax %test-export + (syntax-rules () + ((%test-export . names) (begin))))) + (kawa + (define-syntax %test-export + (syntax-rules () + ((%test-export test-begin . other-names) + (module-export %test-begin . other-names))))) + (else + (define-syntax %test-export + (syntax-rules () + ((%test-export . names) (if #f #f)))))) + +;; List of exported names +(%test-export + test-begin ;; must be listed first, since in Kawa (at least) it is "magic". + test-end test-assert test-eqv test-eq test-equal + test-approximate test-assert test-error test-apply test-with-runner + test-match-nth test-match-all test-match-any test-match-name + test-skip test-expect-fail test-read-eval-string + test-runner-group-path test-group-with-cleanup + test-result-ref test-result-set! test-result-clear test-result-remove + test-result-kind test-passed? + test-log-to-file + ; Misc test-runner functions + test-runner? test-runner-reset test-runner-null + test-runner-simple test-runner-current test-runner-factory test-runner-get + test-runner-create test-runner-test-name + ;; test-runner field setter and getter functions - see %test-record-define: + test-runner-pass-count test-runner-pass-count! + test-runner-fail-count test-runner-fail-count! + test-runner-xpass-count test-runner-xpass-count! + test-runner-xfail-count test-runner-xfail-count! + test-runner-skip-count test-runner-skip-count! + test-runner-group-stack test-runner-group-stack! + test-runner-on-test-begin test-runner-on-test-begin! + test-runner-on-test-end test-runner-on-test-end! + test-runner-on-group-begin test-runner-on-group-begin! + test-runner-on-group-end test-runner-on-group-end! + test-runner-on-final test-runner-on-final! + test-runner-on-bad-count test-runner-on-bad-count! + test-runner-on-bad-end-name test-runner-on-bad-end-name! + test-result-alist test-result-alist! + test-runner-aux-value test-runner-aux-value! + ;; default/simple call-back functions, used in default test-runner, + ;; but can be called to construct more complex ones. + test-on-group-begin-simple test-on-group-end-simple + test-on-bad-count-simple test-on-bad-end-name-simple + test-on-final-simple test-on-test-end-simple + test-on-final-simple) + +(cond-expand + (srfi-9 + (define-syntax %test-record-define + (syntax-rules () + ((%test-record-define alloc runner? (name index getter setter) ...) + (define-record-type test-runner + (alloc) + runner? + (name getter setter) ...))))) + (else + (define %test-runner-cookie (list "test-runner")) + (define-syntax %test-record-define + (syntax-rules () + ((%test-record-define alloc runner? (name index getter setter) ...) + (begin + (define (runner? obj) + (and (vector? obj) + (> (vector-length obj) 1) + (eq (vector-ref obj 0) %test-runner-cookie))) + (define (alloc) + (let ((runner (make-vector 22))) + (vector-set! runner 0 %test-runner-cookie) + runner)) + (begin + (define (getter runner) + (vector-ref runner index)) ...) + (begin + (define (setter runner value) + (vector-set! runner index value)) ...))))))) + +(%test-record-define + %test-runner-alloc test-runner? + ;; Cumulate count of all tests that have passed and were expected to. + (pass-count 1 test-runner-pass-count test-runner-pass-count!) + (fail-count 2 test-runner-fail-count test-runner-fail-count!) + (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!) + (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!) + (skip-count 5 test-runner-skip-count test-runner-skip-count!) + (skip-list 6 %test-runner-skip-list %test-runner-skip-list!) + (fail-list 7 %test-runner-fail-list %test-runner-fail-list!) + ;; Normally #t, except when in a test-apply. + (run-list 8 %test-runner-run-list %test-runner-run-list!) + (skip-save 9 %test-runner-skip-save %test-runner-skip-save!) + (fail-save 10 %test-runner-fail-save %test-runner-fail-save!) + (group-stack 11 test-runner-group-stack test-runner-group-stack!) + (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!) + (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!) + ;; Call-back when entering a group. Takes (runner suite-name count). + (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!) + ;; Call-back when leaving a group. + (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!) + ;; Call-back when leaving the outermost group. + (on-final 16 test-runner-on-final test-runner-on-final!) + ;; Call-back when expected number of tests was wrong. + (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!) + ;; Call-back when name in test=end doesn't match test-begin. + (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!) + ;; Cumulate count of all tests that have been done. + (total-count 19 %test-runner-total-count %test-runner-total-count!) + ;; Stack (list) of (count-at-start . expected-count): + (count-list 20 %test-runner-count-list %test-runner-count-list!) + (result-alist 21 test-result-alist test-result-alist!) + ;; Field can be used by test-runner for any purpose. + ;; test-runner-simple uses it for a log file. + (aux-value 22 test-runner-aux-value test-runner-aux-value!) +) + +(define (test-runner-reset runner) + (test-result-alist! runner '()) + (test-runner-pass-count! runner 0) + (test-runner-fail-count! runner 0) + (test-runner-xpass-count! runner 0) + (test-runner-xfail-count! runner 0) + (test-runner-skip-count! runner 0) + (%test-runner-total-count! runner 0) + (%test-runner-count-list! runner '()) + (%test-runner-run-list! runner #t) + (%test-runner-skip-list! runner '()) + (%test-runner-fail-list! runner '()) + (%test-runner-skip-save! runner '()) + (%test-runner-fail-save! runner '()) + (test-runner-group-stack! runner '())) + +(define (test-runner-group-path runner) + (reverse (test-runner-group-stack runner))) + +(define (%test-null-callback runner) #f) + +(define (test-runner-null) + (let ((runner (%test-runner-alloc))) + (test-runner-reset runner) + (test-runner-on-group-begin! runner (lambda (runner name count) #f)) + (test-runner-on-group-end! runner %test-null-callback) + (test-runner-on-final! runner %test-null-callback) + (test-runner-on-test-begin! runner %test-null-callback) + (test-runner-on-test-end! runner %test-null-callback) + (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) + (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) + runner)) + +;; Not part of the specification. FIXME +;; Controls whether a log file is generated. +(define test-log-to-file #F) + +(define (test-runner-simple) + (let ((runner (%test-runner-alloc))) + (test-runner-reset runner) + (test-runner-on-group-begin! runner test-on-group-begin-simple) + (test-runner-on-group-end! runner test-on-group-end-simple) + (test-runner-on-final! runner test-on-final-simple) + (test-runner-on-test-begin! runner test-on-test-begin-simple) + (test-runner-on-test-end! runner test-on-test-end-simple) + (test-runner-on-bad-count! runner test-on-bad-count-simple) + (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) + runner)) + +(cond-expand + (srfi-39 + (define test-runner-current (make-parameter #f)) + (define test-runner-factory (make-parameter test-runner-simple))) + (else + (define %test-runner-current #f) + (define-syntax test-runner-current + (syntax-rules () + ((test-runner-current) + %test-runner-current) + ((test-runner-current runner) + (set! %test-runner-current runner)))) + (define %test-runner-factory test-runner-simple) + (define-syntax test-runner-factory + (syntax-rules () + ((test-runner-factory) + %test-runner-factory) + ((test-runner-factory runner) + (set! %test-runner-factory runner)))))) + +;; A safer wrapper to test-runner-current. +(define (test-runner-get) + (let ((r (test-runner-current))) + (if (not r) + (cond-expand + (srfi-23 (error "test-runner not initialized - test-begin missing?")) + (else #t))) + r)) + +(define (%test-specificier-matches spec runner) + (spec runner)) + +(define (test-runner-create) + ((test-runner-factory))) + +(define (%test-any-specifier-matches list runner) + (let ((result #f)) + (let loop ((l list)) + (cond ((null? l) result) + (else + (if (%test-specificier-matches (car l) runner) + (set! result #t)) + (loop (cdr l))))))) + +;; Returns #f, #t, or 'xfail. +(define (%test-should-execute runner) + (let ((run (%test-runner-run-list runner))) + (cond ((or + (not (or (eqv? run #t) + (%test-any-specifier-matches run runner))) + (%test-any-specifier-matches + (%test-runner-skip-list runner) + runner)) + (test-result-set! runner 'result-kind 'skip) + #f) + ((%test-any-specifier-matches + (%test-runner-fail-list runner) + runner) + (test-result-set! runner 'result-kind 'xfail) + 'xfail) + (else #t)))) + +(define (%test-begin suite-name count) + (if (not (test-runner-current)) + (test-runner-current (test-runner-create))) + (let ((runner (test-runner-current))) + ((test-runner-on-group-begin runner) runner suite-name count) + (%test-runner-skip-save! runner + (cons (%test-runner-skip-list runner) + (%test-runner-skip-save runner))) + (%test-runner-fail-save! runner + (cons (%test-runner-fail-list runner) + (%test-runner-fail-save runner))) + (%test-runner-count-list! runner + (cons (cons (%test-runner-total-count runner) + count) + (%test-runner-count-list runner))) + (test-runner-group-stack! runner (cons suite-name + (test-runner-group-stack runner))))) +(cond-expand + ((and (not r6rs) kawa) + ;; Kawa has test-begin built in, implemented as: + ;; (begin + ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64))) + ;; (%test-begin suite-name [count])) + ;; This puts test-begin but only test-begin in the default environment., + ;; which makes normal test suites loadable without non-portable commands. + ) + (else + (define-syntax test-begin + (syntax-rules () + ((test-begin suite-name) + (%test-begin suite-name #f)) + ((test-begin suite-name count) + (%test-begin suite-name count)))))) + +(define (test-on-group-begin-simple runner suite-name count) + (if (null? (test-runner-group-stack runner)) + (begin + (display "%%%% Starting test ") + (display suite-name) + (if test-log-to-file + (let* ((log-file-name + (if (string? test-log-to-file) test-log-to-file + (string-append suite-name ".log"))) + (log-file + (cond-expand ((and (not r6rs) mzscheme) + (open-output-file log-file-name 'truncate/replace)) + (else (open-output-file log-file-name))))) + (display "%%%% Starting test " log-file) + (display suite-name log-file) + (newline log-file) + (test-runner-aux-value! runner log-file) + (display " (Writing full log to \"") + (display log-file-name) + (display "\")"))) + (newline))) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (begin + (display "Group begin: " log) + (display suite-name log) + (newline log)))) + #f) + +(define (test-on-group-end-simple runner) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (begin + (display "Group end: " log) + (display (car (test-runner-group-stack runner)) log) + (newline log)))) + #f) + +(define (%test-on-bad-count-write runner count expected-count port) + (display "*** Total number of tests was " port) + (display count port) + (display " but should be " port) + (display expected-count port) + (display ". ***" port) + (newline port) + (display "*** Discrepancy indicates testsuite error or exceptions. ***" port) + (newline port)) + +(define (test-on-bad-count-simple runner count expected-count) + (%test-on-bad-count-write runner count expected-count (current-output-port)) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (%test-on-bad-count-write runner count expected-count log)))) + +(define (test-on-bad-end-name-simple runner begin-name end-name) + (let ((msg (string-append (%test-format-line runner) "test-end " begin-name + " does not match test-begin " end-name))) + (cond-expand + (srfi-23 (error msg)) + (else (display msg) (newline))))) + + +(define (%test-final-report1 value label port) + (if (> value 0) + (begin + (display label port) + (display value port) + (newline port)))) + +(define (%test-final-report-simple runner port) + (%test-final-report1 (test-runner-pass-count runner) + "# of expected passes " port) + (%test-final-report1 (test-runner-xfail-count runner) + "# of expected failures " port) + (%test-final-report1 (test-runner-xpass-count runner) + "# of unexpected successes " port) + (%test-final-report1 (test-runner-fail-count runner) + "# of unexpected failures " port) + (%test-final-report1 (test-runner-skip-count runner) + "# of skipped tests " port)) + +(define (test-on-final-simple runner) + (%test-final-report-simple runner (current-output-port)) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (%test-final-report-simple runner log)))) + +(define (%test-format-line runner) + (let* ((line-info (test-result-alist runner)) + (source-file (assq 'source-file line-info)) + (source-line (assq 'source-line line-info)) + (file (if source-file (cdr source-file) ""))) + (if source-line + (string-append file ":" + (number->string (cdr source-line)) ": ") + ""))) + +(define (%test-end suite-name line-info) + (let* ((r (test-runner-get)) + (groups (test-runner-group-stack r)) + (line (%test-format-line r))) + (test-result-alist! r line-info) + (if (null? groups) + (let ((msg (string-append line "test-end not in a group"))) + (cond-expand + (srfi-23 (error msg)) + (else (display msg) (newline))))) + (if (and suite-name (not (equal? suite-name (car groups)))) + ((test-runner-on-bad-end-name r) r suite-name (car groups))) + (let* ((count-list (%test-runner-count-list r)) + (expected-count (cdar count-list)) + (saved-count (caar count-list)) + (group-count (- (%test-runner-total-count r) saved-count))) + (if (and expected-count + (not (= expected-count group-count))) + ((test-runner-on-bad-count r) r group-count expected-count)) + ((test-runner-on-group-end r) r) + (test-runner-group-stack! r (cdr (test-runner-group-stack r))) + (%test-runner-skip-list! r (car (%test-runner-skip-save r))) + (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) + (%test-runner-fail-list! r (car (%test-runner-fail-save r))) + (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) + (%test-runner-count-list! r (cdr count-list)) + (if (null? (test-runner-group-stack r)) + ((test-runner-on-final r) r))))) + +(define-syntax test-group + (syntax-rules () + ((test-group suite-name . body) + (let ((r (test-runner-current))) + ;; Ideally should also set line-number, if available. + (test-result-alist! r (list (cons 'test-name suite-name))) + (if (%test-should-execute r) + (dynamic-wind + (lambda () (test-begin suite-name)) + (lambda () . body) + (lambda () (test-end suite-name)))))))) + +(define-syntax test-group-with-cleanup + (syntax-rules () + ((test-group-with-cleanup suite-name form cleanup-form) + (test-group suite-name + (dynamic-wind + (lambda () #f) + (lambda () form) + (lambda () cleanup-form)))) + ((test-group-with-cleanup suite-name cleanup-form) + (test-group-with-cleanup suite-name #f cleanup-form)) + ((test-group-with-cleanup suite-name form1 form2 form3 . rest) + (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest)))) + +(define (test-on-test-begin-simple runner) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (let* ((results (test-result-alist runner)) + (source-file (assq 'source-file results)) + (source-line (assq 'source-line results)) + (source-form (assq 'source-form results)) + (test-name (assq 'test-name results))) + (display "Test begin:" log) + (newline log) + (if test-name (%test-write-result1 test-name log)) + (if source-file (%test-write-result1 source-file log)) + (if source-line (%test-write-result1 source-line log)) + (if source-form (%test-write-result1 source-form log)))))) + +(define-syntax test-result-ref + (syntax-rules () + ((test-result-ref runner pname) + (test-result-ref runner pname #f)) + ((test-result-ref runner pname default) + (let ((p (assq pname (test-result-alist runner)))) + (if p (cdr p) default))))) + +(define (test-on-test-end-simple runner) + (let ((log (test-runner-aux-value runner)) + (kind (test-result-ref runner 'result-kind))) + (if (memq kind '(fail xpass)) + (let* ((results (test-result-alist runner)) + (source-file (assq 'source-file results)) + (source-line (assq 'source-line results)) + (test-name (assq 'test-name results))) + (if (or source-file source-line) + (begin + (if source-file (display (cdr source-file))) + (display ":") + (if source-line (display (cdr source-line))) + (display ": "))) + (display (if (eq? kind 'xpass) "XPASS" "FAIL")) + (if test-name + (begin + (display " ") + (display (cdr test-name)))) + (newline))) + (if (output-port? log) + (begin + (display "Test end:" log) + (newline log) + (let loop ((list (test-result-alist runner))) + (if (pair? list) + (let ((pair (car list))) + ;; Write out properties not written out by on-test-begin. + (if (not (memq (car pair) + '(test-name source-file source-line source-form))) + (%test-write-result1 pair log)) + (loop (cdr list))))))))) + +(define (%test-write-result1 pair port) + (display " " port) + (display (car pair) port) + (display ": " port) + (write (cdr pair) port) + (newline port)) + +(define (test-result-set! runner pname value) + (let* ((alist (test-result-alist runner)) + (p (assq pname alist))) + (if p + (set-cdr! p value) + (test-result-alist! runner (cons (cons pname value) alist))))) + +(define (test-result-clear runner) + (test-result-alist! runner '())) + +(define (test-result-remove runner pname) + (let* ((alist (test-result-alist runner)) + (p (assq pname alist))) + (if p + (test-result-alist! runner + (let loop ((r alist)) + (if (eq? r p) (cdr r) + (cons (car r) (loop (cdr r))))))))) + +(define (test-result-kind . rest) + (let ((runner (if (pair? rest) (car rest) (test-runner-current)))) + (test-result-ref runner 'result-kind))) + +(define (test-passed? . rest) + (let ((runner (if (pair? rest) (car rest) (test-runner-get)))) + (memq (test-result-ref runner 'result-kind) '(pass xpass)))) + +(define (%test-report-result) + (let* ((r (test-runner-get)) + (result-kind (test-result-kind r))) + (case result-kind + ((pass) + (test-runner-pass-count! r (+ 1 (test-runner-pass-count r)))) + ((fail) + (test-runner-fail-count! r (+ 1 (test-runner-fail-count r)))) + ((xpass) + (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r)))) + ((xfail) + (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r)))) + (else + (test-runner-skip-count! r (+ 1 (test-runner-skip-count r))))) + (%test-runner-total-count! r (+ 1 (%test-runner-total-count r))) + ((test-runner-on-test-end r) r))) + +(cond-expand + (r6rs + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (guard (ex (else #F)) test-expression))))) + (guile + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (catch #t (lambda () test-expression) (lambda (key . args) #f)))))) + (kawa + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (try-catch test-expression + (ex + (test-result-set! (test-runner-current) 'actual-error ex) + #f)))))) + (srfi-34 + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (guard (err (else #f)) test-expression))))) + (chicken + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (condition-case test-expression (ex () #f)))))) + (else + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + test-expression))))) + +(cond-expand + ((and (not r6rs) (or kawa mzscheme)) + (cond-expand + (mzscheme + (define-for-syntax (%test-syntax-file form) + (let ((source (syntax-source form))) + (cond ((string? source) file) + ((path? source) (path->string source)) + (else #f))))) + (kawa + (define (%test-syntax-file form) + (syntax-source form)))) + (define-for-syntax (%test-source-line2 form) + (let* ((line (syntax-line form)) + (file (%test-syntax-file form)) + (line-pair (if line (list (cons 'source-line line)) '()))) + (cons (cons 'source-form (syntax-object->datum form)) + (if file (cons (cons 'source-file file) line-pair) line-pair))))) + (else + (define (%test-source-line2 form) + '()))) + +(define (%test-on-test-begin r) + (%test-should-execute r) + ((test-runner-on-test-begin r) r) + (not (eq? 'skip (test-result-ref r 'result-kind)))) + +(define (%test-on-test-end r result) + (test-result-set! r 'result-kind + (if (eq? (test-result-ref r 'result-kind) 'xfail) + (if result 'xpass 'xfail) + (if result 'pass 'fail)))) + +(define (test-runner-test-name runner) + (test-result-ref runner 'test-name "")) + +(define-syntax %test-comp2body + (syntax-rules () + ((%test-comp2body r comp expected expr) + (let () + (if (%test-on-test-begin r) + (let ((exp expected)) + (test-result-set! r 'expected-value exp) + (let ((res (%test-evaluate-with-catch expr))) + (test-result-set! r 'actual-value res) + (%test-on-test-end r (comp exp res))))) + (%test-report-result))))) + +(define (%test-approximimate= error) + (lambda (value expected) + (and (>= value (- expected error)) + (<= value (+ expected error))))) + +(define-syntax %test-comp1body + (syntax-rules () + ((%test-comp1body r expr) + (let () + (if (%test-on-test-begin r) + (let () + (let ((res (%test-evaluate-with-catch expr))) + (test-result-set! r 'actual-value res) + (%test-on-test-end r res)))) + (%test-report-result))))) + +(cond-expand + ((and (not r6rs) (or kawa mzscheme)) + ;; Should be made to work for any Scheme with syntax-case + ;; However, I haven't gotten the quoting working. FIXME. + (define-syntax test-end + (lambda (x) + (syntax-case (list x (list 'quote (%test-source-line2 x))) () + (((mac suite-name) line) + (syntax + (%test-end suite-name line))) + (((mac) line) + (syntax + (%test-end #f line)))))) + (define-syntax test-assert + (lambda (x) + (syntax-case (list x (list 'quote (%test-source-line2 x))) () + (((mac tname expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-comp1body r expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-comp1body r expr))))))) + (define-for-syntax (%test-comp2 comp x) + (syntax-case (list x (list 'quote (%test-source-line2 x)) comp) () + (((mac tname expected expr) line comp) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-comp2body r comp expected expr)))) + (((mac expected expr) line comp) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-comp2body r comp expected expr)))))) + (define-syntax test-eqv + (lambda (x) (%test-comp2 (syntax eqv?) x))) + (define-syntax test-eq + (lambda (x) (%test-comp2 (syntax eq?) x))) + (define-syntax test-equal + (lambda (x) (%test-comp2 (syntax equal?) x))) + (define-syntax test-approximate ;; FIXME - needed for non-Kawa + (lambda (x) + (syntax-case (list x (list 'quote (%test-source-line2 x))) () + (((mac tname expected expr error) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-comp2body r (%test-approximimate= error) expected expr)))) + (((mac expected expr error) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-comp2body r (%test-approximimate= error) expected expr)))))))) + (else + (define-syntax test-end + (syntax-rules () + ((test-end) + (%test-end #f '())) + ((test-end suite-name) + (%test-end suite-name '())))) + (define-syntax test-assert + (syntax-rules () + ((test-assert tname test-expression) + (let ((r (test-runner-get))) + (test-result-alist! r `((test-name . ,tname) + (source-form . test-expression))) + (%test-comp1body r test-expression))) + ((test-assert test-expression) + (let ((r (test-runner-get))) + (test-result-alist! r '((source-form . test-expression))) + (%test-comp1body r test-expression))))) + (define-syntax %test-comp2 + (syntax-rules () + ((%test-comp2 comp tname expected expr) + (let ((r (test-runner-get))) + (test-result-alist! r `((test-name . ,tname) + (source-form . expr))) + (%test-comp2body r comp expected expr))) + ((%test-comp2 comp expected expr) + (let ((r (test-runner-get))) + (test-result-alist! r '((source-form . expr))) + (%test-comp2body r comp expected expr))))) + (define-syntax test-equal + (syntax-rules () + ((test-equal . rest) + (%test-comp2 equal? . rest)))) + (define-syntax test-eqv + (syntax-rules () + ((test-eqv . rest) + (%test-comp2 eqv? . rest)))) + (define-syntax test-eq + (syntax-rules () + ((test-eq . rest) + (%test-comp2 eq? . rest)))) + (define-syntax test-approximate + (syntax-rules () + ((test-approximate tname expected expr error) + (%test-comp2 (%test-approximimate= error) tname expected expr)) + ((test-approximate expected expr error) + (%test-comp2 (%test-approximimate= error) expected expr)))))) + +(cond-expand + (r6rs + (define-syntax %test-error + (syntax-rules () + ((%test-error etype expr) + (let ((t etype)) + (when (procedure? t) + (test-result-set! (test-runner-get) 'expected-error t)) + (guard (ex (else + (test-result-set! (test-runner-get) 'actual-error ex) + (if (procedure? t) (t ex) #T))) + expr + #F)))))) + (guile + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (catch #t (lambda () expr) (lambda (key . args) #t))))))) + (mzscheme + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t))) + (let () + (test-result-set! r 'actual-value expr) + #f))))))) + (chicken + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (condition-case expr (ex () #t))))))) + (kawa + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (let () + (if (%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (try-catch + (let () + (test-result-set! r 'actual-value expr) + #f) + (ex + (test-result-set! r 'actual-error ex) + (cond ((and (instance? et ) + (gnu.bytecode.ClassType:isSubclass et )) + (instance? ex et)) + (else #t))))) + (%test-report-result)))))))) + ((and srfi-34 srfi-35) + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (guard (ex ((condition-type? etype) + (and (condition? ex) (condition-has-type? ex etype))) + ((procedure? etype) + (etype ex)) + ((equal? type #t) + #t) + (else #t)) + expr)))))) + (srfi-34 + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (guard (ex (else #t)) expr)))))) + (else + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (begin + ((test-runner-on-test-begin r) r) + (test-result-set! r 'result-kind 'skip) + (%test-report-result))))))) + +(cond-expand + ((and (not r6rs) (or kawa mzscheme)) + + (define-syntax test-error + (lambda (x) + (syntax-case (list x (list 'quote (%test-source-line2 x))) () + (((mac tname etype expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-error r etype expr)))) + (((mac etype expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r etype expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r #t expr)))))))) + (else + (define-syntax test-error + (syntax-rules () + ((test-error name etype expr) + (test-assert name (%test-error etype expr))) + ((test-error etype expr) + (test-assert (%test-error etype expr))) + ((test-error expr) + (test-assert (%test-error #t expr))))))) + +(define (test-apply first . rest) + (if (test-runner? first) + (test-with-runner first (apply test-apply rest)) + (let ((r (test-runner-current))) + (if r + (let ((run-list (%test-runner-run-list r))) + (cond ((null? rest) + (%test-runner-run-list! r (reverse! run-list)) + (first)) ;; actually apply procedure thunk + (else + (%test-runner-run-list! + r + (if (eq? run-list #t) (list first) (cons first run-list))) + (apply test-apply rest) + (%test-runner-run-list! r run-list)))) + (let ((r (test-runner-create))) + (test-with-runner r (apply test-apply first rest)) + ((test-runner-on-final r) r)))))) + +(define-syntax test-with-runner + (syntax-rules () + ((test-with-runner runner form ...) + (let ((saved-runner (test-runner-current))) + (dynamic-wind + (lambda () (test-runner-current runner)) + (lambda () form ...) + (lambda () (test-runner-current saved-runner))))))) + +;;; Predicates + +(define (%test-match-nth n count) + (let ((i 0)) + (lambda (runner) + (set! i (+ i 1)) + (and (>= i n) (< i (+ n count)))))) + +(define-syntax test-match-nth + (syntax-rules () + ((test-match-nth n) + (test-match-nth n 1)) + ((test-match-nth n count) + (%test-match-nth n count)))) + +(define (%test-match-all . pred-list) + (lambda (runner) + (let ((result #t)) + (let loop ((l pred-list)) + (if (null? l) + result + (begin + (if (not ((car l) runner)) + (set! result #f)) + (loop (cdr l)))))))) + +(define-syntax test-match-all + (syntax-rules () + ((test-match-all pred ...) + (%test-match-all (%test-as-specifier pred) ...)))) + +(define (%test-match-any . pred-list) + (lambda (runner) + (let ((result #f)) + (let loop ((l pred-list)) + (if (null? l) + result + (begin + (if ((car l) runner) + (set! result #t)) + (loop (cdr l)))))))) + +(define-syntax test-match-any + (syntax-rules () + ((test-match-any pred ...) + (%test-match-any (%test-as-specifier pred) ...)))) + +;; Coerce to a predicate function: +(define (%test-as-specifier specifier) + (cond ((procedure? specifier) specifier) + ((integer? specifier) (test-match-nth 1 specifier)) + ((string? specifier) (test-match-name specifier)) + (else + (error "not a valid test specifier")))) + +(define-syntax test-skip + (syntax-rules () + ((test-skip pred ...) + (let ((runner (test-runner-get))) + (%test-runner-skip-list! runner + (cons (test-match-all (%test-as-specifier pred) ...) + (%test-runner-skip-list runner))))))) + +(define-syntax test-expect-fail + (syntax-rules () + ((test-expect-fail pred ...) + (let ((runner (test-runner-get))) + (%test-runner-fail-list! runner + (cons (test-match-all (%test-as-specifier pred) ...) + (%test-runner-fail-list runner))))))) + +(define (test-match-name name) + (lambda (runner) + (equal? name (test-runner-test-name runner)))) + +(define (test-read-eval-string string) + (let* ((port (open-input-string string)) + (form (read port))) + (if (eof-object? (read-char port)) + (eval form) + (cond-expand + (srfi-23 (error "(not at eof)")) + (else "error"))))) + diff --git a/functional-tests/srfi/s64/testing.sls b/functional-tests/srfi/s64/testing.sls new file mode 100644 index 0000000..2d582bb --- /dev/null +++ b/functional-tests/srfi/s64/testing.sls @@ -0,0 +1,74 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s64 testing) + (export + test-begin + test-end test-assert test-eqv test-eq test-equal + test-approximate test-error test-apply test-with-runner + test-match-nth test-match-all test-match-any test-match-name + test-skip test-expect-fail test-read-eval-string + test-group test-runner-group-path test-group-with-cleanup + test-result-ref test-result-set! test-result-clear test-result-remove + test-result-kind test-passed? + (rename (%test-log-to-file test-log-to-file)) + ; Misc test-runner functions + test-runner? test-runner-reset test-runner-null + test-runner-simple test-runner-current test-runner-factory test-runner-get + test-runner-create test-runner-test-name + ;; test-runner field setter and getter functions - see %test-record-define: + test-runner-pass-count test-runner-pass-count! + test-runner-fail-count test-runner-fail-count! + test-runner-xpass-count test-runner-xpass-count! + test-runner-xfail-count test-runner-xfail-count! + test-runner-skip-count test-runner-skip-count! + test-runner-group-stack test-runner-group-stack! + test-runner-on-test-begin test-runner-on-test-begin! + test-runner-on-test-end test-runner-on-test-end! + test-runner-on-group-begin test-runner-on-group-begin! + test-runner-on-group-end test-runner-on-group-end! + test-runner-on-final test-runner-on-final! + test-runner-on-bad-count test-runner-on-bad-count! + test-runner-on-bad-end-name test-runner-on-bad-end-name! + test-result-alist test-result-alist! + test-runner-aux-value test-runner-aux-value! + ;; default/simple call-back functions, used in default test-runner, + ;; but can be called to construct more complex ones. + test-on-group-begin-simple test-on-group-end-simple + test-on-bad-count-simple test-on-bad-end-name-simple + test-on-final-simple test-on-test-end-simple) + (import + (rnrs base) + (rnrs control) + (rnrs exceptions) + (rnrs io simple) + (rnrs lists) + (rename (rnrs eval) (eval rnrs:eval)) + (rnrs mutable-pairs) + (srfi s0 cond-expand) + (only (srfi s1 lists) reverse!) + (srfi s6 basic-string-ports) + (srfi s9 records) + (srfi s39 parameters) + (srfi s23 error tricks) + (srfi private include)) + + (define (eval form) + (rnrs:eval form (environment '(rnrs) + '(rnrs eval) + '(rnrs mutable-pairs) + '(rnrs mutable-strings) + '(rnrs r5rs)))) + + (define %test-log-to-file + (case-lambda + (() test-log-to-file) + ((val) (set! test-log-to-file val)))) + + (SRFI-23-error->R6RS "(library (srfi s64 testing))" + (include/resolve ("srfi" "s64") "testing.scm")) +) diff --git a/functional-tests/srfi/s8/receive.sls b/functional-tests/srfi/s8/receive.sls new file mode 100644 index 0000000..b6f6a0b --- /dev/null +++ b/functional-tests/srfi/s8/receive.sls @@ -0,0 +1,19 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s8 receive) + (export receive) + (import (rnrs)) + + (define-syntax receive + (syntax-rules () + [(_ formals expression b b* ...) + (call-with-values + (lambda () expression) + (lambda formals b b* ...))])) + +) diff --git a/functional-tests/srfi/s9/records.sls b/functional-tests/srfi/s9/records.sls new file mode 100644 index 0000000..396931c --- /dev/null +++ b/functional-tests/srfi/s9/records.sls @@ -0,0 +1,51 @@ +;; Copyright (c) 2009 Derick Eddington. All rights reserved. +;; Licensed under an MIT-style license. My license is in the file +;; named LICENSE from the original collection this file is distributed +;; with. If this file is redistributed with some other collection, my +;; license must also be included. + +#!r6rs +(library (srfi s9 records) + (export + (rename (srfi:define-record-type define-record-type))) + (import + (rnrs)) + + (define-syntax srfi:define-record-type + (lambda (stx) + (syntax-case stx () + [(_ type (constructor constructor-tag ...) + predicate + (field-tag accessor setter ...) ...) + (and (for-all identifier? + #'(type constructor predicate constructor-tag ... + field-tag ... accessor ...)) + (for-all (lambda (s) + (or (and (= 1 (length s)) (identifier? (car s))) + (= 0 (length s)))) + #'((setter ...) ...)) + (for-all (lambda (ct) + (memp (lambda (ft) (bound-identifier=? ct ft)) + #'(field-tag ...))) + #'(constructor-tag ...))) + (with-syntax ([(field-clause ...) + (map (lambda (clause) + (if (= 2 (length clause)) + #`(immutable . #,clause) + #`(mutable . #,clause))) + #'((field-tag accessor setter ...) ...))] + [(unspec-tag ...) + (remp (lambda (ft) + (memp (lambda (ct) (bound-identifier=? ft ct)) + #'(constructor-tag ...))) + #'(field-tag ...))]) + #'(define-record-type (type constructor predicate) + (sealed #t) + (protocol (lambda (ctor) + (lambda (constructor-tag ...) + (define unspec-tag) + ... + (ctor field-tag ...)))) + (fields field-clause ...)))]))) + +)