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

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

Rel 1.3.0

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