Diff of /sml/trunk/src/cm/stable/stabilize.sml

Parent Directory | Revision Log | Patch

	revision 310, Wed Jun 2 07:28:27 1999 UTC	revision 311, Wed Jun 2 09:08:48 1999 UTC
#	Line 9	Line 9
9	structure DG = DependencyGraph	structure DG = DependencyGraph
10	structure GG = GroupGraph	structure GG = GroupGraph
11	structure EM = GenericVC.ErrorMsg	structure EM = GenericVC.ErrorMsg
12		structure PP = PrettyPrint
13		structure SM = GenericVC.SourceMap
14	structure GP = GeneralParams	structure GP = GeneralParams
15	structure E = GenericVC.Environment	structure E = GenericVC.Environment
16
17	type statenvgetter = GP.info -> DG.bnode -> E.staticEnv	type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
18		type recomp = GG.group * GP.info -> bool
19	in	in
20
21	signature STABILIZE = sig	signature STABILIZE = sig
#	Line 22	Line 25
25	AbsPath.t -> GG.group option	AbsPath.t -> GG.group option
26
27	val stabilize :	val stabilize :
28	GP.info ->	GP.info -> { group: GG.group, anyerrors: bool ref } ->
	{ group: GG.group, gpath: AbsPath.t, anyerrors: bool ref } ->
29	GG.group option	GG.group option
30	end	end
31
32	functor StabilizeFn (val bn2statenv : statenvgetter) :> STABILIZE = struct	functor StabilizeFn (val bn2statenv : statenvgetter
33		val recomp: recomp) :> STABILIZE = struct
34
35	datatype pitem =	datatype pitem =
36	PSS of SymbolSet.set	PSS of SymbolSet.set
#	Line 77	Line 80
80	handle e as Interrupt.Interrupt => raise e	handle e as Interrupt.Interrupt => raise e
81	| _ => ()	| _ => ()
82
83	fun stabilize gp { group = g as GG.GROUP grec, gpath, anyerrors } =	fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
	case #stableinfo grec of
	GG.STABLE _ => SOME g
	| GG.NONSTABLE granted => let
84
85		fun doit granted = let
86	val bname = AbsPath.name o SmlInfo.binpath	val bname = AbsPath.name o SmlInfo.binpath
87	val bsz = OS.FileSys.fileSize o bname	val bsz = OS.FileSys.fileSize o bname
88	fun cpb s i = let	fun cpb s i = let
#	Line 99	Line 100
100
101	val exports = #exports grec	val exports = #exports grec
102	val islib = #islib grec	val islib = #islib grec
103	val required = StringSet.difference (#required grec,	val required = StringSet.difference (#required grec, granted)
	granted)
104	val grouppath = #grouppath grec	val grouppath = #grouppath grec
105	val subgroups = #subgroups grec	val subgroups = #subgroups grec
106
#	Line 194	Line 194
194	fun esc #"\\" = "\\\\"	fun esc #"\\" = "\\\\"
195	| esc #"\"" = "\\\""	| esc #"\"" = "\\\""
196	| esc c = String.str c	| esc c = String.str c
197	in	in
198	String.translate esc s :: "\"" :: k m	String.translate esc s :: "\"" :: k m
199	end	end
#	Line 216	Line 215
215
216	fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m	fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
217
218	fun w_abspath_raw p k m =	fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m
	w_list w_string (AbsPath.pickle p) k m
219
220	val w_abspath = w_share w_abspath_raw PAP	val w_abspath = w_share w_abspath_raw PAP
221
#	Line 252	Line 250
250	fun k0 m = []	fun k0 m = []
251	val m0 = (0, Map.empty)	val m0 = (0, Map.empty)
252	in	in
253	concat	concat (w_exports exports
	(w_exports exports
254	(w_bool islib	(w_bool islib
255	(w_privileges required	(w_privileges required
256	(w_list w_sg subgroups k0))) m0)	(w_list w_sg subgroups k0))) m0)
#	Line 318	Line 315
315	val memberlist = rev (!members)	val memberlist = rev (!members)
316
317	val policy = #fnpolicy (#param gp)	val policy = #fnpolicy (#param gp)
318		val gpath = #grouppath grec
319	val spath = FilenamePolicy.mkStablePath policy gpath	val spath = FilenamePolicy.mkStablePath policy gpath
320	fun delete () = deleteFile (AbsPath.name spath)	fun delete () = deleteFile (AbsPath.name spath)
321	val outs = AbsPath.openBinOut spath	val outs = AbsPath.openBinOut spath
#	Line 336	Line 334
334	raise e)	raise e)
335	| exn => (BinIO.closeOut outs; NONE)	| exn => (BinIO.closeOut outs; NONE)
336	end	end
337		in
338		case #stableinfo grec of
339		GG.STABLE _ => SOME g
340		| GG.NONSTABLE granted =>
341		if not (recomp (g, gp)) then
342		(anyerrors := true; NONE)
343		else let
344		fun notStable (GG.GROUP { stableinfo, ... }) =
345		case stableinfo of
346		GG.STABLE _ => false
347		| GG.NONSTABLE _ => true
348		in
349		case List.filter notStable (#subgroups grec) of
350		[] => doit granted
351		| l => let
352		val grammar = case l of [_] => " is" | _ => "s are"
353		fun ppb pps = let
354		fun loop [] = ()
355		| loop (GG.GROUP { grouppath, ... } :: t) =
356		(PP.add_string pps
357		(AbsPath.name grouppath);
358		PP.add_newline pps;
359		loop t)
360		in
361		PP.add_newline pps;
362		PP.add_string pps
363		(concat ["because the following sub-group",
364		grammar, " not stable:"]);
365		PP.add_newline pps;
366		loop l
367		end
368		val errcons = #errcons gp
369		val gname = AbsPath.name (#grouppath grec)
370		in
371		EM.errorNoFile (errcons, anyerrors) SM.nullRegion
372		EM.COMPLAIN
373		(gname ^ " cannot be stabilized")
374		ppb;
375		NONE
376		end
377		end
378		end
379
380	fun loadStable (gp, getGroup, anyerrors) group = let	fun loadStable (gp, getGroup, anyerrors) group = let
381
382	fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)	fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
383
384	val grpSrcInfo = (#errcons gp, anyerrors)	val errcons = #errcons gp
385		val grpSrcInfo = (errcons, anyerrors)
386		val gname = AbsPath.name group
387		fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
388		EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody
389
390	exception Format	exception Format
391
392	val policy = #fnpolicy (#param gp)	val policy = #fnpolicy (#param gp)
393	val spath = FilenamePolicy.mkStablePath policy group	val spath = FilenamePolicy.mkStablePath policy group
394	val _ = Say.vsay ["[checking stable ", AbsPath.name group, "]\n"]	val _ = Say.vsay ["[checking stable ", gname, "]\n"]
395	val s = AbsPath.openBinIn spath	val s = AbsPath.openBinIn spath
396
397	fun getGroup' p =	fun getGroup' p =
398	case getGroup p of	case getGroup p of
399	SOME g => g	SOME g => g
400	| NONE => raise Format	| NONE =>
401		(error ["unable to find ", AbsPath.name p];
402		raise Format)
403
404	(* for getting sharing right... *)	(* for getting sharing right... *)
405	val m = ref IntBinaryMap.empty	val m = ref IntBinaryMap.empty

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.310   changed lines   Added in v.311

---

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