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

Annotation of /sml/trunk/src/compiler/MiscUtil/print/pputil.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright 1989 by AT&T Bell Laboratories *)
2 :     (* basics/pputil.sml *)
3 :    
4 :     structure PPUtil : PPUTIL =
5 :     struct
6 :    
7 :     structure S : SYMBOL = Symbol
8 :     structure PP = PrettyPrint
9 :     structure IP = InvPath
10 :     structure SP = SymPath
11 :    
12 :     val pps = PP.add_string
13 :    
14 :     fun ppSequence0 ppstream (sep:PP.ppstream->unit,pr,elems) =
15 :     let fun prElems [el] = pr ppstream el
16 :     | prElems (el::rest) =
17 :     (pr ppstream el;
18 :     sep ppstream;
19 :     prElems rest)
20 :     | prElems [] = ()
21 :     in prElems elems
22 :     end
23 :    
24 :     fun ppSequence ppstream {sep:PP.ppstream->unit, pr:PP.ppstream->'a->unit,
25 :     style:PP.break_style} (elems: 'a list) =
26 :     (PP.begin_block ppstream style 0;
27 :     ppSequence0 ppstream (sep,pr,elems);
28 :     PP.end_block ppstream)
29 :    
30 :     fun ppClosedSequence ppstream{front:PP.ppstream->unit,sep:PP.ppstream->unit,
31 :     back:PP.ppstream->unit,pr:PP.ppstream->'a->unit,
32 :     style:PP.break_style} (elems:'a list) =
33 :     (PP.begin_block ppstream PP.CONSISTENT 0;
34 :     front ppstream;
35 :     PP.begin_block ppstream style 0;
36 :     ppSequence0 ppstream (sep,pr,elems);
37 :     PP.end_block ppstream;
38 :     back ppstream;
39 :     PP.end_block ppstream)
40 :    
41 :     fun ppSym ppstream (s:S.symbol) = PP.add_string ppstream (S.name s)
42 :    
43 :     val stringDepth = Control.Print.stringDepth
44 :    
45 :     (** NOTE: this duplicates code in basics/printutil.sml **)
46 :     fun escape i = let
47 :     val m = Int.toString
48 :     in
49 :     concat ["\\", m(i div 100), m((i div 10)mod 10), m(i mod 10)]
50 :     end
51 :     val offset = Char.ord #"A" - Char.ord #"\^A"
52 :     fun ml_char #"\n" = "\\n"
53 :     | ml_char #"\t" = "\\t"
54 :     | ml_char #"\\" = "\\\\"
55 :     | ml_char #"\"" = "\\\""
56 :     | ml_char c = if ((c >= #"\^A") andalso (c <= #"\^Z"))
57 :     then "\\^" ^ String.str(Char.chr(Char.ord c + offset))
58 :     else if ((#" " <= c) andalso (c <= #"~"))
59 :     then String.str c
60 :     else escape(Char.ord c)
61 :    
62 :     fun mlstr s = concat["\"", concat(map ml_char (explode s)), "\""]
63 :    
64 :     fun pp_mlstr ppstream s =
65 :     let val depth = !stringDepth
66 :     val add_string = PP.add_string ppstream
67 :     fun pr i =
68 :     if i=depth then add_string "#"
69 :     else (let val ch = String.sub(s,i)
70 :     in add_string (ml_char ch); pr (i+1)
71 :     end handle Substring => ())
72 :     in add_string "\""; pr 0; add_string "\""
73 :     end
74 :    
75 :     fun ppvseq ppstream ind (sep:string) pr elems =
76 :     let fun prElems [el] = pr ppstream el
77 :     | prElems (el::rest) = (pr ppstream el;
78 :     PP.add_string ppstream sep;
79 :     PP.add_newline ppstream;
80 :     prElems rest)
81 :     | prElems [] = ()
82 :     in PP.begin_block ppstream PP.CONSISTENT ind;
83 :     prElems elems;
84 :     PP.end_block ppstream
85 :     end
86 :    
87 :     fun ppvlist ppstrm (header,separator,pr_item,items) =
88 :     case items
89 :     of nil => ()
90 :     | first::rest =>
91 :     (PP.add_string ppstrm header;
92 :     pr_item ppstrm first;
93 :     app (fn x => (PP.add_newline ppstrm;
94 :     PP.add_string ppstrm separator;
95 :     pr_item ppstrm x))
96 :     rest)
97 :    
98 :     (* debug print functions *)
99 :     fun ppIntPath ppstream =
100 :     ppClosedSequence ppstream
101 :     {front=(fn pps => PP.add_string pps "["),
102 :     sep=(fn pps => (PP.add_string pps ","; PP.add_break pps (0,0))),
103 :     back=(fn pps => PP.add_string pps "]"),
104 :     style=PP.INCONSISTENT,
105 :     pr=(fn pps => PP.add_string pps o Int.toString)}
106 :    
107 :     fun ppSymPath ppstream (sp: SymPath.path) =
108 :     PP.add_string ppstream (SymPath.toString sp)
109 :    
110 :     fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) =
111 :     ppClosedSequence ppstream
112 :     {front=(fn pps => PP.add_string pps "<"),
113 :     sep=(fn pps => (PP.add_string pps ".")),
114 :     back=(fn pps => PP.add_string pps ">"),
115 :     style=PP.INCONSISTENT,
116 :     pr=ppSym}
117 :     path
118 :    
119 :    
120 :     (* findPath: convert inverse symbolic path names to a printable string in the
121 :     context of an environment.
122 :    
123 :     Its arguments are the inverse symbolic path, a check predicate on static
124 :     semantic values, and a lookup function mapping paths to their bindings
125 :     (if any) in an environment and raising Env.Unbound on paths with no
126 :     binding.
127 :    
128 :     It looks up each suffix of the path name, going from shortest to longest
129 :     suffix, in the current environment until it finds one whose lookup value
130 :     satisfies the check predicate. It then converts that suffix to a string.
131 :     If it doesn't find any suffix, the full path (reversed, i.e. in the
132 :     normal order) and the boolean value false are returned, otherwise the
133 :     suffix and true are returned.
134 :    
135 :     Example:
136 :     Given A.B.t as a path, and a lookup function for an
137 :     environment, this function tries:
138 :     t
139 :     B.t
140 :     A.B.t
141 :     If none of these work, it returns ?.A.B.t
142 :    
143 :     Note: the symbolic path is passed in reverse order because that is
144 :     the way all symbolic path names are stored within static semantic objects.
145 :     *)
146 :    
147 :     val resultId = S.strSymbol "<resultStr>"
148 :     val returnId = S.strSymbol "<returnStr>"
149 :    
150 :     fun findPath (IP.IPATH p: IP.path, check, look): (S.symbol list * bool) =
151 :     let fun try(name::untried,tried) =
152 :     (if (S.eq(name,resultId)) orelse (S.eq(name,returnId))
153 :     then try(untried,tried)
154 :     else
155 :     let val elem = look(SP.SPATH(name :: tried))
156 :     in if check elem
157 :     then (name::tried,true)
158 :     else try(untried,name::tried)
159 :     end handle Env.Unbound => try(untried,name::tried))
160 :     | try([],tried) = (tried, false)
161 :     in try(p,[])
162 :     end
163 :    
164 :    
165 :     fun ppi ppstrm (i:int) = pps ppstrm (Int.toString i)
166 :    
167 :     fun add_comma ppstrm = pps ppstrm ","
168 :    
169 :     fun add_comma_nl ppstrm = (add_comma ppstrm; PP.add_newline ppstrm)
170 :    
171 :     fun nl_indent ppstrm i =
172 :     let val {linewidth,...} = PP.dest_ppstream ppstrm
173 :     in PP.add_break ppstrm (linewidth,i)
174 :     end
175 :    
176 :     fun nl_app ppstrm f =
177 :     let fun g [] = ()
178 :     | g [el] = f ppstrm el
179 :     | g (el::rst) = (f ppstrm el; PP.add_newline ppstrm; g rst)
180 :     in g
181 :     end
182 :    
183 :     fun br_app ppstrm f =
184 :     let fun g [] = ()
185 :     | g [el] = f ppstrm el
186 :     | g (el::rst) = (f ppstrm el; PP.add_break ppstrm (1,0); g rst)
187 :     in g
188 :     end
189 :    
190 :     fun en_pp ppstrm =
191 :     {begin_block = PrettyPrint.begin_block ppstrm,
192 :     end_block = fn () => PrettyPrint.end_block ppstrm,
193 :     pps = PrettyPrint.add_string ppstrm,
194 :     add_break = PrettyPrint.add_break ppstrm,
195 :     add_newline = fn () => PrettyPrint.add_newline ppstrm};
196 :    
197 :     fun ppArray ppstrm (f:PP.ppstream -> 'a -> unit, a:'a array) =
198 :     let val {begin_block,pps,add_break,end_block,...} = en_pp ppstrm
199 :     fun loop i =
200 :     let val elem = Array.sub(a,i)
201 :     in pps (Int.toString i);
202 :     pps ": ";
203 :     f ppstrm elem;
204 :     add_break (1,0);
205 :     loop (i+1)
206 :     end
207 :     in begin_block PP.INCONSISTENT 0;
208 :     loop 0 handle General.Subscript => ();
209 :     end_block()
210 :     end
211 :    
212 :     fun C f x y = f y x;
213 :    
214 :     fun ppTuple ppstrm f =
215 :     ppClosedSequence ppstrm
216 :     {front=C pps "(",
217 :     sep=fn ppstrm => (pps ppstrm ","; PP.add_break ppstrm (0,0)),
218 :     back=C pps ")",
219 :     pr=f, style=PP.INCONSISTENT}
220 :    
221 :    
222 :     end (* structure PPUtil *)
223 :    
224 :     (*
225 :     * $Log: pputil.sml,v $
226 :     * Revision 1.5 1997/11/24 20:30:50 dbm
227 :     * Localize resultId, returnId.
228 :     *
229 :     * Revision 1.4 1997/09/30 02:36:20 dbm
230 :     * Replaced "Symbol.eq" by "S.eq".
231 :     *
232 :     * Revision 1.3 1997/09/24 04:09:28 dbm
233 :     * Corrected comment for findPath.
234 :     *
235 :     * Revision 1.2 1997/09/23 04:04:31 dbm
236 :     * Change definition of findPath for more accurate type path printing.
237 :     *
238 :     * Revision 1.1.1.1 1997/01/14 01:38:44 george
239 :     * Version 109.24
240 :     *
241 :     *)

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