88 lines
1.8 KiB
Racket
88 lines
1.8 KiB
Racket
#lang racket/base
|
|
|
|
(provide let/assert
|
|
make-assert
|
|
a-eq? a-!eq?
|
|
a->? a-<=?
|
|
a->=? a-<?
|
|
a-=? a-!=?
|
|
a-<0? a->=0?
|
|
a-<=0? a->0?
|
|
a-=0? a-!=0?
|
|
a-true? a-false?
|
|
a-nullptr? a-!nullptr?
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; let/assert
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(define-syntax make-assert
|
|
(syntax-rules ()
|
|
((_ name not-name pred)
|
|
(begin
|
|
(define-syntax name
|
|
(syntax-rules ()
|
|
((_ const)
|
|
(λ (x) (pred x const)))))
|
|
(define-syntax not-name
|
|
(syntax-rules ()
|
|
((_ const)
|
|
(λ (x) (not (pred x const))))))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(make-assert a-eq? a-!eq? eq?)
|
|
|
|
(define a-nullptr? (a-eq? #f))
|
|
(define a-!nullptr? (a-!eq? #f))
|
|
|
|
(make-assert a->? a-<=? >)
|
|
(make-assert a->=? a-<? >=)
|
|
(make-assert a-=? a-!=? =)
|
|
|
|
(define (a-=0? x) (= x 0))
|
|
(define (a-!=0? x) (not (= x 0)))
|
|
(define (a->0? x) (> x 0))
|
|
(define (a->=0? x) (>= x 0))
|
|
(define (a-<0? x) (< x 0))
|
|
(define (a-<=0? x) (<= x 0))
|
|
|
|
|
|
(define a-true? (a-eq? #t))
|
|
(define a-false? (a-eq? #f))
|
|
|
|
(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
|
|
(syntax-rules ()
|
|
((_ ((v rest ...) ...) b1 ...)
|
|
(with-handlers ([exn:let/assert? let/assert-value])
|
|
(let* ((v (assert-expr rest ...))
|
|
...)
|
|
b1
|
|
...
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|