thin-provisioning-tools/functional-tests/utils.scm
Joe Thornber 8b7e5acc48 [functional-tests/utils] add all?, some? and none?
They only work with one list though.  Use every from srfi1.
2017-10-04 10:19:46 +01:00

93 lines
2.1 KiB
Scheme

(library
(utils)
(export inc! dec!
swap!
slurp-file
chomp
hotpatch-sym
indirect-lambda
set-lambda!
dlambda
all? some? none?)
(import (chezscheme)
(only (srfi s1 lists) drop-while))
(define-syntax inc!
(syntax-rules ()
((_ v) (set! v (+ 1 v)))
((_ v n) (set! v (+ n v)))))
(define-syntax dec!
(syntax-rules ()
((_ v) (set! v (- v 1)))
((_ v n) (set! v (- v n)))))
(define-syntax swap!
(syntax-rules ()
((_ x y)
(let ((tmp x))
(set! x y)
(set! y tmp)))))
(define (slurp-file path)
(define (slurp)
(let ((output (get-string-all (current-input-port))))
(if (eof-object? output)
output
(chomp output))))
(with-input-from-file path slurp))
(define (chomp line)
(list->string
(reverse
(drop-while char-whitespace?
(reverse (string->list line))))))
(define hotpatch-sym (gensym))
(define-syntax indirect-lambda
(syntax-rules ()
((_ params b1 b2 ...)
(let ((this (lambda params b1 b2 ...)))
(lambda args
(if (and (= (length args) 2)
(eq? (car args) hotpatch-sym))
(set! this (cadr args))
(apply this args)))))))
(define (set-lambda! fn new-fn)
(fn hotpatch-sym new-fn))
(define-syntax dlambda
(syntax-rules ()
((_ (name params b1 b2 ...) ...)
(lambda (m . args)
(apply (case m
[(name) (lambda params b1 b2 ...)] ...)
args)))))
;; FIXME: why aren't these in core scheme? what do people use instead?
(define (all? pred xs)
(let loop ((xs xs))
(if (null? xs)
#t
(if (pred (car xs))
(loop (cdr xs))
#f))))
(define (some? pred xs)
(let loop ((xs xs))
(if (null? xs)
#f
(if (pred (car xs))
#t
(loop (cdr xs))))))
(define (none? pred xs)
(not (all? pred xs)))
)