source: project/release/4/check-errors/trunk/type-errors.scm @ 15588

Last change on this file since 15588 was 15588, checked in by Kon Lovett, 10 years ago

Added 'make-error-type-message' & fixed 'define-check+error-type'.

File size: 2.8 KB
Line 
1;;;; type-errors.scm
2;;;; Kon Lovett, Apr '09
3
4;;;
5
6(module type-errors (;export
7  ;;
8  error-argument-type
9  make-error-type-message
10  ;;
11  error-fixnum
12  error-positive-fixnum
13  error-cardinal-fixnum
14  error-flonum
15  error-integer
16  error-positive-integer
17  error-cardinal-integer
18  error-number
19  error-positive-number
20  error-cardinal-number
21  error-procedure
22  error-input-port
23  error-output-port
24  error-list
25  error-pair
26  error-blob
27  error-vector
28  error-structure
29  error-symbol
30  error-keyword
31  error-string
32  error-char
33  error-boolean
34  ;;
35  (define-error-type error-argument-type))
36
37(import scheme chicken (only data-structures ->string conc))
38
39(declare
40  (usual-integrations)
41  (fixnum)
42  (inline)
43  (local)
44  (no-procedure-checks)
45  (no-bound-checks)
46  (constant
47    vowel?)
48  (bound-to-procedure
49    ##sys#signal-hook) )
50
51;;;
52
53;;
54
55(define (vowel? ch) (and (memq ch '(#\a #\e #\i #\o #\u)) #t))
56
57(define (make-error-type-message kndnam #!optional argnam)
58  (let ((kndnam (->string kndnam)))
59    (conc
60      "bad"
61      #\space (if argnam (conc #\` argnam #\' #\space) "")
62      "argument type - not"
63      #\space (if (vowel? (string-ref kndnam 0)) "an" "a")
64      #\space kndnam) ) )
65
66(define (error-argument-type loc obj kndnam #!optional argnam)
67  (##sys#signal-hook #:type-error loc (make-error-type-message kndnam argnam) obj) )
68
69;;
70
71; <symbol>          : <msg> is "<symbol>"
72; <symbol> <string> : <msg> is <string>
73; ->
74; (define (error-<symbol> loc obj #!optional argnam)
75;   (error-argument-type loc obj <msg> argnam) )
76
77(define-syntax define-error-type
78  (lambda (form r c)
79    (let (($define (r 'define))
80          ($#!optional (r '#!optional))
81          ($error-argument-type (r 'error-argument-type)) )
82      (let* ((typ (cadr form))
83             (typstr (symbol->string typ))
84             (msg (if (null? (cddr form)) typstr (caddr form)))
85             (nam (string->symbol (string-append "error-" typstr))) )
86        `(,$define (,nam loc obj ,$#!optional argnam)
87           (,$error-argument-type loc obj ,msg argnam) ) ) ) ) )
88
89;;
90
91(define-error-type fixnum)
92(define-error-type positive-fixnum)
93(define-error-type cardinal-fixnum)
94(define-error-type flonum)
95(define-error-type integer)
96(define-error-type positive-integer)
97(define-error-type cardinal-integer)
98(define-error-type number)
99(define-error-type positive-number)
100(define-error-type cardinal-number)
101(define-error-type procedure)
102(define-error-type input-port)
103(define-error-type output-port)
104(define-error-type list)
105(define-error-type pair)
106(define-error-type blob)
107(define-error-type vector)
108(define-error-type symbol)
109(define-error-type keyword)
110(define-error-type string)
111(define-error-type char)
112(define-error-type boolean)
113
114(define (error-structure loc obj tag #!optional argnam)
115        (error-argument-type loc obj (conc "structure" #\space tag) argnam) )
116
117) ;module type-errors
Note: See TracBrowser for help on using the repository browser.