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 version "1.0.1")
|
||||||
(define license '(Apache-2.0 OR MIT))
|
(define license '(Apache-2.0 OR MIT))
|
||||||
(define collection "let-assert")
|
(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
|
(define scribblings
|
||||||
'(
|
'(
|
||||||
|
|||||||
@@ -56,58 +56,32 @@
|
|||||||
(define a-false? (a-eq? #f))
|
(define a-false? (a-eq? #f))
|
||||||
|
|
||||||
|
|
||||||
(define-syntax assert-expr
|
(define-syntax let/assert*
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ fail (expr cond retval))
|
((_ ((v1 e1)) (b1 ...))
|
||||||
(let ((a expr)) (if (cond a) a (fail retval))))
|
(let ((v1 e1))
|
||||||
((_ fail (expr)) expr)
|
b1 ...))
|
||||||
)
|
((_ ((v1 e1 assert1 ret1)) (b1 ...))
|
||||||
)
|
(let ((v1 e1))
|
||||||
|
(cond ((assert1 v1)
|
||||||
(define-syntax let/assert
|
b1 ...)
|
||||||
(syntax-rules (fail)
|
(else ret1))))
|
||||||
((_ ((v rest ...) ...) b1 ...)
|
((_ ((v1 e1) r ...) (b1 ...))
|
||||||
(call/cc
|
(let ((v1 e1))
|
||||||
(λ (fail)
|
(let/assert* (r ...) (b1 ...))))
|
||||||
(let* ((v (assert-expr fail (rest ...)))
|
((_ ((v1 e1 assert1 ret1) r ...) (b1 ...))
|
||||||
...)
|
(let ((v1 e1))
|
||||||
b1
|
(cond ((assert1 v1)
|
||||||
...)
|
(let/assert* (r ...) (b1 ...)))
|
||||||
)
|
(else ret1))))
|
||||||
)
|
|
||||||
)
|
|
||||||
)
|
|
||||||
)
|
|
||||||
|
|
||||||
#|
|
|
||||||
(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)
|
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
(define-syntax let/assert
|
(define-syntax let/assert
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ ((v rest ...) ...) b1 ...)
|
((_ (a1 ...) b1 ...)
|
||||||
(with-handlers ([exn:let/assert? let/assert-value])
|
(let/assert* (a1 ...) (b1 ...))
|
||||||
(let* ((v (assert-expr rest ...))
|
|
||||||
...)
|
|
||||||
b1
|
|
||||||
...
|
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
|
||||||
)
|
|
||||||
|#
|
|
||||||
|
|||||||
Reference in New Issue
Block a user