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/bootstrap/mkprimperv.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log 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