suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

svn: r7982

Browse Source
This commit is contained in:
Matthias Felleisen 2007-12-12 23:41:46 +00:00
parent 75b2415a96
commit cc4d5cfdc1
1 changed files with 71 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/htdp/error.ss
View File

@ -1,27 +1,34 @@
#cs(module error mzscheme #lang mzscheme
(require (lib "etc.ss") (lib "list.ss"))
;; --------------------------------------------------------------------------
(provide check-arg check-arity check-proc check-result check-list-list find-non
tp-exn? number->ord)
;; (_ -> Boolean) (listof X) -> (union X false) (require (lib "etc.ss")
(define (find-non pred? l) (lib "list.ss"))
;; --------------------------------------------------------------------------
(provide check-arg check-arity check-proc check-result check-list-list
natural?
find-non tp-exn? number->ord)
(define (natural? w)
(and (number? w) (integer? w) (>= w 0)))
;; (_ -> Boolean) (listof X) -> (union X false)
(define (find-non pred? l)
(let ([r (filter (compose not pred?) l)]) (let ([r (filter (compose not pred?) l)])
(if (null? r) #f (car r)))) (if (null? r) #f (car r))))
#| Tests ------------------------------------------------------------------ #| Tests ------------------------------------------------------------------
(not (find-non list? '((1 2 3) (a b c)))) (not (find-non list? '((1 2 3) (a b c))))
(symbol? (find-non number? '(1 2 3 a))) (symbol? (find-non number? '(1 2 3 a)))
(symbol? (find-non list? '((1 2 3) a (b c)))) (symbol? (find-non list? '((1 2 3) a (b c))))
|# |#
(define-struct (tp-exn exn) ()) (define-struct (tp-exn exn) ())
(define (tp-error name fmt . args) (define (tp-error name fmt . args)
(raise (make-tp-exn (string-append (format "~a: " name) (apply format fmt args)) (raise (make-tp-exn (string-append (format "~a: " name) (apply format fmt args))
(current-continuation-marks)))) (current-continuation-marks))))
(define (number->ord i) (define (number->ord i)
(if (= i 0) (if (= i 0)
"zeroth" "zeroth"
(case (modulo i 10) (case (modulo i 10)
@ -30,13 +37,13 @@
[(2) (format "~and" i)] [(2) (format "~and" i)]
[(3) (format "~ard" i)]))) [(3) (format "~ard" i)])))
;; Symbol (union true String) String X -> void ;; Symbol (union true String) String X -> void
(define (check-list-list pname condition pred given) (define (check-list-list pname condition pred given)
(when (string? condition) (when (string? condition)
(tp-error pname (string-append condition (format "~nin ~e" given))))) (tp-error pname (string-append condition (format "~nin ~e" given)))))
;; Symbol (_ -> Boolean) String X X *-> X ;; Symbol (_ -> Boolean) String X X *-> X
(define (check-result pname pred? expected given . other-given) (define (check-result pname pred? expected given . other-given)
(if (pred? given) (if (pred? given)
given given
(tp-error pname "result of type <~a> expected, given: ~a" expected (tp-error pname "result of type <~a> expected, given: ~a" expected
@ -44,21 +51,21 @@
(car other-given) (car other-given)
given)))) given))))
;; check-arg : sym bool str str TST -> void ;; check-arg : sym bool str str TST -> void
(define (check-arg pname condition expected arg-posn given) (define (check-arg pname condition expected arg-posn given)
(unless condition (unless condition
(tp-error pname "expected <~a> as ~a argument, given: ~e" (tp-error pname "expected <~a> as ~a argument, given: ~e"
expected arg-posn given))) expected arg-posn given)))
;; check-arity : sym num (list-of TST) -> void ;; check-arity : sym num (list-of TST) -> void
(define (check-arity name arg# args) (define (check-arity name arg# args)
(if (= (length args) arg#) (if (= (length args) arg#)
(void) (void)
(tp-error name "expects ~a arguments, given ~e" arg# (length args)))) (tp-error name "expects ~a arguments, given ~e" arg# (length args))))
;; check-proc : ;; check-proc :
;; sym (... *->* ...) num (union sym str) (union sym str) -> void ;; sym (... *->* ...) num (union sym str) (union sym str) -> void
(define (check-proc proc f exp-arity arg# arg-err) (define (check-proc proc f exp-arity arg# arg-err)
(unless (procedure? f) (unless (procedure? f)
(tp-error proc "procedure expected as ~s argument; given ~e" arg# f)) (tp-error proc "procedure expected as ~s argument; given ~e" arg# f))
(unless (procedure-arity-includes? f exp-arity) (unless (procedure-arity-includes? f exp-arity)
@ -71,4 +78,4 @@
(format "1 argument") (format "1 argument")
(format "~s arguments" arity-of-f))] (format "~s arguments" arity-of-f))]
[(arity-at-least? arity-of-f) (format "at least ~s arguments" (arity-at-least-value arity-of-f))] [(arity-at-least? arity-of-f) (format "at least ~s arguments" (arity-at-least-value arity-of-f))]
[else (format "multiple arities (~s)" arity-of-f)])))))) [else (format "multiple arities (~s)" arity-of-f)])))))