Annotation of /sml/trunk/src/cm/bootstrap/mkprimperv.sml

Parent Directory | Revision Log

---

Revision 325 - (view) (download)

1 :	blume	325	functor MkPrimPervFn (structure MachDepVC: MACHDEP_VC) = struct
2 :	blume	324
3 :	blume	325	structure E = GenericVC.Environment
4 :	blume	324	structure S = GenericVC.Source
5 :			structure EM = GenericVC.ErrorMsg
6 :			structure SM = GenericVC.SourceMap
7 :	blume	325	structure BF = MachDepVC.Binfile
8 :			structure DE = GenericVC.DynamicEnv
9 :	blume	324
10 :			fun mk (gp: GeneralParams.info) specgroup = let
11 :			val context = AbsPath.relativeContext (AbsPath.dir specgroup)
12 :			val specname = AbsPath.name specgroup
13 :			val stream = TextIO.openIn specname
14 :			val errcons = #errcons gp
15 :			val source = S.newSource (specname, 1, stream, false, errcons)
16 :			val sourceMap = #sourceMap source
17 :
18 :			val _ = GroupReg.register (#groupreg gp) (specgroup, source)
19 :
20 :			fun error r m = EM.error source r EM.COMPLAIN m EM.nullErrorBody
21 :
22 :			fun lineIn pos = let
23 :			val line = TextIO.inputLine stream
24 :			val len = size line
25 :			val newpos = pos + len
26 :			val _ = GenericVC.SourceMap.newline sourceMap newpos
27 :			fun sep c = Char.isSpace c orelse Char.contains "(),=;" c
28 :			in
29 :			if line = "" then NONE
30 :			else if String.sub (line, 0) = #"#" then SOME ([], newpos)
31 :			else SOME (String.tokens sep line, newpos)
32 :			end
33 :
34 :	blume	325	local
35 :			val boguspid = GenericVC.PersStamps.fromBytes
36 :			(Byte.stringToBytes "0123456789abcdef")
37 :			in
38 :			fun bogus n = { name = n, env = GenericVC.Environment.emptyEnv,
39 :			pidInfo = { statpid = boguspid, sympid = boguspid,
40 :			ctxt = GenericVC.CMStaticEnv.empty } }
41 :			end
42 :	blume	324
43 :			fun loop (split, m, fl, pos) =
44 :			case lineIn pos of
45 :			NONE => (error (pos, pos) "unexpected end of file"; NONE)
46 :			| SOME (line, newpos) => let
47 :			val error = error (pos, newpos)
48 :			fun look n =
49 :			case StringMap.find (m, n) of
50 :			SOME x => x
51 :			| NONE => (error ("undefined: " ^ n); bogus n)
52 :			fun sml spec = let
53 :			val sourcepath = AbsPath.standard (#pcmode (#param gp))
54 :			{ context = context, spec = spec }
55 :			in
56 :			SmlInfo.info gp { sourcepath = sourcepath,
57 :			group = (specgroup, (pos, newpos)),
58 :			share = NONE }
59 :			end
60 :
61 :			fun report n = let
62 :			val outfile =
63 :			AbsPath.name (SmlInfo.binpath (sml n)) ^ ".PID"
64 :			val s = TextIO.openOut outfile
65 :			val p = #statpid (#pidInfo (look n))
66 :			in
67 :			TextIO.output (s, GenericVC.PersStamps.toHex p ^ "\n");
68 :			TextIO.closeOut s
69 :			end
70 :
71 :	blume	325	fun compile (name, file, args) = let
72 :			fun one (arg, e) = E.layerEnv (#env (look arg), e)
73 :			val ctxt = foldl one E.emptyEnv args
74 :			val bfc = Dummy.f ()
75 :			val pi = { statpid = BF.staticPidOf bfc,
76 :			sympid = BF.lambdaPidOf bfc,
77 :			ctxt = E.staticPart ctxt }
78 :			val env = E.mkenv { static = BF.senvOf bfc,
79 :			symbolic = BF.symenvOf bfc,
80 :			dynamic = DE.empty }
81 :			val pspec = { name = name, env = env, pidInfo = pi }
82 :			in
83 :			StringMap.insert (m, name, pspec)
84 :			end
85 :	blume	324	in
86 :			case line of
87 :			[] => loop (split, m, fl, newpos)
88 :			| ["split"] => loop (true, m, fl, newpos)
89 :			| ["nosplit"] => loop (false, m, fl, newpos)
90 :			| ["reportPid", name] =>
91 :			(report name;
92 :			loop (split, m, fl, newpos))
93 :			| ("let" :: name :: file :: args) =>
94 :			loop (split, compile (name, file, args),
95 :			file :: fl, newpos)
96 :			| ("return" :: core :: pervasive :: primitives) =>
97 :			SOME { core = #env (look core),
98 :			pervasive = #env (look pervasive),
99 :			primitives = foldr
100 :			(fn (n, l) => look n :: l)
101 :			[] primitives }
102 :			| _ => (error "malformed line"; NONE)
103 :			end
104 :			in
105 :			loop (false, StringMap.empty, [], 2) (* consistent with ml-lex bug? *)
106 :			end
107 :			end

---

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