91 lines
2.7 KiB
Scheme
91 lines
2.7 KiB
Scheme
(import (scheme base))
|
|
(import (scheme cxr))
|
|
(import (scheme eval))
|
|
(import (scheme write))
|
|
(import (scheme read))
|
|
(import (scheme file))
|
|
(import (scheme process-context))
|
|
|
|
(define (pk . args) ;; peek stuff, debug helper.
|
|
(write args (current-error-port))
|
|
(display #\newline (current-error-port))
|
|
(flush-output-port (current-error-port))
|
|
(car (reverse args)))
|
|
|
|
(define filename "../srfi.180.checks.scm")
|
|
|
|
(define-syntax define-syntax-rule
|
|
(syntax-rules ()
|
|
((define-syntax-rule (keyword args ...) body)
|
|
(define-syntax keyword
|
|
(syntax-rules ()
|
|
((keyword args ...) body))))))
|
|
|
|
(define-syntax-rule (check expected actual)
|
|
(lambda ()
|
|
(let ((expected* expected))
|
|
(guard (ex (else (vector #f 'exception-raised expected* ex)))
|
|
(let ((actual* actual))
|
|
(if (equal? expected* actual*)
|
|
(vector #t)
|
|
(vector #f 'unexpected-result expected* actual*)))))))
|
|
|
|
(define-syntax-rule (check-raise predicate? actual)
|
|
(lambda ()
|
|
(let ((predicate?* predicate?))
|
|
(guard (ex ((predicate?* ex) (vector #t))
|
|
(else (vector #f 'unexpected-exception predicate?* ex)))
|
|
(let ((actual* actual))
|
|
(vector #f 'no-exception predicate?* actual*))))))
|
|
|
|
(define-syntax-rule (skip test expected actual)
|
|
(lambda ()
|
|
(vector #t)))
|
|
|
|
(define (success? v)
|
|
(vector-ref v 0))
|
|
|
|
(define (failure? v)
|
|
(not (success? v)))
|
|
|
|
(define (failure-expected v)
|
|
(vector-ref v 1))
|
|
|
|
(define (failure-actual v)
|
|
(vector-ref v 2))
|
|
|
|
(define (filename->library-name filename)
|
|
;; TODO: try to guess ;)
|
|
'(srfi 180 checks))
|
|
|
|
(define (filename->library-exports filename)
|
|
(define library (call-with-input-file filename read))
|
|
(let loop ((forms (cddr library))
|
|
(out '()))
|
|
(if (null? forms)
|
|
out
|
|
(if (and (pair? (car forms))
|
|
(eq? (caar forms) 'export))
|
|
(loop (cdr forms) (append out (cdar forms)))
|
|
(loop (cdr forms) out)))))
|
|
|
|
(define library-name (filename->library-name filename))
|
|
|
|
(define (check-one? library-name symbol)
|
|
(pk library-name symbol)
|
|
(let* ((proc (eval `,symbol (environment library-name)))
|
|
(out (proc)))
|
|
(if (failure? out)
|
|
(begin (pk out) #f)
|
|
#t)))
|
|
|
|
(if (null? (cddr (command-line)))
|
|
(let loop ((symbols (filename->library-exports filename))
|
|
(errors? #f))
|
|
(if (null? symbols)
|
|
(exit (if errors? 1 0))
|
|
(if (check-one? library-name (car symbols))
|
|
(begin (loop (cdr symbols) #f))
|
|
(loop (cdr symbols) #t))))
|
|
(check-one? library-name (string->symbol (caddr (command-line)))))
|