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

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

Rmvd extra space.

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