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/compiler/TopLevel/batch/cmsa.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/TopLevel/batch/cmsa.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 114 - (view) (download)

1 : monnier 45 (* COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies *)
2 :     (* cmsa.sml *)
3 : monnier 16
4 : monnier 106 functor CMSAFun (structure BF : BINFILE
5 : monnier 45 structure C : COMPILE) :> CMSA = struct
6 : monnier 16
7 : monnier 93 structure E = CMEnv.Env
8 : monnier 16 structure P = Control.Print
9 : monnier 45 structure S = Symbol
10 : monnier 16
11 :     type env = E.environment (* environments *)
12 : monnier 45 type sym = S.symbol (* symbols *)
13 : monnier 16
14 :     (* build symbols from strings *)
15 : monnier 45 val STR = S.strSymbol (* structure *)
16 :     val SIG = S.sigSymbol (* signature *)
17 :     val FCT = S.fctSymbol (* functor *)
18 :     val FSIG = S.fsigSymbol (* funsig *)
19 : monnier 16
20 :     (* fetch the pervasive environment *)
21 :     fun pervenv () = #get EnvRef.pervasive ()
22 :    
23 :     (* add a delta to the toplevel environment *)
24 :     fun register e = let
25 :     val tl = EnvRef.topLevel
26 :     val base = #get tl ()
27 : monnier 93 val new = Environment.concatEnv (CMEnv.unCM e, base)
28 : monnier 16 in
29 :     #set tl new
30 :     end
31 :    
32 :     (* build a layered environment from a list of environments;
33 :     * the head of the list goes on top *)
34 :     val layer = foldr E.concatEnv E.emptyEnv
35 :    
36 :    
37 :     (* filter environment by list of symbols *)
38 :     fun filter sl e = E.filterEnv (e, sl)
39 :    
40 :     (* first try loading the binfile (derived from 1st argument);
41 :     * if this fails, then try compiling the source (1st argument);
42 :     * after one of the two steps succeeds run the code *)
43 :     fun run (source, base) = let
44 :     fun loadbin () = let
45 :     val { dir, file } = OS.Path.splitDirFile source
46 :     val cmdir = OS.Path.joinDirFile { dir = dir, file = "CM" }
47 :     val file = file ^ ".bin"
48 :     val oskind =
49 :     case SMLofNJ.SysInfo.getOSKind () of
50 :     SMLofNJ.SysInfo.UNIX => "unix"
51 :     | SMLofNJ.SysInfo.WIN32 => "win32"
52 :     | SMLofNJ.SysInfo.MACOS => "macos"
53 :     | SMLofNJ.SysInfo.OS2 => "os2"
54 :     | SMLofNJ.SysInfo.BEOS => "beos"
55 : monnier 106 val arch'os = concat [C.architecture, "-", oskind]
56 : monnier 16 val archosdir = OS.Path.joinDirFile { dir = cmdir, file = arch'os }
57 :     val bin = OS.Path.joinDirFile { dir = archosdir, file = file }
58 :     val _ = P.say (concat ["Loading: ", bin, "..."])
59 :     val f = BinIO.openIn bin
60 :     fun rest () = let
61 : monnier 106 val bfc = BF.read { name = bin,
62 :     stream = f,
63 :     senv = E.staticPart base,
64 :     keep_code = true }
65 : monnier 16 val _ = BinIO.closeIn f
66 : monnier 45 val _ = P.say "ok - executing..."
67 : monnier 106 val e = BF.exec (bfc, E.dynamicPart base)
68 : monnier 45 val _ = P.say "done\n"
69 :     in
70 :     e
71 :     end
72 : monnier 16 in
73 :     rest () handle e => (BinIO.closeIn f; raise e)
74 :     end
75 :     fun compilesource () = let
76 :     val filename = source
77 :     val _ = P.say (concat ["failed.\n\tTrying to compile ",
78 :     filename, "... "])
79 :     val s = TextIO.openIn filename
80 :     val source = Source.newSource (filename, 1, s, false,
81 :     { linewidth = !P.linewidth,
82 :     flush = P.flush,
83 :     consumer = P.say })
84 :     val ast = C.parse source
85 :     handle exn => (TextIO.closeIn s; raise exn)
86 :     val _ = TextIO.closeIn s
87 :     val errors = ErrorMsg.errors source
88 :     fun check phase =
89 :     if ErrorMsg.anyErrors errors then let
90 :     val msg = phase ^ " failed."
91 :     val _ = P.say msg
92 :     in
93 :     raise C.Compile msg
94 :     end
95 :     else ()
96 :     val corenv = #get EnvRef.core ()
97 : monnier 45 val cinfo = C.mkCompInfo (source, corenv, fn x => x)
98 :    
99 :     val {csegments=code, newstatenv, exportPid, imports,
100 :     inlineExp, ...} =
101 :     C.compile {source=source, ast=ast,
102 :     statenv=E.staticPart base,
103 :     symenv=E.symbolicPart base,
104 :     compInfo=cinfo, checkErr=check,
105 :     runtimePid=NONE, splitting=true}
106 :     val obj = C.mkexec code
107 :     val _ = P.say "ok - executing..."
108 :     val ndenv = C.execute {executable=C.mkexec code,
109 :     imports=imports, exportPid=exportPid,
110 :     dynenv=E.dynamicPart base}
111 :     val _ = P.say "done\n"
112 :     in
113 :     E.mkenv {static=newstatenv, dynamic=ndenv,
114 :     symbolic= C.mksymenv(exportPid, inlineExp)}
115 : monnier 16 end
116 :     in
117 :     loadbin () handle _ => compilesource ()
118 :     end
119 :    
120 : monnier 45 end (* functor CMSAFun *)
121 : monnier 16
122 : monnier 45
123 :    
124 :    
125 :    
126 :    
127 :    
128 :    
129 :    
130 : monnier 93
131 :     (*
132 : monnier 113 * $Log$
133 : monnier 93 *)

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