Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- (library (contract)
- (export
- ->
- listof vectorof
- any/c or/c
- integer-in fixnum-in flonum-in char-in
- define/contract)
- (import (rnrs (6))
- (srfi srfi-1))
- ;; auxiliary keyword ->
- (define-syntax ->
- (lambda (x)
- (syntax-violation #f "misplaced aux keyword" x)))
- ;;;;;;;;;;;;;;;;;;;;
- ;; Useful predicate creators
- ;;;;;;;;;;;;;;;;;;;;
- (define (listof pred?)
- (lambda (x)
- (if (list? x)
- (every pred? x)
- #f)))
- (define (vectorof pred?)
- (lambda (x)
- (let ([len (vector-length x)])
- (let loop ([i 0])
- (cond
- [(= i len) #t]
- [(pred? (vector-ref x i)) (loop (+ i 1))]
- [else #f])))))
- (define (any/c x)
- #t)
- (define (or/c . preds)
- (lambda (x)
- (let loop ([preds preds])
- (cond
- [(null? preds) #f]
- [((car preds) x)]
- [else (loop (cdr preds))]))))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; Number predicate creators ;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (define (in-range/c a b pred? st? bt? expected)
- (lambda (x)
- (if (and (pred? a) (pred? b))
- (and (bt? x a) (st? x b))
- (raise "error"))))
- (define (between/c a b)
- (in-range/c a b real? <= >= 'real))
- (define (integer-in a b)
- (in-range/c a b integer? <= >= 'integer))
- (define (fixnum-in a b)
- (in-range/c a b fixnum? fx<=? fx>=? 'fixnum))
- (define (flonum-in a b)
- (in-range/c a b flonum? fl<=? fl>=? 'flonum))
- (define (char-in a b)
- (in-range/c a b char? char<=? char>=? 'char))
- (define-syntax define/contract
- (syntax-rules (->)
- [(define/contract (id var ...)
- (-> pred? ... return-pred?) body ...)
- (define (id var ...)
- (define (%INTERNAL_PROC)
- body ...)
- (unless (pred? var) (error define/contract "contract error")) ...
- (let ([%return-value (%INTERNAL_PROC)])
- (if (return-pred? %return-value)
- %return-value
- (error 'define/contract "contract error"))))])))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement