author | obua |
Wed, 11 Jul 2007 11:47:59 +0200 | |
changeset 23770 | 2711e0285072 |
parent 22252 | ce77e9622002 |
child 23826 | 463903573934 |
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 |
||
17491 | 6 |
Compatibility file for Moscow ML 2.01 |
9254 | 7 |
|
17491 | 8 |
NOTE: saving images does not work; may run it interactively as follows: |
9254 | 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 |
||
16517 | 22 |
load "Obj"; |
9254 | 23 |
load "Bool"; |
24 |
load "Int"; |
|
25 |
load "Real"; |
|
26 |
load "ListPair"; |
|
27 |
load "OS"; |
|
28 |
load "Process"; |
|
29 |
load "FileSys"; |
|
21298
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
30 |
load "IO"; |
9254 | 31 |
|
16517 | 32 |
(*low-level pointer equality*) |
33 |
local val cast : 'a -> int = Obj.magic |
|
34 |
in fun pointer_eq (x:'a, y:'a) = (cast x = cast y) end; |
|
35 |
||
16469 | 36 |
(*proper implementation available?*) |
37 |
structure IntInf = |
|
38 |
struct |
|
39 |
open Int; |
|
40 |
end; |
|
41 |
||
42 |
structure Real = |
|
43 |
struct |
|
44 |
open Real; |
|
45 |
val realFloor = real o floor; |
|
46 |
end; |
|
47 |
||
17491 | 48 |
structure String = |
49 |
struct |
|
50 |
fun isSuffix s1 s2 = |
|
51 |
let val n1 = size s1 and n2 = size s2 |
|
52 |
in if n1 = n2 then s1 = s2 else n1 <= n2 andalso String.substring (s2, n2 - n1, n1) = s1 end; |
|
53 |
open String; |
|
54 |
end; |
|
55 |
||
16469 | 56 |
structure Time = |
57 |
struct |
|
58 |
open Time; |
|
59 |
fun toString t = Time.toString t |
|
60 |
handle Overflow => Real.toString (Time.toReal t); (*workaround Y2004 bug*) |
|
61 |
end; |
|
62 |
||
9254 | 63 |
structure OS = |
16469 | 64 |
struct |
9254 | 65 |
open OS |
66 |
structure Process = Process |
|
67 |
structure FileSys = FileSys |
|
16469 | 68 |
end; |
16993 | 69 |
|
22252 | 70 |
exception Option = Option.Option; |
71 |
||
72 |
||
9254 | 73 |
(*limit the printing depth*) |
74 |
fun print_depth n = |
|
75 |
(Meta.printDepth := n div 2; |
|
76 |
Meta.printLength := n); |
|
77 |
||
78 |
(*interface for toplevel pretty printers, see also Pure/install_pp.ML*) |
|
79 |
(*the documentation refers to an installPP but I couldn't fine it!*) |
|
80 |
fun make_pp path pprint = (); |
|
81 |
fun install_pp _ = (); |
|
82 |
||
16681 | 83 |
(*dummy implementation*) |
84 |
fun ml_prompts p1 p2 = (); |
|
85 |
||
86 |
(*dummy implementation*) |
|
16660 | 87 |
fun profile (n: int) f x = f x; |
88 |
||
18384 | 89 |
(*dummy implementation*) |
16681 | 90 |
fun exception_trace f = f (); |
9254 | 91 |
|
18384 | 92 |
(*dummy implementation*) |
93 |
fun print x = x; |
|
94 |
||
9254 | 95 |
|
96 |
(** Compiler-independent timing functions **) |
|
97 |
||
98 |
load "Timer"; |
|
99 |
||
21298
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
100 |
fun start_timing () = |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
101 |
let val CPUtimer = Timer.startCPUTimer(); |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
102 |
val time = Timer.checkCPUTimer(CPUtimer) |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
103 |
in (CPUtimer,time) end; |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
104 |
|
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
105 |
fun end_timing (CPUtimer, {gc,sys,usr}) = |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
106 |
let open Time (*...for Time.toString, Time.+ and Time.- *) |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
107 |
val {gc=gc2,sys=sys2,usr=usr2} = Timer.checkCPUTimer(CPUtimer) |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
108 |
in "User " ^ toString (usr2-usr) ^ |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
109 |
" GC " ^ toString (gc2-gc) ^ |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
110 |
" All "^ toString (sys2-sys + usr2-usr + gc2-gc) ^ |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
111 |
" secs" |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
112 |
handle Time => "" |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
113 |
end; |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
114 |
|
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
115 |
fun check_timer timer = |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
116 |
let val {sys, usr, gc} = Timer.checkCPUTimer timer |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
117 |
in (sys, usr, gc) end; |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
118 |
|
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
119 |
|
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
120 |
(* SML basis library fixes *) |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
121 |
|
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
122 |
structure TextIO = |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
123 |
struct |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
124 |
fun canInput _ = raise IO.Io {cause = Fail "undefined", function = "canInput", name = ""}; |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
125 |
open TextIO; |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
126 |
end; |
6d2306b2376d
tuned names of start_timing,/end_timing/check_timer;
wenzelm
parents:
21280
diff
changeset
|
127 |
|
9254 | 128 |
|
14851
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
129 |
(* bounded time execution *) |
0fc75361e0c7
TimeLimit structure added (no proper implementation yet)
webertj
parents:
14519
diff
changeset
|
130 |
|
21280 | 131 |
(*dummy implementation*) |
18760 | 132 |
fun interrupt_timeout time f x = |
133 |
f x; |
|
16517 | 134 |
|
21280 | 135 |
|
9254 | 136 |
(* ML command execution *) |
137 |
||
138 |
(*Can one redirect 'use' directly to an instream?*) |
|
22144 | 139 |
fun use_text _ _ _ txt = |
9254 | 140 |
let |
141 |
val tmp_name = FileSys.tmpName (); |
|
142 |
val tmp_file = TextIO.openOut tmp_name; |
|
143 |
in |
|
144 |
TextIO.output (tmp_file, txt); |
|
145 |
TextIO.closeOut tmp_file; |
|
146 |
use tmp_name; |
|
147 |
FileSys.remove tmp_name |
|
148 |
end; |
|
149 |
||
22252 | 150 |
fun use_file _ _ name = use name; |
21770 | 151 |
|
9254 | 152 |
|
153 |
||
16993 | 154 |
(** interrupts **) (*Note: may get into race conditions*) |
9254 | 155 |
|
156 |
(* FIXME proper implementation available? *) |
|
157 |
||
158 |
exception Interrupt; |
|
159 |
||
16993 | 160 |
fun ignore_interrupt f x = f x; |
12988 | 161 |
fun raise_interrupt f x = f x; |
9254 | 162 |
|
163 |
||
164 |
||
165 |
(** OS related **) |
|
166 |
||
167 |
(* system command execution *) |
|
168 |
||
169 |
(*execute Unix command which doesn't take any input from stdin and |
|
170 |
sends its output to stdout; could be done more easily by Unix.execute, |
|
171 |
but that function doesn't use the PATH*) |
|
172 |
fun execute command = |
|
173 |
let |
|
174 |
val tmp_name = FileSys.tmpName (); |
|
16993 | 175 |
val is = (Process.system (command ^ " > " ^ tmp_name); TextIO.openIn tmp_name); |
9254 | 176 |
val result = TextIO.inputAll is; |
177 |
in |
|
178 |
TextIO.closeIn is; |
|
179 |
FileSys.remove tmp_name; |
|
180 |
result |
|
181 |
end; |
|
182 |
||
183 |
(*plain version; with return code*) |
|
184 |
fun system cmd = |
|
185 |
if Process.system cmd = Process.success then 0 else 1; |
|
186 |
||
187 |
||
17824 | 188 |
val string_of_pid = Int.toString; |
189 |
||
190 |
||
9254 | 191 |
(* getenv *) |
192 |
||
193 |
fun getenv var = |
|
194 |
(case Process.getEnv var of |
|
195 |
NONE => "" |
|
196 |
| SOME txt => txt); |