4403
|
1 |
(* Title: Pure/ML-Systems/smlnj.ML
|
|
2 |
ID: $Id$
|
|
3 |
Author: Carsten Clasohm and Markus Wenzel, TU Muenchen
|
|
4 |
|
5708
|
5 |
Compatibility file for Standard ML of New Jersey 110 or later.
|
4403
|
6 |
*)
|
|
7 |
|
|
8 |
(** ML system related **)
|
|
9 |
|
|
10 |
(* restore old-style character / string functions *)
|
|
11 |
|
10725
|
12 |
val ord = SML90.ord;
|
|
13 |
val chr = SML90.chr;
|
|
14 |
val explode = SML90.explode;
|
|
15 |
val implode = SML90.implode;
|
4403
|
16 |
|
|
17 |
|
|
18 |
(* New Jersey ML parameters *)
|
|
19 |
|
|
20 |
val _ =
|
|
21 |
(Compiler.Control.Print.printLength := 1000;
|
|
22 |
Compiler.Control.Print.printDepth := 350;
|
|
23 |
Compiler.Control.Print.stringDepth := 250;
|
|
24 |
Compiler.Control.Print.signatures := 2);
|
|
25 |
|
|
26 |
|
|
27 |
(* Poly/ML emulation *)
|
|
28 |
|
|
29 |
fun quit () = exit 0;
|
|
30 |
|
|
31 |
(*limit the printing depth -- divided by 2 for comparibility with Poly/ML*)
|
|
32 |
fun print_depth n =
|
|
33 |
(Compiler.Control.Print.printDepth := n div 2;
|
|
34 |
Compiler.Control.Print.printLength := n);
|
|
35 |
|
|
36 |
|
5816
|
37 |
(* compiler-independent timing functions *)
|
4403
|
38 |
|
|
39 |
(*Note start point for timing*)
|
5816
|
40 |
fun startTiming() =
|
4403
|
41 |
let val CPUtimer = Timer.startCPUTimer();
|
|
42 |
val time = Timer.checkCPUTimer(CPUtimer)
|
|
43 |
in (CPUtimer,time) end;
|
|
44 |
|
|
45 |
(*Finish timing and return string*)
|
|
46 |
fun endTiming (CPUtimer, {gc,sys,usr}) =
|
|
47 |
let open Time (*...for Time.toString, Time.+ and Time.- *)
|
|
48 |
val {gc=gc2,sys=sys2,usr=usr2} = Timer.checkCPUTimer(CPUtimer)
|
|
49 |
in "User " ^ toString (usr2-usr) ^
|
|
50 |
" GC " ^ toString (gc2-gc) ^
|
|
51 |
" All "^ toString (sys2-sys + usr2-usr + gc2-gc) ^
|
|
52 |
" secs"
|
|
53 |
handle Time => ""
|
|
54 |
end;
|
|
55 |
|
|
56 |
|
4977
|
57 |
(* prompts *)
|
|
58 |
|
|
59 |
fun ml_prompts p1 p2 =
|
|
60 |
(Compiler.Control.primaryPrompt := p1; Compiler.Control.secondaryPrompt := p2);
|
|
61 |
|
|
62 |
|
4403
|
63 |
(* toplevel pretty printing (see also Pure/install_pp.ML) *)
|
|
64 |
|
|
65 |
fun make_pp path pprint =
|
|
66 |
let
|
|
67 |
open Compiler.PrettyPrint;
|
|
68 |
|
|
69 |
fun pp pps obj =
|
|
70 |
pprint obj
|
|
71 |
(add_string pps, begin_block pps INCONSISTENT,
|
|
72 |
fn wd => add_break pps (wd, 0), fn () => add_newline pps,
|
|
73 |
fn () => end_block pps);
|
|
74 |
in
|
|
75 |
(path, pp)
|
|
76 |
end;
|
|
77 |
|
|
78 |
fun install_pp (path, pp) = Compiler.PPTable.install_pp path pp;
|
|
79 |
|
|
80 |
|
|
81 |
(* ML command execution *)
|
|
82 |
|
10914
|
83 |
fun use_text (print, err) verbose txt =
|
5090
|
84 |
let
|
|
85 |
val ref out_orig = Compiler.Control.Print.out;
|
|
86 |
|
|
87 |
val out_buffer = ref ([]: string list);
|
|
88 |
val out = {say = (fn s => out_buffer := s :: ! out_buffer), flush = (fn () => ())};
|
10914
|
89 |
fun output () =
|
7890
|
90 |
let val str = implode (rev (! out_buffer))
|
10914
|
91 |
in String.substring (str, 0, Int.max (0, size str - 1)) end;
|
5090
|
92 |
in
|
|
93 |
Compiler.Control.Print.out := out;
|
|
94 |
Compiler.Interact.useStream (TextIO.openString txt) handle exn =>
|
10914
|
95 |
(Compiler.Control.Print.out := out_orig; err (output ()); raise exn);
|
5090
|
96 |
Compiler.Control.Print.out := out_orig;
|
10914
|
97 |
if verbose then print (output ()) else ()
|
5090
|
98 |
end;
|
4403
|
99 |
|
|
100 |
|
|
101 |
|
5816
|
102 |
(** interrupts **)
|
|
103 |
|
|
104 |
local
|
|
105 |
|
|
106 |
datatype 'a result =
|
|
107 |
Result of 'a |
|
|
108 |
Exn of exn;
|
|
109 |
|
|
110 |
fun capture f x = Result (f x) handle exn => Exn exn;
|
|
111 |
|
|
112 |
fun release (Result x) = x
|
|
113 |
| release (Exn exn) = raise exn;
|
|
114 |
|
|
115 |
|
|
116 |
val sig_int = Signals.sigINT;
|
|
117 |
val sig_int_mask = Signals.MASK [Signals.sigINT];
|
|
118 |
|
|
119 |
fun interruptible () =
|
|
120 |
(case Signals.masked () of
|
|
121 |
Signals.MASKALL => false
|
|
122 |
| Signals.MASK sigs => List.all (fn s => s <> sig_int) sigs);
|
|
123 |
|
|
124 |
val mask_signals = Signals.maskSignals;
|
|
125 |
val unmask_signals = Signals.unmaskSignals;
|
|
126 |
|
|
127 |
fun change_mask ok change unchange f x =
|
|
128 |
if ok () then f x
|
|
129 |
else
|
|
130 |
let
|
|
131 |
val _ = change sig_int_mask;
|
|
132 |
val result = capture f x;
|
|
133 |
val _ = unchange sig_int_mask;
|
|
134 |
in release result end;
|
|
135 |
|
|
136 |
in
|
|
137 |
|
|
138 |
|
|
139 |
(* mask / unmask interrupt *)
|
|
140 |
|
|
141 |
fun mask_interrupt f = change_mask (not o interruptible) mask_signals unmask_signals f;
|
|
142 |
fun unmask_interrupt f = change_mask interruptible unmask_signals mask_signals f;
|
|
143 |
|
|
144 |
|
|
145 |
(* exhibit interrupt (via exception) *)
|
|
146 |
|
|
147 |
exception Interrupt;
|
|
148 |
|
|
149 |
fun exhibit_interrupt f x =
|
|
150 |
let
|
|
151 |
val orig_handler = Signals.inqHandler sig_int;
|
|
152 |
fun reset_handler () = (Signals.setHandler (sig_int, orig_handler); ());
|
|
153 |
|
|
154 |
val interrupted = ref false;
|
|
155 |
|
|
156 |
fun set_handler cont =
|
|
157 |
Signals.setHandler (sig_int, Signals.HANDLER (fn _ => (interrupted := true; cont)));
|
|
158 |
|
|
159 |
fun proceed cont =
|
|
160 |
let
|
|
161 |
val _ = set_handler cont;
|
|
162 |
val result = unmask_interrupt (capture f) x;
|
|
163 |
val _ = reset_handler ();
|
|
164 |
in release result end;
|
|
165 |
in
|
|
166 |
SMLofNJ.Cont.callcc proceed;
|
|
167 |
reset_handler ();
|
|
168 |
if ! interrupted then raise Interrupt else ()
|
|
169 |
end;
|
|
170 |
|
|
171 |
end;
|
|
172 |
|
|
173 |
|
|
174 |
|
4403
|
175 |
(** OS related **)
|
|
176 |
|
|
177 |
(* system command execution *)
|
|
178 |
|
|
179 |
(*execute Unix command which doesn't take any input from stdin and
|
|
180 |
sends its output to stdout; could be done more easily by Unix.execute,
|
|
181 |
but that function doesn't use the PATH*)
|
|
182 |
fun execute command =
|
|
183 |
let
|
|
184 |
val tmp_name = OS.FileSys.tmpName ();
|
|
185 |
val is = (OS.Process.system (command ^ " > " ^ tmp_name); TextIO.openIn tmp_name);
|
|
186 |
val result = TextIO.inputAll is;
|
|
187 |
in
|
|
188 |
TextIO.closeIn is;
|
|
189 |
OS.FileSys.remove tmp_name;
|
|
190 |
result
|
|
191 |
end;
|
|
192 |
|
7855
|
193 |
(*plain version; with return code*)
|
|
194 |
val system = OS.Process.system: string -> int;
|
|
195 |
|
4403
|
196 |
|
|
197 |
(* file handling *)
|
|
198 |
|
6227
|
199 |
(*get time of last modification*)
|
|
200 |
fun file_info name = Time.toString (OS.FileSys.modTime name) handle _ => "";
|
4403
|
201 |
|
|
202 |
|
|
203 |
(* getenv *)
|
|
204 |
|
|
205 |
fun getenv var =
|
|
206 |
(case OS.Process.getEnv var of
|
|
207 |
NONE => ""
|
|
208 |
| SOME txt => txt);
|