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/cm/smlfile/skel-io.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/smlfile/skel-io.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 275 - (view) (download)

1 : blume 275 (*
2 :     * Reading and writing skeletons to skeleton files.
3 :     *
4 :     * (C) 1999 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 :     signature SKELIO = sig
9 :     exception InternalError
10 :     val read : AbsPath.t * TStamp.t -> Skeleton.decl option
11 :     val write : AbsPath.t * Skeleton.decl -> unit
12 :     end
13 :    
14 :     structure SkelIO :> SKELIO = struct
15 :    
16 :     structure SK = Skeleton
17 :     structure SS = SymbolSet
18 :     structure S = GenericVC.Symbol
19 :     structure SP = GenericVC.SymPath
20 :    
21 :     exception InternalError
22 :     exception FormatError
23 :    
24 :     val s2b = Byte.stringToBytes
25 :     val b2c = Byte.byteToChar
26 :    
27 :     val version = "Decl 9\n"
28 :    
29 :     fun makeset l = SS.addList (SS.empty, l)
30 :    
31 :     fun inputLine s = let
32 :     fun finish acc = String.implode (rev acc)
33 :     fun loop acc =
34 :     case Option.map b2c (BinIO.input1 s) of
35 :     NONE => finish (#"\n" :: acc)
36 :     | SOME #"\n" => finish (#"\n" :: acc)
37 :     | SOME c => loop (c :: acc)
38 :     in
39 :     loop []
40 :     end
41 :    
42 :     fun write_decl (s, d) = let
43 :    
44 :     (* We are consing up the whole output as a list of strings
45 :     * before concatenating it to form the final result and
46 :     * wrinting it out using one single `output' call. *)
47 :     fun w_name (n, r) = let
48 :     val ns = S.nameSpace n
49 :     val prefix =
50 :     case ns of
51 :     S.STRspace => "#"
52 :     | S.SIGspace => "$"
53 :     | S.FCTspace => "%"
54 :     | S.FSIGspace => "&"
55 :     | _ => raise InternalError
56 :     in
57 :     prefix :: S.name n :: "." :: r
58 :     end
59 :    
60 :     fun w_list w (l, r) = foldr w (";" :: r) l
61 :    
62 :     fun w_path (SP.SPATH p, r) = w_list w_name (p, r)
63 :    
64 :     fun w_option w (NONE, r) = "-" :: r
65 :     | w_option w (SOME x, r) = "+" :: w (x, r)
66 :    
67 :     fun w_decl (SK.StrDecl l, r) =
68 :     let
69 :     fun w_item ({ name, def, constraint }, r) =
70 :     w_name (name,
71 :     w_strExp (def,
72 :     w_option w_strExp (constraint, r)))
73 :     in
74 :     "s" :: w_list w_item (l, r)
75 :     end
76 :     | w_decl (SK.FctDecl l, r) = let
77 :     fun w_item ({ name, def }, r) =
78 :     w_name (name, w_fctExp (def, r))
79 :     in
80 :     "f" :: w_list w_item (l, r)
81 :     end
82 :     | w_decl (SK.LocalDecl (x, y), r) = "l" :: w_decl (x, w_decl (y, r))
83 :     | w_decl (SK.SeqDecl l, r) = "q" :: w_list w_decl (l, r)
84 :     | w_decl (SK.OpenDecl l, r) = "o" :: w_list w_strExp (l, r)
85 :     | w_decl (SK.DeclRef s, r) = "r" :: w_list w_name (SS.listItems s, r)
86 :    
87 :     and w_strExp (SK.VarStrExp p, r) = "v" :: w_path (p, r)
88 :     | w_strExp (SK.BaseStrExp d, r) = "s" :: w_decl (d, r)
89 :     | w_strExp (SK.AppStrExp (p, l), r) =
90 :     "a" :: w_path (p, w_list w_strExp (l, r))
91 :     | w_strExp (SK.LetStrExp (d, se), r) =
92 :     "l" :: w_decl (d, w_strExp (se, r))
93 :     | w_strExp (SK.AugStrExp (se, s), r) =
94 :     "g" :: w_strExp (se, w_list w_name (SS.listItems s, r))
95 :     | w_strExp (SK.ConStrExp (s1, s2), r) =
96 :     "c" :: w_strExp (s1, w_strExp(s2, r))
97 :    
98 :     and w_fctExp (SK.VarFctExp (p, fe), r) =
99 :     "v" :: w_path (p, w_option w_fctExp (fe, r))
100 :     | w_fctExp (SK.BaseFctExp { params, body, constraint }, r) = let
101 :     fun w_item ((mn, se), r) =
102 :     w_option w_name (mn, w_strExp (se, r))
103 :     in
104 :     "f" ::
105 :     w_list w_item (params,
106 :     w_strExp (body,
107 :     w_option w_strExp (constraint, r)))
108 :     end
109 :     | w_fctExp (SK.AppFctExp (p, sel, feo), r) =
110 :     "a" ::
111 :     w_path (p, w_list w_strExp (sel, w_option w_fctExp (feo, r)))
112 :     | w_fctExp (SK.LetFctExp (d, fe), r) =
113 :     "l" :: w_decl (d, w_fctExp (fe, r))
114 :    
115 :     in
116 :     BinIO.output (s, s2b (concat (version :: w_decl (d, ["\n"]))))
117 :     end
118 :    
119 :     fun read_decl s = let
120 :    
121 :     fun rd () = Option.map b2c (BinIO.input1 s)
122 :    
123 :     local
124 :     fun get (ns, first) = let
125 :     fun loop (accu, NONE) = raise FormatError
126 :     | loop ([], SOME #".") = raise FormatError
127 :     | loop (accu, SOME #".") = ns (String.implode (rev accu))
128 :     | loop (accu, SOME s) = loop (s :: accu, rd ())
129 :     in
130 :     loop ([], first)
131 :     end
132 :     in
133 :     fun r_name (SOME #"#") = get (S.strSymbol, rd ())
134 :     | r_name (SOME #"$") = get (S.sigSymbol, rd ())
135 :     | r_name (SOME #"%") = get (S.fctSymbol, rd ())
136 :     | r_name (SOME #"&") = get (S.fsigSymbol, rd ())
137 :     | r_name _ = raise FormatError
138 :     end
139 :    
140 :     fun r_list r = let
141 :     fun loop (accu, NONE) = raise FormatError
142 :     | loop (accu, SOME #";") = rev accu
143 :     | loop (accu, cur) = loop ((r cur) :: accu, rd ())
144 :     in
145 :     fn first => loop ([], first)
146 :     end
147 :    
148 :     fun r_path first = SP.SPATH (r_list r_name first)
149 :    
150 :     fun r_option r (SOME #"-") = NONE
151 :     | r_option r (SOME #"+") = SOME (r (rd ()))
152 :     | r_option r _ = raise FormatError
153 :    
154 :     fun r_decl (SOME #"s") =
155 :     let
156 :     fun r_item first = {
157 :     name = r_name first,
158 :     def = r_strExp (rd ()),
159 :     constraint = r_option r_strExp (rd ())
160 :     }
161 :     in
162 :     SK.StrDecl (r_list r_item (rd ()))
163 :     end
164 :     | r_decl (SOME #"f") =
165 :     let
166 :     fun r_item first = {
167 :     name = r_name first,
168 :     def = r_fctExp (rd ())
169 :     }
170 :     in
171 :     SK.FctDecl (r_list r_item (rd ()))
172 :     end
173 :     | r_decl (SOME #"l") = SK.LocalDecl (r_decl (rd ()), r_decl (rd ()))
174 :     | r_decl (SOME #"q") = SK.SeqDecl (r_list r_decl (rd ()))
175 :     | r_decl (SOME #"o") = SK.OpenDecl (r_list r_strExp (rd ()))
176 :     | r_decl (SOME #"r") = SK.DeclRef (makeset (r_list r_name(rd ())))
177 :     | r_decl _ = raise FormatError
178 :    
179 :     and r_strExp (SOME #"v") = SK.VarStrExp (r_path (rd ()))
180 :     | r_strExp (SOME #"s") = SK.BaseStrExp (r_decl (rd ()))
181 :     | r_strExp (SOME #"a") =
182 :     SK.AppStrExp (r_path (rd ()), r_list r_strExp (rd ()))
183 :     | r_strExp (SOME #"l") =
184 :     SK.LetStrExp (r_decl (rd ()), r_strExp (rd ()))
185 :     | r_strExp (SOME #"g") =
186 :     SK.AugStrExp (r_strExp (rd ()), makeset (r_list r_name (rd ())))
187 :     | r_strExp (SOME #"c") =
188 :     SK.ConStrExp (r_strExp (rd ()), r_strExp (rd ()))
189 :     | r_strExp _ = raise FormatError
190 :    
191 :     and r_fctExp (SOME #"v") =
192 :     SK.VarFctExp (r_path(rd()), r_option r_fctExp(rd()))
193 :     | r_fctExp (SOME #"f") =
194 :     let
195 :     fun r_param first = (r_option r_name first, r_strExp (rd ()))
196 :     in
197 :     SK.BaseFctExp {
198 :     params = r_list r_param (rd ()),
199 :     body = r_strExp (rd ()),
200 :     constraint = r_option r_strExp (rd ())
201 :     }
202 :     end
203 :     | r_fctExp (SOME #"a") =
204 :     SK.AppFctExp (r_path (rd ()),
205 :     r_list r_strExp (rd ()),
206 :     r_option r_fctExp (rd ()))
207 :     | r_fctExp (SOME #"l") =
208 :     SK.LetFctExp (r_decl (rd ()), r_fctExp (rd ()))
209 :     | r_fctExp _ = raise FormatError
210 :    
211 :     val firstline = inputLine s
212 :     val r = if firstline = version then r_decl (rd ())
213 :     else raise FormatError
214 :     val nl = rd ()
215 :     in
216 :     if nl = SOME #"\n" then r else raise FormatError
217 :     end
218 :    
219 :     fun read (ap, ts) =
220 :     if TStamp.earlier (AbsPath.tstamp ap, ts) then NONE
221 :     else let
222 :     val s = AbsPath.openBinIn ap
223 :     val r = read_decl s
224 :     handle exn => (BinIO.closeIn s; raise exn)
225 :     in
226 :     BinIO.closeIn s; SOME r
227 :     end handle _ => NONE
228 :    
229 :     fun write (ap, sk) = let
230 :     val s = AbsPath.openBinOut Say.vsay ap
231 :     in
232 :     (Interrupt.guarded (fn () => write_decl (s, sk));
233 :     BinIO.closeOut s)
234 :     handle exn => let
235 :     val p = AbsPath.name ap
236 :     in
237 :     BinIO.closeOut s;
238 :     OS.FileSys.remove p handle _ => ();
239 :     Say.say (concat ["[writing ", p, " failed]\n"]);
240 :     raise exn
241 :     end
242 :     end handle Interrupt.Interrupt => raise Interrupt.Interrupt
243 :     | InternalError => raise InternalError
244 :     | _ => ()
245 :     end

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