Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/MiscUtil/util/errormsg.nw
ViewVC logotype

Annotation of /sml/trunk/src/compiler/MiscUtil/util/errormsg.nw

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 <<errormsg.sig>>=
2 :     (* Copyright 1989 by AT&T Bell Laboratories *)
3 :     signature ERRORMSG =
4 :     sig
5 :     datatype severity = WARN | COMPLAIN
6 :     type complainer (* = severity -> string -> (PrettyPrint.ppstream -> unit)
7 :     -> unit *)
8 :     type errorFn = SourceMap.region -> complainer
9 :     type errors (* = {error: errorFn,
10 :     errorMatch: region->string,
11 :     anyErrors : bool ref} *)
12 :     val anyErrors : errors -> bool
13 :     exception Error
14 :     val defaultConsumer : unit -> PrettyPrint.ppconsumer
15 :     val nullErrorBody : PrettyPrint.ppstream -> unit
16 :     val error : Source.inputSource -> SourceMap.region -> complainer
17 :     val errorNoFile : PrettyPrint.ppconsumer * bool ref -> SourceMap.region
18 :     -> complainer
19 :    
20 :     val matchErrorString : Source.inputSource -> SourceMap.region -> string
21 :     val errors : Source.inputSource -> errors
22 :     val errorsNoFile : PrettyPrint.ppconsumer * bool ref -> errors
23 :    
24 :     val impossible : string -> 'a
25 :     val impossibleWithBody : string -> (PrettyPrint.ppstream -> unit) -> 'a
26 :     end
27 :     @
28 :     <<errormsg.sml>>=
29 :     (* Copyright 1989 by AT&T Bell Laboratories *)
30 :    
31 :     structure ErrorMsg : ERRORMSG =
32 :     struct
33 :    
34 :     open PrettyPrint SourceMap
35 :    
36 :     (* error reporting *)
37 :    
38 :     exception Error (* was Syntax, changed to Error in 0.92 *)
39 :    
40 :     datatype severity = WARN | COMPLAIN
41 :    
42 :     type complainer = severity -> string -> (ppstream -> unit) -> unit
43 :    
44 :     type errorFn = region -> complainer
45 :    
46 :     type errors = {error: region->complainer,
47 :     errorMatch: region->string,
48 :     anyErrors: bool ref}
49 :    
50 :     fun defaultConsumer () =
51 :     {consumer = Control.Print.say,
52 :     linewidth = !Control.Print.linewidth,
53 :     flush = Control.Print.flush}
54 :    
55 :     val nullErrorBody = (fn (ppstrm: ppstream) => ())
56 :    
57 :     fun ppmsg(errConsumer,location,severity,msg,body) =
58 :     with_pp errConsumer (fn ppstrm =>
59 :     (begin_block ppstrm CONSISTENT 0;
60 :     begin_block ppstrm CONSISTENT 2;
61 :     add_string ppstrm location;
62 :     add_string ppstrm (* print error label *)
63 :     (case severity
64 :     of WARN => " Warning: "
65 :     | COMPLAIN => " Error: ");
66 :     add_string ppstrm msg;
67 :     body ppstrm;
68 :     end_block ppstrm;
69 :     add_newline ppstrm;
70 :     end_block ppstrm))
71 :    
72 :     fun record(COMPLAIN,anyErrors) = anyErrors := true
73 :     | record(WARN,_) = ()
74 :    
75 :     fun impossible msg =
76 :     (app Control.Print.say ["Error: Compiler bug: ",msg,"\n"];
77 :     Control.Print.flush();
78 :     raise Error)
79 :     @
80 :     With the advent of source-map resynchronization (a.k.a
81 :     [[(*#line...*)]]), a contiguous region as seen by the compiler can
82 :     correspond to one or more contiguous regions in source code.
83 :     We can imagine myriad ways of displaying such information, but we
84 :     confine ourselves to two:
85 :     \begin{itemize}
86 :     \item
87 :     When there's just one source region, we have what we had in the old
88 :     compiler, and we display it the same way:
89 :     \begin{quote}
90 :     {\tt \emph{name}:\emph{line}.\emph{col}} or\\
91 :     {\tt \emph{name}:\emph{line1}.\emph{col1}-\emph{line2}.\emph{col2}}
92 :     \end{quote}
93 :     \item
94 :     When there are two or more source regions, we use an ellipsis instead
95 :     of a dash, and if not all regions are from the same file, we provide
96 :     the file names of both endpoints (even if the endpoints are the same
97 :     file).
98 :     \end{itemize}
99 :     <<errormsg.sml>>=
100 :     fun location_string ({sourceMap,fileOpened,...}:Source.inputSource) (p1,p2) =
101 :     let fun shortpoint ({line, column,...}:sourceloc, l) =
102 :     Int.toString line :: "." :: Int.toString column :: l
103 :     fun showpoint (p as {fileName,...}:sourceloc, l) =
104 :     Pathnames.trim fileName :: ":" :: shortpoint (p, l)
105 :     fun allfiles(f, (src:sourceloc, _)::l) =
106 :     f = #fileName src andalso allfiles(f, l)
107 :     | allfiles(f, []) = true
108 :     fun lastpos [(_, hi)] = hi
109 :     | lastpos (h::t) = lastpos t
110 :     | lastpos [] = impossible "lastpos botch in ErrorMsg.location_string"
111 :     in concat (
112 :     case fileregion sourceMap (p1, p2)
113 :     of [(lo, hi)] =>
114 :     if p1+1 >= p2 then showpoint (lo, [])
115 :     else showpoint(lo, "-" :: shortpoint(hi, []))
116 :     | (lo, _) :: rest =>
117 :     if allfiles(#fileName lo, rest) then
118 :     showpoint(lo, "..." :: shortpoint(lastpos rest, []))
119 :     else
120 :     showpoint(lo, "..." :: showpoint (lastpos rest, []))
121 :     | [] => [Pathnames.trim fileOpened, ":<nullRegion>"]
122 :     )
123 :     end
124 :     @ Emulating my predecessors, I've gone to some trouble to avoid list appends (and the
125 :     corresponding allocations).
126 :     <<errormsg.sml>>=
127 :     fun error (source as {anyErrors, errConsumer,...}: Source.inputSource)
128 :     (p1:int,p2:int) (severity:severity)
129 :     (msg: string) (body : ppstream -> unit) =
130 :     (ppmsg(errConsumer,(location_string source (p1,p2)),severity,msg,body);
131 :     record(severity,anyErrors))
132 :    
133 :     fun errorNoFile (errConsumer,anyErrors) ((p1,p2): region) severity msg body =
134 :     (ppmsg(errConsumer,
135 :     if p2>0 then concat[Int.toString p1, "-", Int.toString p2]
136 :     else "",
137 :     severity, msg, body);
138 :     record(severity,anyErrors))
139 :    
140 :     fun impossibleWithBody msg body =
141 :     (with_pp (defaultConsumer()) (fn ppstrm =>
142 :     (add_string ppstrm "Error: Compiler bug: ";
143 :     add_string ppstrm msg;
144 :     body ppstrm;
145 :     add_newline ppstrm));
146 :     raise Error)
147 :    
148 :     val matchErrorString = location_string
149 :    
150 :     fun errors source =
151 :     {error = error source,
152 :     errorMatch = matchErrorString source,
153 :     anyErrors = #anyErrors source}
154 :    
155 :     fun anyErrors{anyErrors,error,errorMatch} = !anyErrors
156 :    
157 :     fun errorsNoFile (consumer,any) =
158 :     {error = errorNoFile (consumer,any),
159 :     errorMatch = fn _ => "Match",
160 :     anyErrors = any}
161 :    
162 :     end (* structure ErrorMsg *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0