65 lines
1.9 KiB
Scheme
65 lines
1.9 KiB
Scheme
#lang scheme/base
|
|
|
|
(provide (all-defined-out))
|
|
|
|
;; Structures --------------------------------------------------
|
|
|
|
;; struct check-info : symbol any
|
|
(define-struct check-info (name value))
|
|
|
|
|
|
;; Infrastructure ----------------------------------------------
|
|
|
|
;; The continuation mark under which all check-info is keyed
|
|
(define check-info-mark (gensym 'schemeunit))
|
|
|
|
;; (continuation-mark-set -> (listof check-info))
|
|
(define (check-info-stack marks)
|
|
(apply append (continuation-mark-set->list marks check-info-mark)))
|
|
|
|
;; with-check-info* : (list-of check-info) thunk -> any
|
|
(define (with-check-info* info thunk)
|
|
(define current-marks
|
|
(continuation-mark-set-first #f check-info-mark))
|
|
(with-continuation-mark
|
|
check-info-mark
|
|
(append (if current-marks current-marks null) info)
|
|
(thunk)))
|
|
|
|
(define-syntax with-check-info
|
|
(syntax-rules ()
|
|
[(_ ((name val) ...) body ...)
|
|
(with-check-info*
|
|
(list (make-check-info name val) ...)
|
|
(lambda () body ...))]))
|
|
|
|
(define (make-check-name name)
|
|
(make-check-info 'name name))
|
|
(define (make-check-params params)
|
|
(make-check-info 'params params))
|
|
(define (make-check-location stx)
|
|
(make-check-info 'location stx))
|
|
(define (make-check-expression msg)
|
|
(make-check-info 'expression msg))
|
|
(define (make-check-message msg)
|
|
(make-check-info 'message msg))
|
|
(define (make-check-actual param)
|
|
(make-check-info 'actual param))
|
|
(define (make-check-expected param)
|
|
(make-check-info 'expected param))
|
|
|
|
(define (check-name? info)
|
|
(eq? (check-info-name info) 'name))
|
|
(define (check-params? info)
|
|
(eq? (check-info-name info) 'params))
|
|
(define (check-location? info)
|
|
(eq? (check-info-name info) 'location))
|
|
(define (check-expression? info)
|
|
(eq? (check-info-name info) 'expression))
|
|
(define (check-message? info)
|
|
(eq? (check-info-name info) 'message))
|
|
(define (check-actual? info)
|
|
(eq? (check-info-name info) 'actual))
|
|
(define (check-expected? info)
|
|
(eq? (check-info-name info) 'expected))
|