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/sourcemap.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/MiscUtil/util/sourcemap.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 93 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/MiscUtil/util/sourcemap.sml

1 : monnier 16 (* I can imagine at least three implementations: one that doesn't *)
2 :     (* support resynchronization, one that supports resynchronization only at *)
3 :     (* column 1, and one that supports arbitrary resynchronization. *)
4 :     (* *)
5 :     (* *)
6 :     (* \section{Implementation} *)
7 :     (* This implementation supports arbitary resynchronization. *)
8 :     (* *)
9 :     (* <sourcemap.sml>= *)
10 :     (* sourcemap.sml *)
11 :     (* <RCS log>= *)
12 :     (*
13 :     * changed ErrorMsg to use SourceMap to get source locations; only the
14 :     * formatting is done internally
15 :     *
16 :     * added SourceMap structure
17 :     *
18 :     * .sig and .sml for sourcemap, source, and errormsg are derived from .nw
19 :     * files. to extract, try
20 :     * for base in sourcemap source errormsg
21 :     * do
22 :     * for suffix in sml sig
23 :     * do
24 :     * $cmd -L'(*#line %L "%F"*)' -R$base.$suffix $base.nw > $base.$suffix
25 :     * done
26 :     * done
27 :     * where
28 :     * cmd=notangle
29 :     * or
30 :     * cmd="nountangle -ml"
31 :     *
32 :     * At some point, it may be desirable to move noweb support into CM
33 :     * *)
34 :     structure SourceMap : SOURCE_MAP = struct
35 :     (* A character position is an integer. A region is delimited by the *)
36 :     (* position of the start character and one beyond the end. *)
37 :     (* It might help to think of Icon-style positions, which fall between *)
38 :     (* characters. *)
39 :     (* *)
40 :     (* <toplevel>= *)
41 :     type charpos = int
42 :     type 'a pair = 'a * 'a
43 :     type region = charpos pair
44 :     val nullRegion : region = (0,0)
45 :     type sourceloc = {fileName:string, line:int, column:int}
46 :     (* The empty region is conventional. *)
47 :     (* *)
48 :     (* <toplevel>= *)
49 :     fun span ((0,0), r) = r
50 :     | span (r, (0,0)) = r
51 :     | span ((l1, h1), (l2, h2)) = if l1 < h2 then (l1, h2) else (l2, h1)
52 :     (* The representation is a pair of lists. *)
53 :     (* [[linePos]] records line numbers for newlines \emph{and} *)
54 :     (* resynchronization. *)
55 :     (* [[resynchPos]] records file name and column for resynchronization. *)
56 :     (* The representation satisfies these invariants: *)
57 :     (* \begin{itemize} *)
58 :     (* \item *)
59 :     (* The lists are never empty (initialization is treated as a resynchronization). *)
60 :     (* \item *)
61 :     (* Positions decrease as we walk down the lists. *)
62 :     (* \item *)
63 :     (* The last element in each list contains the smallest valid position. *)
64 :     (* \item *)
65 :     (* For every element in [[resynchPos]], there is a corresponding element in *)
66 :     (* [[linePos]] with the same position. *)
67 :     (* \end{itemize} *)
68 :     (* We could get even more clever and store file names only when they *)
69 :     (* differ, but it doesn't seem worth it---we would have to get very *)
70 :     (* clever about tracking column numbers and resynchronizations. *)
71 :     (* *)
72 :     (* <toplevel>= *)
73 :     type sourcemap = {resynchPos: (charpos * string * int) list ref,
74 :     linePos: (charpos * int) list ref}
75 :    
76 :     fun newmap (pos, {fileName, line, column}: sourceloc) : sourcemap =
77 :     {resynchPos = ref [(pos, fileName, column)], linePos = ref [(pos, line)]}
78 :    
79 :     fun resynch ({resynchPos, linePos}: sourcemap) (pos, {fileName, line, column}) =
80 :     let val curFile = #2 (hd (!resynchPos))
81 :     fun thefile (SOME file) = if file = curFile then curFile else file
82 :     (* pathetic attempt at hash-consing *)
83 :     | thefile NONE = #2 (hd (!resynchPos))
84 :     fun thecol NONE = 1
85 :     | thecol (SOME c) = c
86 :     in resynchPos := (pos, thefile fileName, thecol column) :: !resynchPos;
87 :     linePos := (pos, line) :: !linePos
88 :     end
89 :     (* Since [[pos]] is the position of the newline, the next line doesn't *)
90 :     (* start until the succeeding position. *)
91 :     (* *)
92 :     (* <toplevel>= *)
93 :     fun newline ({resynchPos, linePos}: sourcemap) pos =
94 :     let val (_, line) = hd (!linePos)
95 :     in linePos := (pos+1, line+1) :: !linePos
96 :     end
97 :    
98 :     fun lastChange({linePos, ...}: sourcemap) = #1 (hd (!linePos))
99 :     (* A generally useful thing to do is to remove from the lists the initial *)
100 :     (* sequences of tuples *)
101 :     (* whose positions satisfy some predicate: *)
102 :     (* *)
103 :     (* <toplevel>= *)
104 :     fun remove p ({resynchPos,linePos}: sourcemap) =
105 :     let fun strip (l as (pos, _ )::rest) = if p pos then strip rest else l
106 :     | strip [] = []
107 :     fun strip'(l as (pos, _, _)::rest) = if p pos then strip' rest else l
108 :     | strip'[] = []
109 :     in (strip'(!resynchPos), strip (!linePos))
110 :     end
111 :     (* We find file and line number by linear search. *)
112 :     (* The first position less than [[p]] is what we want. *)
113 :     (* The initial column depends on whether we resynchronized. *)
114 :     (* *)
115 :     (* <toplevel>= *)
116 :     fun column ((pos, file, col), (pos', line), p) =
117 :     if pos = pos' then p - pos + col else p - pos' + 1
118 :    
119 :     fun filepos smap p : sourceloc =
120 :     let val (files, lines) = remove (fn pos : int => pos > p) smap
121 :     val xx as (_, file, _) = hd files
122 :     val yy as (_, line) = hd lines
123 :     in {fileName = file, line = line, column = column(xx, yy, p)}
124 :     end
125 :     (* Searching regions is a bit trickier, since we track file and line *)
126 :     (* simultaneously. We exploit the invariant that every file entry has a *)
127 :     (* corresponding line entry. *)
128 :     (* We also exploit that only file entries correspond to new regions. *)
129 :     (* *)
130 :     (* <toplevel>= *)
131 :     fun fileregion smap (lo, hi) =
132 :     if (lo,hi) = nullRegion then [] else
133 :     let exception Impossible
134 :     fun gather((p, file, col)::files, (p', line)::lines, region_end, answers) =
135 :     if p' <= lo then (* last item *)
136 :     ({fileName=file, line=line, column=column((p, file, col), (p', line), lo)},
137 :     region_end) :: answers
138 :     else
139 :     if p < p' then
140 :     gather((p, file, col)::files, lines, region_end, answers)
141 :     else (* p = p'; new region *)
142 :     gather(files, lines, end_of (p, hd files, hd lines),
143 :     ({fileName = file, line = line, column = col}, region_end) :: answers)
144 :     | gather _ = raise Impossible
145 :     and end_of(lastpos, xx as (p, file, col), yy as (p', line)) =
146 :     {fileName=file, line=line, column=column(xx, yy, lastpos)}
147 :     val (files, lines) = remove (fn pos : int => pos >= hi andalso pos > lo) smap
148 :     val _ = if null files orelse null lines then raise Impossible else ()
149 :     val answer = gather(files, lines, end_of(hi, hd files, hd lines), [])
150 :     fun validate(({fileName=f, line=l, column=c},
151 :     {fileName=f', line=l', column=c'}) :: rest) =
152 :     if f = f' andalso (l' > l orelse (l' = l andalso c' >= c)) then
153 :     validate rest
154 :     else
155 :     raise Impossible
156 :     | validate [] = ()
157 :     in validate answer; answer
158 :     end
159 :     (* [[validate]] checks the invariant that single regions occupy a *)
160 :     (* single source file and that coordinates are nondecreasing. *)
161 :     (* We have to be careful not to remove the entry for [[lo]] when *)
162 :     (* [[pos = hi = lo]]. *)
163 :     (* *)
164 :     (* *)
165 :     (* *)
166 :     (* <toplevel>= *)
167 :     fun positions({resynchPos,linePos}: sourcemap) (src:sourceloc) =
168 :     let exception Unimplemented
169 :     in raise Unimplemented
170 :     end
171 :     (* When discarding old positions, we have to be careful to maintain the *)
172 :     (* last part of the invariant. *)
173 :     (* *)
174 :     (* <toplevel>= *)
175 :     fun forgetOldPositions ({resynchPos, linePos} : sourcemap) =
176 :     let val r as (p, file, col) = hd (!resynchPos)
177 :     val l as (p', line) = hd (!linePos)
178 :     in linePos := [l];
179 :     resynchPos := [if p = p' then r else (p', file, 1)]
180 :     end
181 :     (* <toplevel>= *)
182 :     fun newlineCount smap (lo, hi) =
183 :     let val (hifiles, hilines) = remove (fn pos : int => pos >= hi andalso pos > lo) smap
184 :     val (lofiles, lolines) = remove (fn pos : int => pos > lo) smap
185 :     in length hilines - length hifiles - (length lolines - length lofiles)
186 :     end
187 :     end
188 :    
189 :     (*
190 :     * $Log: sourcemap.sml,v $
191 : monnier 93 * Revision 1.1.1.1 1998/04/08 18:39:16 george
192 :     * Version 110.5
193 : monnier 16 *
194 :     *)

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