/usr/share/scheme48-1.9/big/matcher.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Mike Sperber
; Combinators for predicates, useful for test suites.
(define-record-type matcher :matcher
(make-matcher predicate
sexpr)
matcher?
(predicate matcher-predicate)
(sexpr matcher-sexpr))
(define-record-discloser :matcher
(lambda (m)
(list 'matcher (matcher-sexpr m))))
(define (matches? matcher val)
((matcher-predicate matcher) val))
(define (is p? . rest)
(cond ((pair? rest)
(let ((val (car rest)))
(make-matcher (lambda (x)
(p? x val))
`(is ,p? ,val))))
((procedure? p?)
(make-matcher p? `(is ,p?)))
(else (make-matcher (lambda (x)
(equal? x p?))
`(is ,p?)))))
(define (anything)
(make-matcher (lambda (x) #t)
`anything))
(define (opposite matcher)
(make-matcher (lambda (x)
(not (matches? matcher x)))
`(not ,(matcher-sexpr matcher))))
(define (is-true)
(make-matcher (lambda (x) x)
'is-true))
(define (is-false)
(make-matcher (lambda (x) (not x))
'is-false))
(define (is-null)
(make-matcher (lambda (x) (null? x))
'is-false))
(define (is-within val epsilon)
(make-matcher (lambda (x)
(and (number? x)
(< (magnitude (- val x )) epsilon)))
`(is-within ,val ,epsilon)))
(define (member-of list)
(make-matcher (lambda (x) (member x list))
`(is-member ,list)))
(define (all-of . matchers)
(make-matcher (lambda (x)
(every? (lambda (matcher)
(matches? matcher x))
matchers))
`(all-of ,@(map matcher-sexpr matchers))))
(define (any-of . matchers)
(make-matcher (lambda (x)
(any? (lambda (matcher)
(matches? matcher x))
matchers))
`(any-of ,@(map matcher-sexpr matchers))))
(define (list-where-all matcher)
(make-matcher (lambda (l)
(and (list? l)
(every? (lambda (x)
(matches? matcher x))
l)))
`(list-where-each ,matcher)))
(define (list-where-any matcher)
(make-matcher (lambda (l)
(and (list? l)
(any? (lambda (x)
(matches? matcher x))
l)))
`(list-where-any ,matcher)))
(define (list-of . matchers)
(let ((count (length matchers)))
(make-matcher (lambda (x)
(and (list? x)
(let loop ((matchers matchers)
(els x))
(cond
((null? matchers) (null? els))
((null? els) #f)
(else
(and (matches? (car matchers) (car els))
(loop (cdr matchers) (cdr els))))))))
`(list-of ,@matchers))))
(define (vector-of . matchers)
(let* ((matchers (list->vector matchers))
(count (vector-length matchers)))
(make-matcher (lambda (x)
(and (vector? x)
(= count (vector-length x))
(let loop ((i 0))
(if (= i count)
#t
(and (matches? (vector-ref matchers i))
(loop (+ 1 i)))))))
`(vector-of ,matchers))))
(define (pair-of car-matcher cdr-matcher)
(make-matcher (lambda (x)
(and (pair? x)
(matches? car-matcher (car x))
(matches? cdr-matcher (cdr x))))
`(pair-of ,car-matcher ,cdr-matcher)))
|