/usr/share/scheme48-1.9/r6rs/n-ary-comparison.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 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Mike Sperber, Robert Ransom
; Tricky business, as we want to typecheck all arguments, and avoid
; redundant normalizations.
; x is already wrapped
(define (compare-n-ary name =? wrap pred x . rest)
(let loop ((x x)
(rest rest))
(or (null? rest)
(let ((next (wrap (car rest))))
(if (=? x next)
(loop next (cdr rest))
(check-pred name pred (cdr rest)))))))
(define (check-pred name pred lis)
(cond
((memp (lambda (x)
(not (pred x)))
lis)
=> (lambda (wrong)
(assertion-violation name
"invalid argument"
(car wrong))))
(else #f)))
(define-syntax define-n-ary-comparison
(syntax-rules ()
((define-n-ary-comparison ?name ?pred ?wrap ?binary-name)
(define (?name a b . rest)
(let ((bw (?wrap b)))
(cond
((?binary-name (?wrap a) bw)
(or (null? rest)
(apply compare-n-ary '?name ?binary-name ?wrap ?pred bw rest)))
((null? rest) #f)
(else (check-pred '?name ?pred rest))))))))
|