emo/thin-provisioning-tools
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[functional tests] Remove dependency on the ThunderChez library.

Browse Source 
I've just moved the relevant code into the functional-tests dir.
This commit is contained in:
Joe Thornber 2020-04-30 12:07:42 +01:00
parent ad79b627a4
commit 3e5de399a7
61 changed files with 16836 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
README.md
View File

@ -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,

14
functional-tests/fmt/README Normal file
View File

@ -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.

1
functional-tests/fmt/VERSION Normal file
View File

@ -0,0 +1 @@
0.8.4

42
functional-tests/fmt/c.sls Normal file
View File

@ -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")
)

874
functional-tests/fmt/fmt-c.scm Normal file
View File

@ -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)) "--"))

77
functional-tests/fmt/fmt-color.scm Normal file
View File

@ -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 "<b>" (apply-cat args) "</b>"))
((eq? color 'underline)
(cat "<u>" (apply-cat args) "</u>"))
(else
(let ((cname (if (number? color) (cat "#" color) color)))
(fmt-if fmt-use-html-font?
(cat "<font color=\"" cname "\">" (apply-cat args)
"</font>")
(cat "<span style=color:\"" cname "\">"
(apply-cat args) "</span>")))))
(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)))

417
functional-tests/fmt/fmt-column.scm Normal file
View File

@ -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)))

46
functional-tests/fmt/fmt-gauche.scm Normal file
View File

@ -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))))

74
functional-tests/fmt/fmt-js.scm Normal file
View File

@ -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))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

263
functional-tests/fmt/fmt-pretty.scm Normal file
View File

@ -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)))

135
functional-tests/fmt/fmt-unicode.scm Normal file
View File

@ -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)))

69
functional-tests/fmt/fmt.css Normal file
View File

@ -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;
}

1349
functional-tests/fmt/fmt.doc Normal file
View File

File diff suppressed because it is too large Load Diff

1751
functional-tests/fmt/fmt.html Normal file
View File

File diff suppressed because it is too large Load Diff

1211
functional-tests/fmt/fmt.scm Normal file
View File

File diff suppressed because it is too large Load Diff

47
functional-tests/fmt/fmt.sls Normal file
View File

@ -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")
)

5
functional-tests/fmt/hash-compat.scm Normal file
View File

@ -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)

18
functional-tests/fmt/js.sls Normal file
View File

@ -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")
)

20
functional-tests/fmt/mantissa.scm Normal file
View File

@ -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))))))]))

11
functional-tests/fmt/read-line.scm Normal file
View File

@ -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))])))))

5
functional-tests/fmt/string-ports.scm Normal file
View File

@ -0,0 +1,5 @@
(define (call-with-output-string f)
(let ((port (open-output-string)))
(let () (f port))
(get-output-string port)))

464
functional-tests/fmt/test-fmt-c.scm Normal file
View File

@ -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)

46
functional-tests/fmt/test-fmt-js.scm Normal file
View File

@ -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)

486
functional-tests/fmt/test-fmt.scm Normal file
View File

@ -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)

27
functional-tests/fmt/test-round.scm Normal file
View File

@ -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)

1132
functional-tests/matchable.sls Normal file
View File

File diff suppressed because it is too large Load Diff

14
functional-tests/run-tests
View File

@ -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 $*

12
functional-tests/run-tests.scm Normal file
View File

@ -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)

32
functional-tests/srfi/LICENSE Normal file
View File

@ -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.

17
functional-tests/srfi/README Normal file
View File

@ -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)

25
functional-tests/srfi/private/OS-id-features.sls Normal file
View File

@ -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))))
)

18
functional-tests/srfi/private/auxiliary-keyword.sls Normal file
View File

@ -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*) ...)])))

53
functional-tests/srfi/private/feature-cond.sls Normal file
View File

@ -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"))
)

51
functional-tests/srfi/private/include.sls Normal file
View File

@ -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)))))))])))
)

11
functional-tests/srfi/private/include/compat.chezscheme.sls Normal file
View File

@ -0,0 +1,11 @@
(library (srfi private include compat)
(export search-paths)
(import (chezscheme))
(define (search-paths)
(map car (library-directories)))
)

130
functional-tests/srfi/private/let-opt.sls Normal file
View File

@ -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
)

54
functional-tests/srfi/private/make-aliased-libraries.sps Normal file
View File

@ -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) symbol<?)
(only (xitomatl environments) environment environment-symbols))
(define srfi-libraries/mnemonics
(map/filter (match-lambda
;; NOTE: Uses only the 3-element names.
((:and ('srfi (:symbol ":(\\d+)" num) _)
name)
(list (string->number (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 symbol<?
(environment-symbols (environment lib-name))))
(alias-name `(srfi ,(string->symbol (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)

23
functional-tests/srfi/private/platform-features.chezscheme.sls Normal file
View File

@ -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))
)

103
functional-tests/srfi/private/registry.sls Normal file
View File

@ -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)))
)

43
functional-tests/srfi/private/vanish.sls Normal file
View File

@ -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)))))
)

51
functional-tests/srfi/s0/cond-expand.sls Normal file
View File

@ -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 ...))])))
)

1142
functional-tests/srfi/s1/lists.sls Normal file
View File

File diff suppressed because it is too large Load Diff

2019
functional-tests/srfi/s13/srfi-13.scm Normal file
View File

File diff suppressed because it is too large Load Diff

85
functional-tests/srfi/s13/strings.sls Normal file
View File

@ -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"))
)

66
functional-tests/srfi/s14/char-sets.sls Normal file
View File

@ -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")))

806
functional-tests/srfi/s14/srfi-14.scm Normal file
View File

@ -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.

1476
functional-tests/srfi/s19/srfi-19.scm Normal file
View File

File diff suppressed because it is too large Load Diff

58
functional-tests/srfi/s19/time.sls Normal file
View File

@ -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<=?
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")
)

26
functional-tests/srfi/s19/time/compat.chezscheme.sls Normal file
View File

@ -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)))
)

16
functional-tests/srfi/s23/error.sls Normal file
View File

@ -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))
)

43
functional-tests/srfi/s23/error/tricks.sls Normal file
View File

@ -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 ...))))))
)

30
functional-tests/srfi/s27/random-bits.sls Normal file
View File

@ -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"))
)

584
functional-tests/srfi/s27/random.ss Normal file
View File

@ -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))

67
functional-tests/srfi/s27/readme Normal file
View File

@ -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.

43
functional-tests/srfi/s6/basic-string-ports.mzscheme.sls Normal file
View File

@ -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)))
)

20
functional-tests/srfi/s6/basic-string-ports.sls Normal file
View File

@ -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))
)

6
functional-tests/srfi/s6/basic-string-ports/compat.chezscheme.sls Normal file
View File

@ -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)))

993
functional-tests/srfi/s64/testing.scm Normal file
View File

@ -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 <java.lang.Throwable>
(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 <java.lang.Throwable>
(test-result-set! r 'actual-error ex)
(cond ((and (instance? et <gnu.bytecode.ClassType>)
(gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
(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")))))

74
functional-tests/srfi/s64/testing.sls Normal file
View File

@ -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"))
)

19
functional-tests/srfi/s8/receive.sls Normal file
View File

@ -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* ...))]))
)

51
functional-tests/srfi/s9/records.sls Normal file
View File

@ -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 ...)))])))
)