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/branches/SMLNJ/src/compiler/MiscUtil/util/errormsg.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/MiscUtil/util/errormsg.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 245 - (view) (download)

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

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