|
1 (* Title: Pure/RAW/ROOT_smlnj.ML |
|
2 |
|
3 Compatibility file for Standard ML of New Jersey. |
|
4 *) |
|
5 |
|
6 val io_buffer_size = 4096; |
|
7 use "RAW/proper_int.ML"; |
|
8 |
|
9 exception Interrupt; |
|
10 fun reraise exn = raise exn; |
|
11 |
|
12 fun exit rc = Posix.Process.exit (Word8.fromInt rc); |
|
13 fun quit () = exit 0; |
|
14 |
|
15 use "RAW/overloading_smlnj.ML"; |
|
16 use "RAW/exn.ML"; |
|
17 use "RAW/single_assignment.ML"; |
|
18 use "RAW/universal.ML"; |
|
19 use "RAW/thread_dummy.ML"; |
|
20 use "RAW/multithreading.ML"; |
|
21 use "RAW/ml_stack_dummy.ML"; |
|
22 use "RAW/ml_pretty.ML"; |
|
23 use "RAW/ml_name_space.ML"; |
|
24 structure PolyML = struct end; |
|
25 use "RAW/pp_dummy.ML"; |
|
26 use "RAW/use_context.ML"; |
|
27 use "RAW/ml_positions.ML"; |
|
28 |
|
29 |
|
30 val seconds = Time.fromReal; |
|
31 |
|
32 (*low-level pointer equality*) |
|
33 CM.autoload "$smlnj/init/init.cmi"; |
|
34 val pointer_eq = InlineT.ptreql; |
|
35 |
|
36 |
|
37 (* restore old-style character / string functions *) |
|
38 |
|
39 val ord = mk_int o SML90.ord; |
|
40 val chr = SML90.chr o dest_int; |
|
41 val raw_explode = SML90.explode; |
|
42 val implode = SML90.implode; |
|
43 |
|
44 |
|
45 (* New Jersey ML parameters *) |
|
46 |
|
47 val _ = |
|
48 (Control.Print.printLength := 1000; |
|
49 Control.Print.printDepth := 350; |
|
50 Control.Print.stringDepth := 250; |
|
51 Control.Print.signatures := 2; |
|
52 Control.MC.matchRedundantError := false); |
|
53 |
|
54 |
|
55 (* Poly/ML emulation *) |
|
56 |
|
57 (*limit the printing depth -- divided by 2 for comparibility with Poly/ML*) |
|
58 local |
|
59 val depth = ref (10: int); |
|
60 in |
|
61 fun get_default_print_depth () = ! depth; |
|
62 fun default_print_depth n = |
|
63 (depth := n; |
|
64 Control.Print.printDepth := dest_int n div 2; |
|
65 Control.Print.printLength := dest_int n); |
|
66 val _ = default_print_depth 10; |
|
67 end; |
|
68 |
|
69 fun ml_make_string (_: string) = "(fn _ => \"?\")"; |
|
70 |
|
71 |
|
72 (*prompts*) |
|
73 fun ml_prompts p1 p2 = |
|
74 (Control.primaryPrompt := p1; Control.secondaryPrompt := p2); |
|
75 |
|
76 (*dummy implementation*) |
|
77 structure ML_Profiling = |
|
78 struct |
|
79 fun profile_time (_: (int * string) list -> unit) f x = f x; |
|
80 fun profile_time_thread (_: (int * string) list -> unit) f x = f x; |
|
81 fun profile_allocations (_: (int * string) list -> unit) f x = f x; |
|
82 end; |
|
83 |
|
84 (*dummy implementation*) |
|
85 fun print_exception_trace (_: exn -> string) (_: string -> unit) f = f (); |
|
86 |
|
87 |
|
88 (* ML command execution *) |
|
89 |
|
90 fun use_text ({tune_source, print, error, ...}: use_context) |
|
91 {line, file, verbose, debug = _: bool} text = |
|
92 let |
|
93 val ref out_orig = Control.Print.out; |
|
94 |
|
95 val out_buffer = ref ([]: string list); |
|
96 val out = {say = (fn s => out_buffer := s :: ! out_buffer), flush = (fn () => ())}; |
|
97 fun output () = |
|
98 let val str = implode (rev (! out_buffer)) |
|
99 in String.substring (str, 0, Int.max (0, size str - 1)) end; |
|
100 in |
|
101 Control.Print.out := out; |
|
102 Backend.Interact.useStream (TextIO.openString (tune_source (ml_positions line file text))) |
|
103 handle exn => |
|
104 (Control.Print.out := out_orig; |
|
105 error ((if file = "" then "" else "Error in " ^ file ^ "\n") ^ output ()); raise exn); |
|
106 Control.Print.out := out_orig; |
|
107 if verbose then print (output ()) else () |
|
108 end; |
|
109 |
|
110 fun use_file context {verbose, debug} file = |
|
111 let |
|
112 val instream = TextIO.openIn file; |
|
113 val text = Exn.release (Exn.capture TextIO.inputAll instream before TextIO.closeIn instream); |
|
114 in use_text context {line = 1, file = file, verbose = verbose, debug = debug} text end; |
|
115 |
|
116 |
|
117 (* toplevel pretty printing *) |
|
118 |
|
119 fun ml_pprint pps = |
|
120 let |
|
121 fun str "" = () |
|
122 | str s = PrettyPrint.string pps s; |
|
123 fun pprint (ML_Pretty.Block ((bg, en), consistent, ind, prts)) = |
|
124 (str bg; |
|
125 (if consistent then PrettyPrint.openHVBox else PrettyPrint.openHOVBox) pps |
|
126 (PrettyPrint.Rel (dest_int ind)); |
|
127 List.app pprint prts; PrettyPrint.closeBox pps; |
|
128 str en) |
|
129 | pprint (ML_Pretty.String (s, _)) = str s |
|
130 | pprint (ML_Pretty.Break (false, width, offset)) = |
|
131 PrettyPrint.break pps {nsp = dest_int width, offset = dest_int offset} |
|
132 | pprint (ML_Pretty.Break (true, _, _)) = PrettyPrint.newline pps; |
|
133 in pprint end; |
|
134 |
|
135 fun toplevel_pp context path pp = |
|
136 use_text context {line = 1, file = "pp", verbose = false, debug = false} |
|
137 ("CompilerPPTable.install_pp [" ^ String.concatWith "," (map (fn s => "\"" ^ s ^ "\"") path) ^ |
|
138 "] (fn pps => ml_pprint pps o Pretty.to_ML o (" ^ pp ^ "))"); |
|
139 |
|
140 |
|
141 |
|
142 (** interrupts **) |
|
143 |
|
144 local |
|
145 |
|
146 fun change_signal new_handler f x = |
|
147 let |
|
148 val old_handler = Signals.setHandler (Signals.sigINT, new_handler); |
|
149 val result = Exn.capture (f old_handler) x; |
|
150 val _ = Signals.setHandler (Signals.sigINT, old_handler); |
|
151 in Exn.release result end; |
|
152 |
|
153 in |
|
154 |
|
155 fun interruptible (f: 'a -> 'b) x = |
|
156 let |
|
157 val result = ref (Exn.interrupt_exn: 'b Exn.result); |
|
158 val old_handler = Signals.inqHandler Signals.sigINT; |
|
159 in |
|
160 SMLofNJ.Cont.callcc (fn cont => |
|
161 (Signals.setHandler (Signals.sigINT, Signals.HANDLER (fn _ => cont)); |
|
162 result := Exn.capture f x)); |
|
163 Signals.setHandler (Signals.sigINT, old_handler); |
|
164 Exn.release (! result) |
|
165 end; |
|
166 |
|
167 fun uninterruptible f = |
|
168 change_signal Signals.IGNORE |
|
169 (fn old_handler => f (fn g => change_signal old_handler (fn _ => g))); |
|
170 |
|
171 end; |
|
172 |
|
173 |
|
174 use "RAW/unsynchronized.ML"; |
|
175 use "RAW/ml_debugger.ML"; |
|
176 |
|
177 |
|
178 (* ML system operations *) |
|
179 |
|
180 fun ml_platform_path (s: string) = s; |
|
181 fun ml_standard_path (s: string) = s; |
|
182 |
|
183 use "RAW/ml_system.ML"; |
|
184 |
|
185 structure ML_System = |
|
186 struct |
|
187 |
|
188 open ML_System; |
|
189 |
|
190 fun save_state name = |
|
191 if SMLofNJ.exportML name then () |
|
192 else OS.FileSys.rename {old = name ^ "." ^ platform, new = name}; |
|
193 |
|
194 end; |