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
 [smlnj] / sml / trunk / src / compiler / MiscUtil / util / sourcemap.sml

# Annotation of /sml/trunk/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 : (* = *) 10 : (* sourcemap.sml *) 11 : (* = *) 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 : (* = *) 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 : (* = *) 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 : (* = *) 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 : (* = *) 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 : (* = *) 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 : (* = *) 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 : (* = *) 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 : (* = *) 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 : (* = *) 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 : (* = *) 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 : *)