no call/cc nor exceptions anymore, just a let/cond construction created from the input
This commit is contained in:
@@ -4,7 +4,7 @@
|
||||
(define version "1.0.1")
|
||||
(define license '(Apache-2.0 OR MIT))
|
||||
(define collection "let-assert")
|
||||
(define pkg-desc "A let construct with assertions, i.e. when an assertion is not satisfied, one can prematurely exit a function with a given return value.")
|
||||
(define pkg-desc "A let* construct with assertions, i.e. when an assertion is not satisfied, one can prematurely exit a function with a given return value.")
|
||||
|
||||
(define scribblings
|
||||
'(
|
||||
|
||||
@@ -56,58 +56,32 @@
|
||||
(define a-false? (a-eq? #f))
|
||||
|
||||
|
||||
(define-syntax assert-expr
|
||||
(define-syntax let/assert*
|
||||
(syntax-rules ()
|
||||
((_ fail (expr cond retval))
|
||||
(let ((a expr)) (if (cond a) a (fail retval))))
|
||||
((_ fail (expr)) expr)
|
||||
)
|
||||
)
|
||||
|
||||
(define-syntax let/assert
|
||||
(syntax-rules (fail)
|
||||
((_ ((v rest ...) ...) b1 ...)
|
||||
(call/cc
|
||||
(λ (fail)
|
||||
(let* ((v (assert-expr fail (rest ...)))
|
||||
...)
|
||||
b1
|
||||
...)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
#|
|
||||
(struct exn:let/assert exn (value) #:transparent)
|
||||
|
||||
(define (raise-let/assert v)
|
||||
(raise (exn:let/assert "let/assert" (current-continuation-marks) v)))
|
||||
|
||||
(define (let/assert-value r)
|
||||
(exn:let/assert-value r))
|
||||
|
||||
(define-syntax assert-expr
|
||||
(syntax-rules ()
|
||||
((_ expr cond retval)
|
||||
(let ((a expr)) (if (cond a) a (raise-let/assert retval))))
|
||||
((_ expr)
|
||||
expr)
|
||||
((_ ((v1 e1)) (b1 ...))
|
||||
(let ((v1 e1))
|
||||
b1 ...))
|
||||
((_ ((v1 e1 assert1 ret1)) (b1 ...))
|
||||
(let ((v1 e1))
|
||||
(cond ((assert1 v1)
|
||||
b1 ...)
|
||||
(else ret1))))
|
||||
((_ ((v1 e1) r ...) (b1 ...))
|
||||
(let ((v1 e1))
|
||||
(let/assert* (r ...) (b1 ...))))
|
||||
((_ ((v1 e1 assert1 ret1) r ...) (b1 ...))
|
||||
(let ((v1 e1))
|
||||
(cond ((assert1 v1)
|
||||
(let/assert* (r ...) (b1 ...)))
|
||||
(else ret1))))
|
||||
)
|
||||
)
|
||||
|
||||
(define-syntax let/assert
|
||||
(syntax-rules ()
|
||||
((_ ((v rest ...) ...) b1 ...)
|
||||
(with-handlers ([exn:let/assert? let/assert-value])
|
||||
(let* ((v (assert-expr rest ...))
|
||||
...)
|
||||
b1
|
||||
...
|
||||
((_ (a1 ...) b1 ...)
|
||||
(let/assert* (a1 ...) (b1 ...))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|#
|
||||
|
||||
|
||||
Reference in New Issue
Block a user