source: project/release/4/check-errors/tags/1.4.0/type-errors.scm @ 15735

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

Added 'signal-type-error'

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