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

Last change on this file since 36582 was 36582, checked in by kon, 3 months ago

restore lib-like error messages

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