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 324 - (view) (download)

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

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