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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1140 - (view) (download)

1 : blume 275 (*
2 : blume 296 * Convert ASTs to CM's trimmed version thereof ("skeletons").
3 : blume 275 *
4 : blume 286 * Copyright (c) 1999 by Lucent Technologies, Bell Laboratories
5 : blume 296 *
6 :     * The ideas here are based on those found in the original SC and
7 :     * also in an older version of CM (before 1999). However, nearly
8 :     * all aspects have been changed radically, and the code has been
9 :     * re-written from scratch.
10 :     *
11 :     * The skeletons generated by this module are typically smaller
12 :     * than the "decl"s in SC or old versions of CM. This should
13 :     * make dependency analysis somewhat faster (but is probably not
14 :     * very noticeable).
15 :     *
16 :     * author: Matthias Blume (blume@cs.princeton.edu)
17 :     *
18 :     * The copyright notices of the earlier versions are:
19 : blume 275 * Copyright (c) 1995 by AT&T Bell Laboratories
20 :     * Copyright (c) 1993 by Carnegie Mellon University,
21 :     * School of Computer Science
22 :     * contact: Gene Rollins (rollins+@cs.cmu.edu)
23 :     *)
24 :     signature SKELCVT = sig
25 : blume 879 val convert : { tree: Ast.dec,
26 :     err: ErrorMsg.severity -> Ast.region -> string -> unit }
27 : blume 281 -> { skeleton : Skeleton.decl, complain : unit -> unit }
28 : blume 275 end
29 :    
30 :     structure SkelCvt :> SKELCVT = struct
31 :    
32 : blume 879 open Ast Skeleton
33 : blume 275
34 : blume 278 structure S = Symbol
35 : blume 879 structure SP = SymPath
36 : blume 275 structure SS = SymbolSet
37 : blume 879 structure EM = ErrorMsg
38 : blume 275
39 : blume 278 type symbol = Symbol.symbol
40 : blume 275 type path = symbol list
41 :    
42 : blume 296 (* The main idea is to collect lists of decl ("dl"s).
43 :     * Normally, a dl will eventually become an argument to seq or par.
44 :     * As an important optimization, we always try to keep any "Ref s"
45 :     * at the front (but we don't try too hard and only do it where
46 :     * it is reasonably convenient). *)
47 :    
48 : blume 293 (* function composition suitable for fold[lr]-arguments *)
49 : blume 286 infix o'
50 :     fun (f o' g) (x, y) = f (g x, y)
51 : blume 275
52 : blume 293 (* add the head of a symbol path to a given set *)
53 :     fun s_addP ([], set) = set
54 :     | s_addP (head :: _, set) = SS.add (set, head)
55 :    
56 :     (* same as s_addP except we ignore paths of length 1 because they
57 :     * do not involve module access. *)
58 : blume 291 fun s_addMP ([], set) = set (* can this happen at all? *)
59 :     | s_addMP ([only], set) = set (* no module name here *)
60 :     | s_addMP (head :: _, set) = SS.add (set, head)
61 : blume 275
62 : blume 291 (* add a reference to a symbol to a dl *)
63 :     fun dl_addSym (sy, []) = [Ref (SS.singleton sy)]
64 :     | dl_addSym (sy, Ref s :: dl) = Ref (SS.add (s, sy)) :: dl
65 :     | dl_addSym (sy, dl) = Ref (SS.singleton sy) :: dl
66 : blume 275
67 : blume 291 (* add the first element of a path to a dl *)
68 :     fun dl_addP ([], d) = d
69 :     | dl_addP (head :: _, d) = dl_addSym (head, d)
70 :    
71 :     (* add the first element of a path to a dl -- except if that element is
72 :     * the only one on the path*)
73 :     fun dl_addMP ([], dl) = dl
74 :     | dl_addMP ([only], dl) = dl
75 :     | dl_addMP (head :: _, dl) = dl_addSym (head, dl)
76 :    
77 : blume 286 (* given a set of module references, add it to a decl list *)
78 : blume 293 fun dl_addS (s, dl) =
79 :     if SS.isEmpty s then dl
80 :     else case dl of
81 : blume 286 [] => [Ref s]
82 : blume 293 | Ref s' :: dl' => Ref (SS.union (s, s')) :: dl'
83 :     | _ => Ref s :: dl
84 : blume 275
85 : blume 296 (* make a Seq node when necessary *)
86 :     fun seq [] = Ref SS.empty
87 :     | seq [only] = only
88 :     | seq l = Seq l
89 :    
90 :     (* make a Par node when necessary and stick it in front of a given dl *)
91 :     fun parcons ([], d) = d
92 :     | parcons ([only], d) = only :: d
93 :     | parcons (l, d) = Par l :: d
94 :    
95 :     (* Given a "bind list", stick a parallel Bind in front of a given dl.
96 :     * While doing so, if a Ref occured at the front of the dl, move it
97 :     * past the bind list (shrinking it appropriately). *)
98 :     fun parbindcons (bl, Ref s :: d) = let
99 :     val bs = SS.addList (SS.empty, map #1 bl)
100 :     in
101 :     dl_addS (SS.difference (s, bs), parcons (map Bind bl, d))
102 :     end
103 :     | parbindcons (bl, d) = parcons (map Bind bl, d)
104 :    
105 : blume 291 (* split initial ref set from a decl list *)
106 :     fun split_dl [] = (SS.empty, [])
107 :     | split_dl (Ref s :: d) = (s, d)
108 :     | split_dl d = (SS.empty, d)
109 : blume 275
110 : blume 291 (* join two definition sequences *)
111 :     fun join_dl ([], d) = d
112 :     | join_dl ([Ref s], d) = dl_addS (s, d)
113 :     | join_dl (h :: t, d) = h :: join_dl (t, d)
114 : blume 275
115 : blume 291 (* local definitions *)
116 :     fun local_dl ([], b, d) = join_dl (b, d)
117 :     | local_dl (Ref s :: t, b, d) = dl_addS (s, local_dl (t, b, d))
118 : blume 293 | local_dl (l, b, d) = Local (seq l, seq b) :: d
119 : blume 275
120 : blume 291 (* build a let expression *)
121 :     fun letexp (dl, (s, e)) =
122 :     case split_dl dl of
123 :     (s', []) => (SS.union (s', s), e)
124 :     | (s', dl') => let
125 :     val dl'' = if SS.isEmpty s then dl'
126 :     else rev (dl_addS (s, rev dl'))
127 :     in
128 : blume 293 (s', Let (dl'', e))
129 : blume 291 end
130 : blume 275
131 : blume 293 (* making an Ign1 where necessary ... *)
132 : blume 291 fun ign (p1, NONE) = p1
133 :     | ign ((s1, e1), SOME (s2, e2)) = (SS.union (s1, s2), Ign1 (e1, e2))
134 : blume 275
135 : blume 293 (* Open cancels Decl *)
136 :     fun open' (Decl dl, dl') = join_dl (dl, dl')
137 :     | open' (e, dl) = Open e :: dl
138 :    
139 : blume 291 (* generate a set of "parallel" bindings *)
140 :     fun parbind f l d = let
141 :     val (s, bl) = foldl f (SS.empty, []) l
142 :     in
143 : blume 296 dl_addS (s, parbindcons (bl, d))
144 : blume 291 end
145 : blume 275
146 : blume 291 (* get the ref set from a type *)
147 :     fun ty_s (VarTy _, set) = set
148 :     | ty_s (ConTy (cn, l), set) = s_addMP (cn, foldl ty_s set l)
149 :     | ty_s (RecordTy l, set) = foldl (ty_s o' #2) set l
150 :     | ty_s (TupleTy l, set) = foldl ty_s set l
151 :     | ty_s (MarkTy (arg, _), set) = ty_s (arg, set)
152 : blume 275
153 : blume 291 (* ... from a type option *)
154 :     fun tyopt_s (NONE, set) = set
155 :     | tyopt_s (SOME t, set) = ty_s (t, set)
156 : blume 275
157 : blume 291 (* ... from a pattern *)
158 :     fun pat_s (VarPat p, set) = s_addMP (p, set)
159 :     | pat_s (RecordPat { def, ... }, set) = foldl (pat_s o' #2) set def
160 :     | pat_s ((ListPat l | TuplePat l | VectorPat l | OrPat l), set) =
161 :     foldl pat_s set l
162 :     | pat_s (FlatAppPat l, set) = foldl (pat_s o' #item) set l
163 :     | pat_s (AppPat { constr, argument }, set) =
164 :     pat_s (constr, pat_s (argument, set))
165 :     | pat_s (ConstraintPat { pattern, constraint }, set) =
166 :     pat_s (pattern, ty_s (constraint, set))
167 :     | pat_s (LayeredPat { varPat, expPat }, set) =
168 :     pat_s (varPat, pat_s (expPat, set))
169 :     | pat_s (MarkPat (arg, _), set) = pat_s (arg, set)
170 :     | pat_s ((WildPat|IntPat _|WordPat _|StringPat _|CharPat _), set) = set
171 : blume 275
172 : blume 291 (* ... from an exception binding *)
173 :     fun eb_s (EbGen { exn, etype }, set) = tyopt_s (etype, set)
174 :     | eb_s (EbDef { exn, edef }, set) = s_addMP (edef, set)
175 :     | eb_s (MarkEb (arg, _), set) = eb_s (arg, set)
176 : blume 275
177 : blume 291 (* ... *)
178 :     fun dbrhs_s (Constrs l, set) = foldl (tyopt_s o' #2) set l
179 :     | dbrhs_s (Repl cn, set) = s_addMP (cn, set)
180 : blume 275
181 : blume 291 fun db_s (Db { tyc, tyvars, rhs, lazyp }, set) = dbrhs_s (rhs, set)
182 :     | db_s (MarkDb (arg, _), set) = db_s (arg, set)
183 : blume 275
184 : blume 291 fun tb_s (Tb { tyc, def, tyvars }, set) = ty_s (def, set)
185 :     | tb_s (MarkTb (arg, _), set) = tb_s (arg, set)
186 : blume 275
187 : blume 291 (* get a dl from an expression... *)
188 :     fun exp_dl (VarExp p, d) = dl_addMP (p, d)
189 :     | exp_dl (FnExp rl, d) = foldr rule_dl d rl
190 :     | exp_dl (FlatAppExp l, d) = foldr (exp_dl o' #item) d l
191 :     | exp_dl (AppExp { function, argument }, d) =
192 :     exp_dl (function, exp_dl (argument, d))
193 :     | exp_dl (CaseExp { expr, rules }, d) =
194 :     exp_dl (expr, foldr rule_dl d rules)
195 :     | exp_dl (LetExp { dec, expr }, d) =
196 :     local_dl (dec_dl (dec, []), exp_dl (expr, []), d)
197 :     | exp_dl ((SeqExp l | ListExp l | TupleExp l | VectorExp l), d) =
198 :     foldl exp_dl d l
199 :     | exp_dl (RecordExp l, d) = foldl (exp_dl o' #2) d l
200 :     | exp_dl (SelectorExp _, d) = d
201 :     | exp_dl (ConstraintExp { expr, constraint }, d) =
202 :     dl_addS (ty_s (constraint, SS.empty), exp_dl (expr, d))
203 :     | exp_dl (HandleExp { expr, rules }, d) =
204 :     exp_dl (expr, foldl rule_dl d rules)
205 :     | exp_dl (RaiseExp e, d) = exp_dl (e, d)
206 :     | exp_dl (IfExp { test, thenCase, elseCase }, d) =
207 :     exp_dl (test, exp_dl (thenCase, exp_dl (elseCase, d)))
208 :     | exp_dl ((AndalsoExp (e1, e2) | OrelseExp (e1, e2)), d) =
209 :     exp_dl (e1, exp_dl (e2, d))
210 :     | exp_dl (WhileExp { test, expr }, d) = exp_dl (test, exp_dl (expr, d))
211 :     | exp_dl (MarkExp (arg, _), d) = exp_dl (arg, d)
212 :     | exp_dl ((IntExp _|WordExp _|RealExp _|StringExp _|CharExp _), d) = d
213 : blume 275
214 : blume 291 and rule_dl (Rule { pat, exp }, d) =
215 :     dl_addS (pat_s (pat, SS.empty), exp_dl (exp, d))
216 : blume 275
217 : blume 291 and clause_dl (Clause { pats = p, resultty = t, exp = e }, d) =
218 :     dl_addS (foldl (pat_s o' #item) (tyopt_s (t, SS.empty)) p,
219 :     exp_dl (e, d))
220 :    
221 :     and fb_dl (Fb (l, _), d) = foldr clause_dl d l
222 :     | fb_dl (MarkFb (arg, _), d) = fb_dl (arg, d)
223 :    
224 :     and vb_dl (Vb { pat, exp, lazyp }, d) =
225 :     dl_addS (pat_s (pat, SS.empty), exp_dl (exp, d))
226 :     | vb_dl (MarkVb (arg, _), d) = vb_dl (arg, d)
227 :    
228 :     and rvb_dl (Rvb { var, exp, resultty, ... }, d) =
229 :     dl_addS (tyopt_s (resultty, SS.empty), exp_dl (exp, d))
230 :     | rvb_dl (MarkRvb (arg, _), d) = rvb_dl (arg, d)
231 :    
232 :     and spec_dl (MarkSpec (arg, _), d) = spec_dl (arg, d)
233 :     | spec_dl (StrSpec l, d) = let
234 : blume 293 (* strange case - optional: structure, mandatory: signature *)
235 : blume 291 fun one ((n, g, c), (s, bl)) = let
236 :     val (s', e) = sigexp_p g
237 :     val s'' = SS.union (s, s')
238 :     in
239 :     case c of
240 : blume 296 NONE => (s'', (n, e) :: bl)
241 :     | SOME p => (s'', (n, Ign1 (Var (SP.SPATH p), e)) :: bl)
242 : blume 291 end
243 :     val (s, bl) = foldr one (SS.empty, []) l
244 : blume 286 in
245 : blume 296 dl_addS (s, parbindcons (bl, d))
246 : blume 286 end
247 : blume 291 | spec_dl (TycSpec (l, _), d) = let
248 :     fun one_s ((_, _, SOME t), s) = ty_s (t, s)
249 :     | one_s (_, s) = s
250 : blume 286 in
251 : blume 291 dl_addS (foldl one_s SS.empty l, d)
252 : blume 286 end
253 : blume 291 | spec_dl (FctSpec l, d) = let
254 :     fun one ((n, g), (s, bl)) = let
255 :     val (s', e) = fsigexp_p g
256 :     in
257 : blume 296 (SS.union (s, s'), (n, e) :: bl)
258 : blume 291 end
259 :     val (s, bl) = foldr one (SS.empty, []) l
260 :     in
261 : blume 296 dl_addS (s, parbindcons (bl, d))
262 : blume 291 end
263 :     | spec_dl (ValSpec l, d) = dl_addS (foldl (ty_s o' #2) SS.empty l, d)
264 :     | spec_dl (DataSpec { datatycs, withtycs }, d) =
265 :     dl_addS (foldl db_s (foldl tb_s SS.empty withtycs) datatycs, d)
266 :     | spec_dl (ExceSpec l, d) = dl_addS (foldl (tyopt_s o' #2) SS.empty l, d)
267 :     | spec_dl (ShareStrSpec l, d) = foldl dl_addP d l
268 :     | spec_dl (ShareTycSpec l, d) = dl_addS (foldl s_addMP SS.empty l, d)
269 :     | spec_dl (IncludeSpec g, d) = let
270 :     val (s, e) = sigexp_p g
271 :     in
272 : blume 293 dl_addS (s, open' (e, d))
273 : blume 291 end
274 : blume 275
275 : blume 291 and sigexp_p (VarSig s) = (SS.empty, Var (SP.SPATH [s]))
276 :     | sigexp_p (AugSig (g, whspecs)) = let
277 :     fun one_s (WhType (_, _, ty), s) = ty_s (ty, s)
278 : blume 293 | one_s (WhStruct (_, p), s) = s_addP (p, s)
279 : blume 291 val (s, e) = sigexp_p g
280 :     in
281 :     (foldl one_s s whspecs, e)
282 :     end
283 :     | sigexp_p (BaseSig l) = let
284 :     val (s, d) = split_dl (foldr spec_dl [] l)
285 :     in
286 : blume 293 (s, Decl d)
287 : blume 291 end
288 :     | sigexp_p (MarkSig (arg, _)) = sigexp_p arg
289 : blume 275
290 : blume 291 and fsigexp_p (VarFsig s) = (SS.empty, Var (SP.SPATH [s]))
291 :     | fsigexp_p (BaseFsig { param, result }) =
292 :     letexp (foldr fparam_d [] param, sigexp_p result)
293 :     | fsigexp_p (MarkFsig (arg, _)) = fsigexp_p arg
294 : blume 275
295 : blume 291 and fparam_d ((nopt, g), d) = let
296 :     val (s, e) = sigexp_p g
297 :     in
298 :     case nopt of
299 : blume 293 NONE => dl_addS (s, open' (e, d))
300 : blume 291 | SOME n => dl_addS (s, Bind (n, e) :: d)
301 :     end
302 : blume 275
303 : blume 291 and sigexpc_p NoSig = NONE
304 :     | sigexpc_p (Transparent g | Opaque g) = SOME (sigexp_p g)
305 : blume 275
306 : blume 291 and fsigexpc_p NoSig = NONE
307 :     | fsigexpc_p (Transparent fg | Opaque fg) = SOME (fsigexp_p fg)
308 : blume 275
309 : blume 291 and fctexp_p (VarFct (p, c)) =
310 :     ign ((SS.empty, Var (SP.SPATH p)), fsigexpc_p c)
311 :     | fctexp_p (BaseFct { params, body, constraint }) =
312 :     letexp (foldr fparam_d [] params,
313 :     ign (strexp_p body, sigexpc_p constraint))
314 :     | fctexp_p (AppFct (p, l, c)) = let
315 :     fun one ((str, _), (s, el)) = let
316 :     val (s', e) = strexp_p str
317 :     in
318 :     (SS.union (s, s'), e :: el)
319 :     end
320 :     val (s, el) = foldl one (SS.empty, []) l
321 :     val (s', e) = ign ((SS.empty, Var (SP.SPATH p)), fsigexpc_p c)
322 :     in
323 :     (SS.union (s, s'), foldl Ign1 e el)
324 :     end
325 :     | fctexp_p (LetFct (bdg, b)) = letexp (dec_dl (bdg, []), fctexp_p b)
326 :     | fctexp_p (MarkFct (arg, _)) = fctexp_p arg
327 : blume 275
328 : blume 291 and strexp_p (VarStr p) = (SS.empty, Var (SP.SPATH p))
329 :     | strexp_p (BaseStr dec) = let
330 :     val (s, dl) = split_dl (dec_dl (dec, []))
331 :     in
332 : blume 293 (s, Decl dl)
333 : blume 291 end
334 :     | strexp_p (ConstrainedStr (s, c)) = ign (strexp_p s, sigexpc_p c)
335 :     | strexp_p (AppStr (p, l) | AppStrI (p, l)) = let
336 :     fun one ((str, _), (s, el)) = let
337 :     val (s', e) = strexp_p str
338 :     in
339 :     (SS.union (s, s'), e :: el)
340 :     end
341 :     val (s, el) = foldl one (SS.empty, []) l
342 :     in
343 :     (s, foldl Ign1 (Var (SP.SPATH p)) el)
344 :     end
345 :     | strexp_p (LetStr (bdg, b)) = letexp (dec_dl (bdg, []), strexp_p b)
346 :     | strexp_p (MarkStr (s, _)) = strexp_p s
347 : blume 275
348 : blume 291 and dec_dl (ValDec (l, _), d) = foldl vb_dl d l
349 :     | dec_dl (ValrecDec (l, _), d) = foldl rvb_dl d l
350 :     | dec_dl (FunDec (l, _), d) = foldl fb_dl d l
351 :     | dec_dl (TypeDec l, d) = dl_addS (foldl tb_s SS.empty l, d)
352 :     | dec_dl (DatatypeDec { datatycs, withtycs }, d) =
353 :     dl_addS (foldl db_s (foldl tb_s SS.empty withtycs) datatycs, d)
354 :     | dec_dl (AbstypeDec { abstycs, withtycs, body }, d) =
355 :     dl_addS (foldl db_s (foldl tb_s SS.empty withtycs) abstycs,
356 :     dec_dl (body, d))
357 :     | dec_dl (ExceptionDec l, d) = dl_addS (foldl eb_s SS.empty l, d)
358 :     | dec_dl ((StrDec l | AbsDec l), d) = let
359 :     fun one (MarkStrb (arg, _), x) = one (arg, x)
360 :     | one (Strb { name, def, constraint }, (s, bl)) = let
361 :     val (s', e) = ign (strexp_p def, sigexpc_p constraint)
362 :     in
363 : blume 296 (SS.union (s, s'), (name, e) :: bl)
364 : blume 291 end
365 :     in
366 :     parbind one l d
367 :     end
368 :     | dec_dl (FctDec l, d) = let
369 :     fun one (MarkFctb (arg, _), x) = one (arg, x)
370 :     | one (Fctb { name, def }, (s, bl)) = let
371 :     val (s', e) = fctexp_p def
372 :     in
373 : blume 296 (SS.union (s, s'), (name, e) :: bl)
374 : blume 291 end
375 :     in
376 :     parbind one l d
377 :     end
378 :     | dec_dl (SigDec l, d) = let
379 :     fun one (MarkSigb (arg, _), x) = one (arg, x)
380 :     | one (Sigb { name, def }, (s, bl)) = let
381 :     val (s', e) = sigexp_p def
382 :     in
383 : blume 296 (SS.union (s, s'), (name, e) :: bl)
384 : blume 291 end
385 :     in
386 :     parbind one l d
387 :     end
388 :     | dec_dl (FsigDec l, d) = let
389 :     fun one (MarkFsigb (arg, _), x) = one (arg, x)
390 :     | one (Fsigb { name, def }, (s, bl)) = let
391 :     val (s', e) = fsigexp_p def
392 :     in
393 : blume 296 (SS.union (s, s'), (name, e) :: bl)
394 : blume 291 end
395 :     in
396 :     parbind one l d
397 :     end
398 :     | dec_dl (LocalDec (bdg, body), d) =
399 :     local_dl (dec_dl (bdg, []), dec_dl (body, []), d)
400 :     | dec_dl (SeqDec l, d) = foldr dec_dl d l
401 : blume 296 | dec_dl (OpenDec l, d) = parcons (map (Open o Var o SP.SPATH) l, d)
402 : blume 1140 | dec_dl (OvldDec (_, t, l), d) = dl_addS (ty_s (t, SS.empty),
403 :     foldl exp_dl d l)
404 :     | dec_dl (FixDec _, d) = d
405 : blume 291 | dec_dl (MarkDec (arg, _), d) = dec_dl (arg, d)
406 : blume 275
407 : blume 293 fun c_dec d = seq (dec_dl (d, []))
408 : blume 275
409 : blume 281 fun convert { tree, err } = let
410 :     (* build a function that will complain (once you call it)
411 :     * about any existing restriction violations *)
412 : blume 293 fun complainCM reg = let
413 : blume 281 fun sameReg (LocalDec (_, body), k) = sameReg (body, k)
414 :     | sameReg (SeqDec l, k) = foldl sameReg k l
415 :     | sameReg (OpenDec _, k) =
416 :     (fn () => (k (); err EM.COMPLAIN reg "toplevel open"))
417 : blume 293 | sameReg (MarkDec (arg, reg), k) = complainCM reg (arg, k)
418 : blume 281 | sameReg ((StrDec _ | AbsDec _ | FctDec _ | SigDec _ |
419 :     FsigDec _), k) = k
420 :     | sameReg (_, k) =
421 :     (fn () =>
422 :     (k (); err EM.WARN reg "definition not tracked by CM"))
423 :    
424 :     in
425 :     sameReg
426 :     end
427 : blume 293
428 :     fun warn0 () = ()
429 :     val complain = complainCM (0, 0) (tree, warn0)
430 : blume 275 in
431 : blume 293 { complain = complain, skeleton = c_dec tree }
432 : blume 275 end
433 :     end

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