author | wenzelm |
Sun, 19 Jun 2005 00:07:41 +0200 | |
changeset 16470 | 051db5bb21b5 |
parent 16469 | 7e27422c603e |
child 16502 | 5a56e59526a5 |
permissions | -rw-r--r-- |
9254 | 1 |
(* Title: Pure/ML-Systems/mosml.ML |
2 |
ID: $Id$ |
|
3 |
Author: Lawrence C Paulson, Cambridge University Computer Laboratory |
|
4 |
Copyright 1999 University of Cambridge |
|
5 |
||
6 |
Compatibility file for Moscow ML 2.00 |
|
7 |
||
8 |
NOTE: saving images does not work (yet!?), may run it interactively as follows: |
|
9 |
||
16469 | 10 |
$ cd ~~/src/Pure |
9254 | 11 |
$ isabelle RAW_ML_SYSTEM |
12 |
> val ml_system = "mosml"; |
|
13 |
> use "ML-Systems/mosml.ML"; |
|
14 |
> use "ROOT.ML"; |
|
16470 | 15 |
> Session.finish (); |
16 |
> cd "../HOL"; |
|
17 |
> use "ROOT.ML"; |
|
9254 | 18 |
*) |
19 |
||
20 |
(** ML system related **) |
|
21 |
||
22 |
(* Poly/ML emulation *) |
|
23 |
||
24 |
load "Bool"; |
|
25 |
load "Int"; |
|
26 |
load "Real"; |
|
27 |
load "ListPair"; |
|
28 |
load "OS"; |
|
29 |
load "Process"; |
|
30 |
load "FileSys"; |
|
31 |
||
16469 | 32 |
(*proper implementation available?*) |
33 |
structure IntInf = |
|
34 |
struct |
|
35 |
open Int; |
|
36 |
end; |
|
37 |
||
38 |
structure Real = |
|
39 |
struct |
|
40 |
open Real; |
|
41 |
val realFloor = real o floor; |
|
42 |
end; |
|
43 |
||
44 |
structure Time = |
|
45 |
struct |
|
46 |
open Time; |
|
47 |
fun toString t = Time.toString t |
|
48 |
handle Overflow => Real.toString (Time.toReal t); (*workaround Y2004 bug*) |
|
49 |
end; |
|
50 |
||
9254 | 51 |
structure OS = |
16469 | 52 |
struct |
9254 | 53 |
open OS |
54 |
structure Process = Process |
|
55 |
structure FileSys = FileSys |
|
16469 | 56 |
end; |
9254 | 57 |
|
58 |
(*limit the printing depth*) |
|
59 |
fun print_depth n = |
|
60 |
(Meta.printDepth := n div 2; |
|
61 |
Meta.printLength := n); |
|
62 |
||
63 |
(*interface for toplevel pretty printers, see also Pure/install_pp.ML*) |
|
64 |
(*the documentation refers to an installPP but I couldn't fine it!*) |
|
65 |
fun make_pp path pprint = (); |
|
66 |
fun install_pp _ = (); |
|
67 |
||
68 |
(*prompts*) |
|
69 |
(*n.a.??*) |
|
70 |
fun ml_prompts p1 p2 = (); |
|
71 |
||
72 |
||
73 |
(** Compiler-independent timing functions **) |
|
74 |
||
75 |
load "Timer"; |
|
76 |
||
14519
4ca3608fdf4f
Added support for the newer versions of SML/NJ, which break several of the
skalberg
parents:
12988
diff
changeset
|
77 |
use "ML-Systems/cpu-timer-gc.ML"; |
9254 | 78 |
|
14851
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
79 |
(* bounded time execution *) |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
80 |
|
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
81 |
(* FIXME proper implementation available? *) |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
82 |
|
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
83 |
structure TimeLimit : sig |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
84 |
exception TimeOut |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
85 |
val timeLimit : Time.time -> ('a -> 'b) -> 'a -> 'b |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
86 |
end = struct |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
87 |
exception TimeOut |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
88 |
fun timeLimit t f x = |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
89 |
f x; |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
90 |
end; |
9254 | 91 |
|
92 |
(* ML command execution *) |
|
93 |
||
94 |
(*Can one redirect 'use' directly to an instream?*) |
|
95 |
fun use_text _ _ txt = |
|
96 |
let |
|
97 |
val tmp_name = FileSys.tmpName (); |
|
98 |
val tmp_file = TextIO.openOut tmp_name; |
|
99 |
in |
|
100 |
TextIO.output (tmp_file, txt); |
|
101 |
TextIO.closeOut tmp_file; |
|
102 |
use tmp_name; |
|
103 |
FileSys.remove tmp_name |
|
104 |
end; |
|
105 |
||
106 |
||
107 |
||
108 |
(** interrupts **) (*Note: may get into race conditions*) |
|
109 |
||
110 |
(* FIXME proper implementation available? *) |
|
111 |
||
112 |
exception Interrupt; |
|
113 |
||
12988 | 114 |
fun ignore_interrupt f x = f x; |
115 |
fun raise_interrupt f x = f x; |
|
9254 | 116 |
|
117 |
||
118 |
||
119 |
(** OS related **) |
|
120 |
||
121 |
(* system command execution *) |
|
122 |
||
123 |
(*execute Unix command which doesn't take any input from stdin and |
|
124 |
sends its output to stdout; could be done more easily by Unix.execute, |
|
125 |
but that function doesn't use the PATH*) |
|
126 |
fun execute command = |
|
127 |
let |
|
128 |
val tmp_name = FileSys.tmpName (); |
|
129 |
val is = (Process.system (command ^ " > " ^ tmp_name); TextIO.openIn |
|
130 |
tmp_name); |
|
131 |
val result = TextIO.inputAll is; |
|
132 |
in |
|
133 |
TextIO.closeIn is; |
|
134 |
FileSys.remove tmp_name; |
|
135 |
result |
|
136 |
end; |
|
137 |
||
138 |
(*plain version; with return code*) |
|
139 |
fun system cmd = |
|
140 |
if Process.system cmd = Process.success then 0 else 1; |
|
141 |
||
142 |
||
143 |
(* getenv *) |
|
144 |
||
145 |
fun getenv var = |
|
146 |
(case Process.getEnv var of |
|
147 |
NONE => "" |
|
148 |
| SOME txt => txt); |