mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
115 lines
4.5 KiB
Scheme
115 lines
4.5 KiB
Scheme
|
|
;;> A nice assert macro.
|
|
;;>
|
|
;;> Assert macros are common in Scheme, in particular being helpful
|
|
;;> for domain checks at the beginning of a procedure to catch errors
|
|
;;> as early as possible. Compared to statically typed languages this
|
|
;;> has the advantages that the assertions are optional, and that they
|
|
;;> are not limited by the type system. SRFI 145 provides the related
|
|
;;> notion of assumptions, but the motivation there is to provide
|
|
;;> hints to optimizing compilers, and these are not required to
|
|
;;> actually signal an error.
|
|
;;>
|
|
;;> \macro{(assert expr [msg ...])}
|
|
;;>
|
|
;;> Equivalent to SRFI 145 \code{assume} except that an error is
|
|
;;> guaranteed to be raised if \var{expr} is false. Conceptually
|
|
;;> shorthand for
|
|
;;>
|
|
;;> \code{(or \var{expr}
|
|
;;> (error "assertion failed" \var{msg} ...))}
|
|
;;>
|
|
;;> that is, evaluates \var{expr} and returns it if true, but raises
|
|
;;> an exception otherwise. The error is augmented to include the
|
|
;;> text of the failed \var{expr}. If no additional \var{msg}
|
|
;;> arguments are provided then \var{expr} is scanned for free
|
|
;;> variables in non-operator positions to report values from, e.g. in
|
|
;;>
|
|
;;> \code{(let ((x 3))
|
|
;;> (assert (= x (+ x 1))))}
|
|
;;>
|
|
;;> the error would also report the bound value of \code{x}. This
|
|
;;> uses the technique from Oleg Kiselyov's \hyperlink[http://okmij.org/ftp/Scheme/assert-syntax-rule.txt]{good assert macro},
|
|
;;> which is convenient but fallible. It is thus best to keep the
|
|
;;> body of the assertion simple, moving any predicates you need to
|
|
;;> external utilities, or provide an explicit \var{msg}.
|
|
|
|
(define-library (chibi assert)
|
|
(export assert)
|
|
(cond-expand
|
|
(chibi
|
|
(import (chibi))
|
|
(begin
|
|
(define-syntax syntax-identifier?
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(if (identifier? (cadr expr))
|
|
(car (cddr expr))
|
|
(cadr (cddr expr))))))
|
|
(define-syntax syntax-id-memq?
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let ((expr (cdr expr)))
|
|
(if (any (lambda (x) (compare x (car expr))) (cadr expr))
|
|
(car (cddr expr))
|
|
(cadr (cddr expr)))))))))
|
|
(else
|
|
(import (scheme base))
|
|
(begin
|
|
;; from match.scm
|
|
(define-syntax syntax-identifier?
|
|
(syntax-rules ()
|
|
((_ (x . y) success-k failure-k) failure-k)
|
|
((_ #(x ...) success-k failure-k) failure-k)
|
|
((_ x success-k failure-k)
|
|
(let-syntax
|
|
((sym?
|
|
(syntax-rules ()
|
|
((sym? x sk fk) sk)
|
|
((sym? y sk fk) fk))))
|
|
(sym? abracadabra success-k failure-k)))))
|
|
(define-syntax syntax-id-memq?
|
|
(syntax-rules ()
|
|
((syntax-memq? id (ids ...) sk fk)
|
|
(let-syntax
|
|
((memq?
|
|
(syntax-rules (ids ...)
|
|
((memq? id sk2 fk2) fk2)
|
|
((memq? any-other sk2 fk2) sk2))))
|
|
(memq? random-symbol-to-match sk fk))))))))
|
|
(begin
|
|
(define-syntax extract-vars
|
|
(syntax-rules ()
|
|
((report-vars (op arg0 arg1 ...) (next ...) res)
|
|
(syntax-id-memq? op (quote quasiquote lambda let let* letrec letrec*
|
|
let-syntax letrec-syntax let-values let*-values
|
|
receive match case define define-syntax do)
|
|
(next ... res)
|
|
(extract-vars arg0
|
|
(extract-vars (op arg1 ...) (next ...))
|
|
res)))
|
|
((report-vars (op . x) (next ...) res)
|
|
(next ... res))
|
|
((report-vars x (next ...) (res ...))
|
|
(syntax-identifier? x
|
|
(syntax-id-memq? x (res ...)
|
|
(next ... (res ...))
|
|
(next ... (res ... x)))
|
|
(next ... (res ...))))))
|
|
(define-syntax qq-vars
|
|
(syntax-rules ()
|
|
((qq-vars (next ...) (var ...))
|
|
(next ... `(var ,var) ...))))
|
|
(define-syntax report-final
|
|
(syntax-rules ()
|
|
((report-final expr msg ...)
|
|
(error "assertion failed" 'expr msg ...))))
|
|
(define-syntax assert
|
|
(syntax-rules ()
|
|
((assert test)
|
|
(or test
|
|
(extract-vars test (qq-vars (report-final test)) ())))
|
|
((assert test msg ...)
|
|
(or test
|
|
(report-final test msg ...)))
|
|
((assert) #t)))))
|