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

Parent Directory | Revision Log

---

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

---

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