Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-12 23:47:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

assert improvements: dedup vars, ignore lambdas, allow report:

Browse source
This commit is contained in:
Alex Shinn 2021-05-05 07:56:14 +09:00
parent d5a0f0ddfa
commit 9a9f974d69
1 changed files with 34 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
lib/chibi/assert.sld
View file

@ -4,17 +4,24 @@
(chibi (chibi
(import (chibi)) (import (chibi))
(begin (begin
(define-syntax check-identifier (define-syntax syntax-identifier?
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(if (identifier? (cadr expr)) (if (identifier? (cadr expr))
(car (cddr expr)) (car (cddr expr))
(cadr (cddr expr)))))))) (cadr (cddr expr))))))
(define-syntax syntax-memq?
(er-macro-transformer
(lambda (expr rename compare)
(let ((expr (cdr expr)))
(if (memq (car expr) (cadr expr))
(car (cddr expr))
(cadr (cddr expr)))))))))
(else (else
(import (scheme base)) (import (scheme base))
(begin (begin
;; from match.scm ;; from match.scm
(define-syntax check-identifier (define-syntax syntax-identifier?
(syntax-rules () (syntax-rules ()
((_ (x . y) success-k failure-k) failure-k) ((_ (x . y) success-k failure-k) failure-k)
((_ #(x ...) success-k failure-k) failure-k) ((_ #(x ...) success-k failure-k) failure-k)
@ -24,10 +31,21 @@
(syntax-rules () (syntax-rules ()
((sym? x sk fk) sk) ((sym? x sk fk) sk)
((sym? y sk fk) fk)))) ((sym? y sk fk) fk))))
(sym? abracadabra success-k failure-k)))))))) (sym? abracadabra success-k failure-k)))))
(define-syntax syntax-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 (begin
(define-syntax report-vars (define-syntax report-vars
(syntax-rules (quote quasiquote) (syntax-rules (quote quasiquote lambda)
((report-vars (lambda . x) (next ...) res)
(next ... res))
((report-vars 'x (next ...) res) ((report-vars 'x (next ...) res)
(next ... res)) (next ... res))
((report-vars `x (next ...) res) ((report-vars `x (next ...) res)
@ -37,15 +55,20 @@
((report-vars (op . x) (next ...) res) ((report-vars (op . x) (next ...) res)
(next ... res)) (next ... res))
((report-vars x (next ...) (res ...)) ((report-vars x (next ...) (res ...))
(check-identifier x (syntax-identifier? x
(next ... (res ... (x ,x))) (syntax-memq? x (res ...)
(next ... (res ...)))))) (next ... (res ...))
(next ... (res ... x)))
(next ... (res ...))))))
(define-syntax report-final (define-syntax report-final
(syntax-rules () (syntax-rules ()
((report-final expr (vars ...)) ((report-final expr (var ...))
(error "assertion failed" 'expr `vars ...)))) (error "assertion failed" 'expr `(var ,var) ...))))
(define-syntax assert (define-syntax assert
(syntax-rules () (syntax-rules (report:)
((assert test report: msg ...)
(unless test
(error msg ...)))
((assert test0 test1 ...) ((assert test0 test1 ...)
(if test0 (if test0
(assert test1 ...) (assert test1 ...)