diff options
Diffstat (limited to 'ebus-racket/3rdparty/bzlib/base/assert.ss')
| -rw-r--r-- | ebus-racket/3rdparty/bzlib/base/assert.ss | 150 |
1 files changed, 150 insertions, 0 deletions
diff --git a/ebus-racket/3rdparty/bzlib/base/assert.ss b/ebus-racket/3rdparty/bzlib/base/assert.ss new file mode 100644 index 0000000..aea9349 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/assert.ss @@ -0,0 +1,150 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; assert.ss - utility for verifying result of the values... +;; yc 1/9/2010 - fixed let/assert! and let*/assert to allow for optional test function +;; yc 2/10/2010 - move listof? to list.ss +(require (for-syntax scheme/base "args.ss") + "base.ss" + (only-in mzlib/etc identity) + (prefix-in c: scheme/contract) + ) + +(define-struct (exn:assert! exn) (test? exp expected actual)) + +(define (error/assert! test? exp expected actual (name 'assert!)) + (raise (make-exn:assert! (if (not expected) + (format "~a assert! (~a ~a); actual ~a" name test? exp actual) + (format "~a assert! (~a ~a ~a); actual ~a" name test? exp expected actual)) + (current-continuation-marks) test? exp expected actual))) + +;; assert! v test? v2 +;; assert! v true? +;; assert! v v2 (use equal for comparison) => we can get rid of this form... +(define-syntax named-assert! + (syntax-rules () + ((~ name exp test? expected) + (let ((actual exp)) + (if (test? actual expected) + actual + (error/assert! 'test? 'exp 'expected actual 'name)))) + ((~ name exp test?) + (let ((actual exp)) + (if (test? actual) + actual + (error/assert! 'test? 'exp #f actual 'name)))) + ((~ name exp) + (named-assert! name exp identity)) + )) + +(define-syntax assert! + (syntax-rules () + ((~ args ...) + (named-assert! assert! args ...)))) + + +(define-syntax let/assert! + (syntax-rules () + ((~ ((id test? arg) ...) exp exp2 ...) + (let/assert! let/assert! ((id test? arg) ...) exp exp2 ...)) + ((~ name ((id test? arg) ...) exp exp2 ...) + (let ((id arg) ...) + (let ((id (named-assert! name id test?)) ...) exp exp2 ...))) + ((~ ((id arg) ...) exp exp2 ...) + (let/assert! let/assert! ((id identity arg) ...) exp exp2 ...)) + ((~ name ((id arg) ...) exp exp2 ...) + (let/assert! name ((id identity arg) ...) exp exp2 ...)) + )) + +(define-syntax let*/assert! + (syntax-rules () + ((~ name () exp exp2 ...) + (begin exp exp2 ...)) + ((~ ((id test? arg) ...) exp exp2 ...) + (let*/assert! let*/assert! ((id test? arg) ...) exp exp2 ...)) + ((~ name ((id test? arg) rest ...) exp exp2 ...) + (let/assert! name ((id test? arg)) + (let*/assert! name (rest ...) exp exp2 ...))) + ((~ ((id arg) ...) exp exp2 ...) + (let*/assert! ((id identity arg) ...) exp exp2 ...)) + ((~ name ((id arg) ...) exp exp2 ...) + (let*/assert! name ((id identity arg) ...) exp exp2 ...)) + )) + +(define-syntax (lambda/assert! stx) + (syntax-case stx () + ((~ name (a1 ... rest-id rest-type) exp exp2 ...) + (and (symbol? (syntax->datum #'name)) + (symbol? (syntax->datum #'rest-id))) + (with-syntax (((arg ...) + (typed-args->args #'(a1 ...))) + ((id ...) + (args->identifiers #'(a1 ...))) + ((type ...) + (typed-args->types #'(a1 ...))) + ) + #'(lambda (arg ... . rest-id) + (let/assert! name ((id type id) ... + (rest-id rest-type rest-id)) + exp exp2 ...)))) + ((~ name (a1 ...) exp exp2 ...) + (symbol? (syntax->datum #'name)) + (with-syntax (((arg ...) + (typed-args->args #'(a1 ...))) + ((id ...) + (args->identifiers #'(a1 ...))) + ((type ...) + (typed-args->types #'(a1 ...))) + ) + #'(lambda (arg ...) ;; this is the general idea.. but this general idea doesn't fully work... + (let/assert! name ((id type id) ...) + exp exp2 ...)))) + ((~ (a1 ...) exp exp2 ...) + #'(~ lambda/assert! (a1 ...) exp exp2 ...)) + )) + +(define-syntax define/assert! + (syntax-rules () + ((~ (name . args) exp exp2 ...) + (define name + (lambda/assert! name args exp exp2 ...))))) + +(provide define/assert! + lambda/assert! + let*/assert! + let/assert! + assert! + named-assert! + ) + +(c:provide/contract + (struct exn:assert! ((message string?) + (continuation-marks continuation-mark-set?) + (test? c:any/c) + (exp c:any/c) + (expected c:any/c) + (actual c:any/c))) + (error/assert! (c:->* (c:any/c c:any/c c:any/c c:any/c) + (symbol?) + c:any)) + ) + +#| +;; if I want to define a contract... with the following form it can become quite complicated!!! + +;; we can also guard the arguments @ regular lamda and also let statement... +;; guarding the arguments... +(define/assert! (foo (a number?) (b number? 5) #:c (c number? 5)) + (+ a b c)) + +(define/assert! (foo2 (a number?) (b number? 10) . (rest (listof? number?))) + (apply + a b rest)) +(let/assert! ((a number? 3) (b number? 'abc)) + (+ a b)) +;;|#
\ No newline at end of file |