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))
|
|
|
|
|
|
(define-syntax let/assert*
|
|
(syntax-rules ()
|
|
((_ ((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 ()
|
|
((_ (a1 ...) b1 ...)
|
|
(let/assert* (a1 ...) (b1 ...))
|
|
)
|
|
)
|
|
)
|
|
|