[functional tests] Remove dependency on the ThunderChez library.
I've just moved the relevant code into the functional-tests dir.
This commit is contained in:
Joe Thornber
32
functional-tests/srfi/LICENSE
Normal file
32
functional-tests/srfi/LICENSE
Normal 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
17
functional-tests/srfi/README
Normal 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
25
functional-tests/srfi/private/OS-id-features.sls
Normal 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
18
functional-tests/srfi/private/auxiliary-keyword.sls
Normal 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
53
functional-tests/srfi/private/feature-cond.sls
Normal 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
51
functional-tests/srfi/private/include.sls
Normal 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
11
functional-tests/srfi/private/include/compat.chezscheme.sls
Normal 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
130
functional-tests/srfi/private/let-opt.sls
Normal 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
54
functional-tests/srfi/private/make-aliased-libraries.sps
Normal 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)
|
||||
@@ -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
103
functional-tests/srfi/private/registry.sls
Normal 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
43
functional-tests/srfi/private/vanish.sls
Normal 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
51
functional-tests/srfi/s0/cond-expand.sls
Normal 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
1142
functional-tests/srfi/s1/lists.sls
Normal file
File diff suppressed because it is too large
Load Diff
2019
functional-tests/srfi/s13/srfi-13.scm
Normal file
2019
functional-tests/srfi/s13/srfi-13.scm
Normal file
File diff suppressed because it is too large
Load Diff
85
functional-tests/srfi/s13/strings.sls
Normal file
85
functional-tests/srfi/s13/strings.sls
Normal 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
66
functional-tests/srfi/s14/char-sets.sls
Normal 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
806
functional-tests/srfi/s14/srfi-14.scm
Normal 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
1476
functional-tests/srfi/s19/srfi-19.scm
Normal file
File diff suppressed because it is too large
Load Diff
58
functional-tests/srfi/s19/time.sls
Normal file
58
functional-tests/srfi/s19/time.sls
Normal 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
26
functional-tests/srfi/s19/time/compat.chezscheme.sls
Normal 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
16
functional-tests/srfi/s23/error.sls
Normal 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
43
functional-tests/srfi/s23/error/tricks.sls
Normal 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
30
functional-tests/srfi/s27/random-bits.sls
Normal 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
584
functional-tests/srfi/s27/random.ss
Normal 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
67
functional-tests/srfi/s27/readme
Normal 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
43
functional-tests/srfi/s6/basic-string-ports.mzscheme.sls
Normal 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
20
functional-tests/srfi/s6/basic-string-ports.sls
Normal 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))
|
||||
)
|
||||
@@ -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
993
functional-tests/srfi/s64/testing.scm
Normal 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
74
functional-tests/srfi/s64/testing.sls
Normal 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
19
functional-tests/srfi/s8/receive.sls
Normal 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
51
functional-tests/srfi/s9/records.sls
Normal 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 ...)))])))
|
||||
|
||||
)
|
||||
Reference in New Issue
Block a user