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/interact/evalloop.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/TopLevel/interact/evalloop.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1058 - (view) (download)

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* evalloop.sml *)
3 :    
4 :     functor EvalLoopF(Compile: TOP_COMPILE) : EVALLOOP =
5 :     struct
6 :    
7 :     local open Environment
8 :     structure C = Compile
9 :     structure EM = ErrorMsg
10 :     structure E = Environment
11 : monnier 47 structure PP = PrettyPrint
12 : monnier 16 structure T = Time
13 :     structure U = Unsafe
14 : monnier 47 structure PC = SMLofNJ.Internals.ProfControl
15 : monnier 16 in
16 :    
17 :     exception Interrupt
18 : monnier 47 type lvar = Access.lvar
19 : monnier 16
20 : blume 905 val compManagerHook : (Ast.dec * EnvRef.envref -> unit) ref = ref (fn _ => ())
21 : monnier 16
22 : blume 905 fun installCompManager cm = compManagerHook := cm
23 : monnier 16
24 :     val say = Control.Print.say
25 :    
26 :     exception EndOfFile
27 :    
28 :     fun interruptable f x =
29 :     let val oldcont = !U.topLevelCont
30 :     in U.topLevelCont :=
31 :     SMLofNJ.Cont.callcc
32 :     (fn k => (SMLofNJ.Cont.callcc(fn k' => (SMLofNJ.Cont.throw k k'));
33 :     raise Interrupt));
34 :     (f x before U.topLevelCont := oldcont)
35 :     handle e => (U.topLevelCont := oldcont; raise e)
36 :     end
37 :    
38 :     (*
39 :     * The baseEnv and localEnv are purposely refs so that a top-level command
40 :     * can re-assign either one of them, and the next iteration of the loop
41 :     * will see the new value. It's also important that the toplevelenv
42 :     * continuation NOT see the "fetched" environment, but only the ref;
43 :     * then, if the user "filters" the environment ref, a smaller image
44 :     * can be written.
45 :     *)
46 :    
47 : blume 905 fun evalLoop source = let
48 :     val parser = SmlFile.parseOne source
49 :     val cinfo = C.mkCompInfo { source = source, transform = fn x => x }
50 : monnier 16
51 : monnier 47 fun checkErrors s =
52 : blume 879 if CompInfo.anyErrors cinfo then raise EM.Error else ()
53 : monnier 16
54 :     fun oneUnit () = (* perform one transaction *)
55 : blume 905 case parser () of
56 :     NONE => raise EndOfFile
57 :     | SOME ast => let
58 :     val loc = EnvRef.loc ()
59 :     val base = EnvRef.base ()
60 :     val _ = !compManagerHook (ast, loc)
61 : monnier 16
62 : monnier 47 val {static=statenv, dynamic=dynenv, symbolic=symenv} =
63 : blume 905 E.layerEnv (#get loc (), #get base ())
64 : monnier 16
65 : blume 818 val splitting = Control.LambdaSplitting.get ()
66 : blume 1058 fun uniquepid () = raise Fail "uniquepid called from evalloop"
67 : monnier 47 val {csegments, newstatenv, absyn, exportPid, exportLvars,
68 :     imports, inlineExp, ...} =
69 : blume 905 C.compile {source=source, ast=ast,
70 :     statenv=statenv,
71 :     symenv=symenv,
72 :     compInfo=cinfo,
73 :     checkErr=checkErrors,
74 : blume 1058 splitting=splitting,
75 :     uniquepid = uniquepid }
76 : monnier 47 (** returning absyn and exportLvars here is a bad idea,
77 :     they hold on things unnecessarily; this must be
78 :     fixed in the long run. (ZHONG)
79 :     *)
80 : monnier 16
81 : blume 879 val executable = Execute.mkexec csegments before checkErrors ()
82 : blume 905 val executable = Isolate.isolate (interruptable executable)
83 : monnier 16
84 : monnier 47 val _ = (PC.current := Profile.otherIndex)
85 :     val newdynenv =
86 : blume 905 Execute.execute{executable=executable, imports=imports,
87 :     exportPid=exportPid, dynenv=dynenv}
88 : monnier 47 val _ = (PC.current := Profile.compileIndex)
89 : monnier 16
90 : blume 879 val newenv =
91 :     E.mkenv { static = newstatenv,
92 :     dynamic = newdynenv,
93 :     symbolic = SymbolicEnv.mk (exportPid,inlineExp) }
94 : blume 905 val newLocalEnv = E.concatEnv (newenv, #get loc ())
95 :     (* refetch loc because execution may
96 : monnier 47 have changed its contents *)
97 : monnier 16
98 : blume 905 in
99 :     PrettyPrint.with_pp
100 :     (#errConsumer source)
101 :     (fn ppstrm => PPDec.ppDec
102 :     (E.layerEnv(newLocalEnv, #get base ()))
103 :     ppstrm (absyn, exportLvars));
104 :     #set loc newLocalEnv
105 : monnier 47 end
106 : monnier 16
107 :     fun loop() = (oneUnit(); loop())
108 : blume 905 in
109 :     interruptable loop ()
110 : monnier 16 end (* function evalLoop *)
111 :    
112 :     (*** interactive loop, with error handling ***)
113 : blume 905 fun interact () = let
114 :     val source = Source.newSource("stdIn",1,TextIO.stdIn,true,
115 :     EM.defaultConsumer());
116 :     fun flush'() =
117 :     case TextIO.canInput(TextIO.stdIn, 4096) of
118 :     NONE => ()
119 : monnier 47 | (SOME 0) => ()
120 :     | (SOME _) => (ignore (TextIO.input TextIO.stdIn); flush'())
121 : monnier 16
122 : blume 905 fun flush() = (#anyErrors source := false;
123 :     flush'() handle IO.Io _ => ())
124 : monnier 16
125 : monnier 47 local val p1 = Substring.isPrefix "TopLevel/interact/evalloop.sml:"
126 :     val p2 = Substring.isPrefix "TopLevel/main/compile.sml:"
127 :     val p3 = Substring.isPrefix "MiscUtil/util/stats.sml:"
128 :     in fun edit [s] = [s]
129 :     | edit nil = nil
130 :     | edit (s::r) =
131 :     let val s' = Substring.all s
132 :     in if p1 s' orelse p2 s' orelse p3 s'
133 :     then edit r else s :: edit r
134 :     end
135 : monnier 16 end
136 :    
137 : blume 905 fun showhist' [s] = say(concat[" raised at: ", s, "\n"])
138 :     | showhist' (s::r) = (showhist' r;
139 : monnier 47 say (concat[" ", s, "\n"]))
140 : blume 905 | showhist' [] = ()
141 : monnier 16
142 : blume 905 fun exnMsg (CompileExn.Compile s) = concat["Compile: \"", s, "\""]
143 :     | exnMsg (Isolate.TopLevelException e) = exnMsg e
144 :     | exnMsg exn = General.exnMessage exn
145 : monnier 16
146 : blume 905 fun showhist (Isolate.TopLevelException e) = showhist e
147 :     | showhist e = showhist' (edit(SMLofNJ.exnHistory e))
148 : monnier 16
149 : blume 905 fun loop () = let
150 :     fun non_bt_hdl e =
151 :     case e of
152 :     EndOfFile => (say "\n")
153 :     | Interrupt => (say "\nInterrupt\n";
154 :     flush(); loop())
155 :     (* | EM.Error => (flush(); loop()) *)
156 :     | CompileExn.Compile "syntax error" => (flush(); loop())
157 :     | CompileExn.Compile s =>
158 :     (say(concat["\nuncaught exception Compile: \"",
159 :     s,"\"\n"]);
160 :     flush(); loop())
161 :     | Isolate.TopLevelException Isolate.TopLevelCallcc =>
162 :     (say("Error: throw from one top-level expression \
163 :     \into another\n");
164 :     flush (); loop ())
165 :     | Isolate.TopLevelException EM.Error =>
166 :     (flush (); loop ())
167 :     | Isolate.TopLevelException exn => let
168 :     val msg = exnMsg exn
169 :     val name = exnName exn
170 :     in
171 :     if (msg = name)
172 :     then say (concat
173 :     ["\nuncaught exception ",
174 :     exnName exn, "\n"])
175 :     else say (concat
176 :     ["\nuncaught exception ", exnName exn,
177 :     " [", exnMsg exn, "]\n"]);
178 :     showhist exn;
179 :     flush();
180 :     loop()
181 :     end
182 :     | exn => (say (concat["\nuncaught exception ",
183 :     exnMsg exn, "\n"]);
184 :     showhist exn;
185 :     flush();
186 :     loop())
187 :     fun bt_hdl (e, []) = non_bt_hdl e
188 :     | bt_hdl (e, hist) =
189 :     (say (concat ("\n*** BACK-TRACE ***\n" :: hist));
190 :     say "\n";
191 :     non_bt_hdl e)
192 :     in
193 :     SMLofNJ.Internals.BTrace.bthandle
194 :     { work = fn () => evalLoop source,
195 :     hdl = bt_hdl }
196 :     end
197 :     in
198 :     loop()
199 :     end (* fun interact *)
200 : monnier 16
201 :     fun isTermIn f =
202 :     let val (rd, buf) = TextIO.StreamIO.getReader(TextIO.getInstream f)
203 : blume 905 val isTTY =
204 :     case rd of
205 :     TextPrimIO.RD{ioDesc = SOME iod, ...} =>
206 :     (OS.IO.kind iod = OS.IO.Kind.tty)
207 : monnier 47 | _ => false
208 : monnier 16
209 : blume 905 (* val buf = if (buf = "") then NONE else SOME buf *)
210 :     in
211 :     (* since getting the reader will have terminated the stream, we need
212 :     * to build a new stream. *)
213 :     TextIO.setInstream(f, TextIO.StreamIO.mkInstream(rd, buf));
214 :     isTTY
215 : monnier 16 end
216 :    
217 : blume 905 fun evalStream (fname, stream) = let
218 :     val interactive = isTermIn stream
219 :     val source = Source.newSource(fname,1,stream,interactive,
220 : monnier 47 EM.defaultConsumer())
221 : blume 905 in
222 :     evalLoop source
223 :     handle exn => (Source.closeSource source;
224 :     case exn of
225 :     EndOfFile => ()
226 :     | Isolate.TopLevelException e => raise e
227 :     | _ => raise exn)
228 :     end
229 : monnier 16
230 :     end (* top-level local *)
231 :     end (* functor EvalLoopF *)

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