source: project/release/5/check-errors/trunk/type-errors-basic.impl.scm @ 36557

Last change on this file since 36557 was 36557, checked in by Kon Lovett, 17 months ago

rational import appropriation

File size: 3.7 KB
Line 
1;;;; type-errors-basic.impl.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4;; Issues
5;;
6;; - The type error message is built so as to look like those of the Chicken
7;; "core". This constraint necessarily means some knowledge of the use of the
8;; indefinite article. So any I18N effort will either have some logic needed or
9;; a change to the Chicken "core" form.
10;;
11;; Maybe "... not an integer" -> "... integer required" &
12;; "... not a list" -> "... list required".
13
14(import scheme)
15
16;;;
17
18;;
19
20(define (->boolean x)
21  (and x #t) )
22
23;;;
24
25;;
26
27(define (make-bad-argument-message #!optional argnam)
28  (if (not argnam)
29    "bad argument"
30    (conc "bad " #\` argnam #\' " argument") ) )
31
32(define (make-type-name-message typnam)
33  (or
34    (localized-type-name-message typnam)
35    (->string typnam)) )
36
37(define (make-error-type-message typnam #!optional argnam)
38  (string-append
39    (make-bad-argument-message argnam)
40    " type - not "
41    (make-type-name-message typnam)) )
42
43;;
44
45(define (signal-bounds-error loc . objs)
46  (apply ##sys#signal-hook #:bounds-error loc objs) )
47
48(define (signal-type-error loc . objs)
49  (apply ##sys#signal-hook #:type-error loc objs) )
50
51;;
52
53(define (error-argument-type loc obj typnam #!optional argnam)
54  (signal-type-error loc (make-error-type-message typnam argnam) obj) )
55
56;;
57
58(define (warning-argument-type loc obj typnam #!optional argnam)
59  (let* (
60    (typmsg (make-error-type-message typnam argnam))
61    (locmsg (if loc (string-append (location-message loc) " ") ""))
62    (wrn-msg (conc locmsg typmsg ": " obj)) )
63    (warning wrn-msg) ) )
64
65(define (location-message loc)
66  (conc #\( loc #\)) )
67
68;;
69
70; <symbol>          : <typnam> is "<symbol>"
71; <symbol> <string> : <typnam> is <string>
72; ->
73; (define (error-<symbol> loc obj #!optional argnam)
74;   (error-argument-type loc obj <typnam> argnam) )
75
76(define-syntax define-error-type
77  (er-macro-transformer
78    (lambda (frm rnm cmp)
79      (let (
80        (_define (rnm 'define))
81        (_#!optional (rnm '#!optional))
82        (_error-argument-type (rnm 'error-argument-type)) )
83        (let* (
84          (typ (cadr frm))
85          (typstr (symbol->string typ))
86          (typnam (if (null? (cddr frm)) typstr (caddr frm)))
87          (nam (string->symbol (string-append "error-" typstr))) )
88          `(,_define (,nam loc obj ,_#!optional argnam)
89             (,_error-argument-type loc obj ,typnam argnam) ) ) ) ) ) )
90
91;;
92
93(define (error-bound-value loc obj tag #!optional argnam)
94        (error-argument-type loc "#<unbound>" "bound-value" argnam) )
95
96(define (error-defined-value loc obj tag #!optional argnam)
97        (error-argument-type loc "#<unspecified>" "defined-value" argnam) )
98
99(define (error-minimum-argument-count loc argc minargc)
100  (##sys#signal-hook #:arity-error loc
101    (conc "too few arguments - received " argc " but expected " minargc))
102  #; ;int & foreign-value unrecognized, & foreign is imported
103  (##sys#error-hook
104    (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int)
105    loc
106    minargc argc #f) )
107
108(define (error-argument-count loc argc maxargc)
109  (##sys#signal-hook #:arity-error loc
110    (conc "bad argument count - received " argc " but expected " maxargc))
111  #; ;int & foreign-value unrecognized, & foreign is imported
112  (##sys#error-hook
113    (foreign-value "C_BAD_ARGUMENT_COUNT_ERROR" int)
114    loc
115    maxargc argc #f) )
116
117;;;
118
119;;
120
121(define (localized-type-name-message typnam)
122  ;FIXME en only
123  (conc (appropriate-indefinite-article typnam) " " typnam) )
124
125;;
126
127(define +english-vowels+ '(#\a #\e #\i #\o #\u))
128(define +english-indefinite-articles+ '(an a))
129
130(define (vowel? ch)
131  (->boolean (memq ch +english-vowels+)) )
132
133(define (appropriate-indefinite-article wrd)
134  (let ((s (->string wrd)))
135    (if (vowel? (string-ref s 0))
136      (car +english-indefinite-articles+)
137      (cadr +english-indefinite-articles+) ) ) )
Note: See TracBrowser for help on using the repository browser.