Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2013 Matthew Fluet. |
2 | * Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor MkIO (S : sig | |
11 | type instream | |
12 | type outstream | |
13 | val openOut: string -> outstream | |
14 | end) = | |
15 | struct | |
16 | open S | |
17 | ||
18 | fun inFd _ = raise Fail "IO.inFd" | |
19 | fun mkstemps {prefix, suffix} = | |
20 | let | |
21 | val name = concat [prefix, MLtonRandom.alphaNumString 6, suffix] | |
22 | in | |
23 | (* Make sure the temporary file name doesn't already exist. *) | |
24 | if OS.FileSys.access (name, []) | |
25 | then mkstemps {prefix = prefix, suffix = suffix} | |
26 | else (name, openOut name) | |
27 | end | |
28 | fun mkstemp s = mkstemps {prefix = s, suffix = ""} | |
29 | fun newIn _ = raise Fail "IO.newIn" | |
30 | fun newOut _ = raise Fail "IO.newOut" | |
31 | fun outFd _ = raise Fail "IO.outFd" | |
32 | fun setIn _ = raise Fail "IO.setIn" | |
33 | fun tempPrefix _ = raise Fail "IO.tempPrefix" | |
34 | end | |
35 | ||
36 | functor MkWord(W : WORD) : MLTON_WORD = | |
37 | struct | |
38 | open W | |
39 | type t = word | |
40 | ||
41 | val wordSize = Word.fromInt wordSize | |
42 | ||
43 | val bswap = fn _ => raise Fail "Word.bswap" | |
44 | fun rol (w: word, w': Word.word): word = | |
45 | let | |
46 | val w' = Word.mod (w', wordSize) | |
47 | in | |
48 | orb (>> (w, Word.- (wordSize, w')), | |
49 | << (w, w')) | |
50 | end | |
51 | fun ror (w: word, w': Word.word): word = | |
52 | let | |
53 | val w' = Word.mod (w', wordSize) | |
54 | in | |
55 | orb (>> (w, w'), | |
56 | << (w, Word.- (wordSize, w'))) | |
57 | end | |
58 | ||
59 | end | |
60 | ||
61 | (* This file is just a dummy provided in place of the structure that MLton | |
62 | * supplies so that we can compile under SML/NJ. | |
63 | *) | |
64 | structure MLton: MLTON = | |
65 | struct | |
66 | val debug = false | |
67 | val eq = fn _ => raise Fail "eq" | |
68 | val equal = fn _ => raise Fail "equal" | |
69 | val hash = fn _ => raise Fail "hash" | |
70 | val isMLton = MLton.isMLton | |
71 | val safe = true | |
72 | val share = fn _ => raise Fail "share" | |
73 | val shareAll = fn _ => raise Fail "shareAll" | |
74 | val size = MLton.size | |
75 | ||
76 | structure Array = | |
77 | struct | |
78 | open Array | |
79 | ||
80 | fun unfoldi (n, a, f) = | |
81 | let | |
82 | val r = ref a | |
83 | val a = | |
84 | tabulate (n, fn i => | |
85 | let | |
86 | val (b, a') = f (i, !r) | |
87 | val _ = r := a' | |
88 | in | |
89 | b | |
90 | end) | |
91 | in | |
92 | (a, !r) | |
93 | end | |
94 | end | |
95 | ||
96 | structure BinIO = MkIO (BinIO) | |
97 | ||
98 | structure Exn = | |
99 | struct | |
100 | val addExnMessager = fn _ => raise Fail "Exn.addExnMessager" | |
101 | val history = MLton.Exn.history | |
102 | ||
103 | val defaultTopLevelHandler = fn _ => raise Fail "Exn.defaultTopLevelHandler" | |
104 | val getTopLevelHandler = fn _ => raise Fail "Exn.getTopLevelHandler" | |
105 | val setTopLevelHandler = fn _ => raise Fail "Exn.setTopLevelHandler" | |
106 | val topLevelHandler = fn _ => raise Fail "Exn.topLevelHandler" | |
107 | end | |
108 | ||
109 | structure Finalizable = | |
110 | struct | |
111 | type 'a t = 'a | |
112 | ||
113 | fun addFinalizer _ = () | |
114 | fun finalizeBefore _ = () | |
115 | fun new x = x | |
116 | fun touch _ = () | |
117 | fun withValue (x, f) = f x | |
118 | end | |
119 | ||
120 | structure GC = | |
121 | struct | |
122 | val collect = MLton.GC.collect | |
123 | val pack = MLton.GC.pack | |
124 | val setMessages = MLton.GC.setMessages | |
125 | fun setSummary _ = () | |
126 | fun unpack _ = () | |
127 | ||
128 | structure Statistics = | |
129 | struct | |
130 | val bytesAllocated = fn _ => raise Fail "GC.Statistics.bytesAllocated" | |
131 | val lastBytesLive = fn _ => raise Fail "GC.Statistics.lastBytesLive" | |
132 | val numCopyingGCs = fn _ => raise Fail "GC.Statistics.numCopyingGCs" | |
133 | val numMarkCompactGCs = fn _ => raise Fail "GC.Statistics.numMarkCompactGCs" | |
134 | val numMinorGCs = fn _ => raise Fail "GC.Statistics.numMinorGCs" | |
135 | val maxBytesLive = fn _ => raise Fail "GC.Statistics.maxBytesLive" | |
136 | end | |
137 | end | |
138 | ||
139 | structure Itimer = | |
140 | struct | |
141 | datatype t = Prof | Real | Virtual | |
142 | ||
143 | fun signal _ = Posix.Signal.alrm | |
144 | fun set _ = raise Fail "Itimer.set" | |
145 | end | |
146 | ||
147 | structure Platform = | |
148 | struct | |
149 | fun peek (l, f) = List.find f l | |
150 | fun omap (opt, f) = Option.map f opt | |
151 | ||
152 | structure String = | |
153 | struct | |
154 | open String | |
155 | ||
156 | val toLower = CharVector.map Char.toLower | |
157 | end | |
158 | ||
159 | structure Arch = | |
160 | struct | |
161 | datatype t = Alpha | AMD64 | ARM | ARM64 | HPPA | IA64 | m68k | | |
162 | MIPS | PowerPC | PowerPC64 | S390 | Sparc | X86 | |
163 | ||
164 | val all = [(Alpha, "Alpha"), | |
165 | (AMD64, "AMD64"), | |
166 | (ARM, "ARM"), | |
167 | (ARM64, "ARM64"), | |
168 | (HPPA, "HPPA"), | |
169 | (IA64, "IA64"), | |
170 | (m68k, "m68k"), | |
171 | (MIPS, "MIPS"), | |
172 | (PowerPC, "PowerPC"), | |
173 | (PowerPC64, "PowerPC64"), | |
174 | (S390, "S390"), | |
175 | (Sparc, "Sparc"), | |
176 | (X86, "X86")] | |
177 | ||
178 | fun fromString s = | |
179 | let | |
180 | val s = String.toLower s | |
181 | in | |
182 | omap (peek (all, fn (_, s') => s = String.toLower s'), | |
183 | #1) | |
184 | end | |
185 | ||
186 | fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a'))) | |
187 | ||
188 | val host: t = | |
189 | case fromString (MLton.Platform.Arch.toString MLton.Platform.Arch.host) of | |
190 | NONE => raise Fail "MLton.Platform.Arch.host: strange arch" | |
191 | | SOME host => host | |
192 | end | |
193 | ||
194 | structure OS = | |
195 | struct | |
196 | datatype t = | |
197 | AIX | |
198 | | Cygwin | |
199 | | Darwin | |
200 | | FreeBSD | |
201 | | HPUX | |
202 | | Hurd | |
203 | | Linux | |
204 | | MinGW | |
205 | | NetBSD | |
206 | | OpenBSD | |
207 | | Solaris | |
208 | ||
209 | val all = [(AIX, "AIX"), | |
210 | (Cygwin, "Cygwin"), | |
211 | (Darwin, "Darwin"), | |
212 | (FreeBSD, "FreeBSD"), | |
213 | (HPUX, "HPUX"), | |
214 | (Hurd, "Hurd"), | |
215 | (Linux, "Linux"), | |
216 | (MinGW, "MinGW"), | |
217 | (NetBSD, "NetBSD"), | |
218 | (OpenBSD, "OpenBSD"), | |
219 | (Solaris, "Solaris")] | |
220 | ||
221 | fun fromString s = | |
222 | let | |
223 | val s = String.toLower s | |
224 | in | |
225 | omap (peek (all, fn (_, s') => s = String.toLower s'), | |
226 | #1) | |
227 | end | |
228 | ||
229 | fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a'))) | |
230 | ||
231 | val host: t = | |
232 | case fromString (MLton.Platform.OS.toString MLton.Platform.OS.host) of | |
233 | NONE => raise Fail "MLton.Platform.OS.host: strange os" | |
234 | | SOME os => os | |
235 | end | |
236 | end | |
237 | ||
238 | structure ProcEnv = | |
239 | struct | |
240 | type gid = Posix.ProcEnv.gid | |
241 | ||
242 | fun setenv _ = raise Fail "setenv" | |
243 | fun setgroups _ = raise Fail "setgroups" | |
244 | end | |
245 | ||
246 | structure Process = | |
247 | struct | |
248 | type ('stdin, 'stdout, 'stderr) t = unit | |
249 | type input = unit | |
250 | type output = unit | |
251 | type none = unit | |
252 | type chain = unit | |
253 | type any = unit | |
254 | ||
255 | exception MisuseOfForget | |
256 | exception DoublyRedirected | |
257 | ||
258 | structure Child = | |
259 | struct | |
260 | type ('use, 'dir) t = unit | |
261 | ||
262 | val binIn = fn _ => raise Fail "Child.binIn" | |
263 | val binOut = fn _ => raise Fail "Child.binOut" | |
264 | val fd = fn _ => raise Fail "Child.fd" | |
265 | val remember = fn _ => raise Fail "Child.remember" | |
266 | val textIn = fn _ => raise Fail "Child.textIn" | |
267 | val textOut = fn _ => raise Fail "Child.textOut" | |
268 | end | |
269 | ||
270 | structure Param = | |
271 | struct | |
272 | type ('use, 'dir) t = unit | |
273 | ||
274 | val child = fn _ => raise Fail "Param.child" | |
275 | val fd = fn _ => raise Fail "Param.fd" | |
276 | val file = fn _ => raise Fail "Param.file" | |
277 | val forget = fn _ => raise Fail "Param.forget" | |
278 | val null = () | |
279 | val pipe = () | |
280 | val self = () | |
281 | end | |
282 | ||
283 | val create = fn _ => raise Fail "Process.create" | |
284 | val getStderr = fn _ => raise Fail "Process.getStderr" | |
285 | val getStdin = fn _ => raise Fail "Process.getStdin" | |
286 | val getStdout = fn _ => raise Fail "Process.getStdout" | |
287 | val kill = fn _ => raise Fail "Process.kill" | |
288 | val reap = fn _ => raise Fail "Process.reap" | |
289 | ||
290 | type pid = Posix.Process.pid | |
291 | ||
292 | val atExit = OS.Process.atExit | |
293 | ||
294 | fun exit n = | |
295 | let | |
296 | open OS.Process | |
297 | in | |
298 | exit (if n = 0 then success else failure) | |
299 | end | |
300 | ||
301 | fun spawne {path, args, env} = | |
302 | case Posix.Process.fork () of | |
303 | NONE => Posix.Process.exece (path, args, env) | |
304 | | SOME pid => pid | |
305 | ||
306 | fun spawn {path, args} = | |
307 | spawne {path = path, args = args, env = Posix.ProcEnv.environ ()} | |
308 | ||
309 | fun spawnp {file, args} = | |
310 | case Posix.Process.fork () of | |
311 | NONE => Posix.Process.execp (file, args) | |
312 | | SOME pid => pid | |
313 | end | |
314 | ||
315 | structure Profile = | |
316 | struct | |
317 | structure Data = | |
318 | struct | |
319 | type t = unit | |
320 | ||
321 | val equals = fn _ => raise Fail "Profile.Data.equals" | |
322 | val free = fn _ => raise Fail "Profile.Data.free" | |
323 | val malloc = fn _ => raise Fail "Profile.Data.malloc" | |
324 | val write = fn _ => raise Fail "Profile.Data.write" | |
325 | end | |
326 | val isOn = false | |
327 | val withData = fn _ => raise Fail "Profile.withData" | |
328 | end | |
329 | ||
330 | structure Random = MLtonRandom | |
331 | ||
332 | structure Rusage = | |
333 | struct | |
334 | type t = {stime: Time.time, utime: Time.time} | |
335 | ||
336 | fun measureGC _ = () | |
337 | ||
338 | (* Fake it with Posix.ProcEnv.times | |
339 | * and Timer.totalCPUTimer and Timer.checkCPUTimes. | |
340 | *) | |
341 | fun rusage () = | |
342 | let | |
343 | val zero = {utime = Time.zeroTime, stime = Time.zeroTime} | |
344 | in | |
345 | let | |
346 | val {gc = {usr = gcutime, sys = gcstime}, ...} = | |
347 | Timer.checkCPUTimes (Timer.totalCPUTimer ()) | |
348 | val {utime, stime, cutime, cstime, ...} = | |
349 | Posix.ProcEnv.times () | |
350 | in | |
351 | {self = {utime = utime, stime = stime}, | |
352 | children = {utime = cutime, stime = cstime}, | |
353 | gc = {utime = gcutime, stime = gcstime}} | |
354 | end handle Time => {children = zero, gc = zero, self = zero} | |
355 | (* The handle Time is there because of a bug in SML/NJ that | |
356 | * causes a Time exception to be raised on machines with a | |
357 | * large uptime (enough that the number of clock ticks is | |
358 | * >= 2^31). | |
359 | *) | |
360 | end | |
361 | end | |
362 | ||
363 | structure Signal = | |
364 | struct | |
365 | open Posix.Signal | |
366 | ||
367 | type t = signal | |
368 | ||
369 | val prof = alrm | |
370 | val vtalrm = alrm | |
371 | ||
372 | structure Handler = | |
373 | struct | |
374 | type t = unit | |
375 | ||
376 | val default = () | |
377 | val handler = fn _ => () | |
378 | val ignore = () | |
379 | val isDefault = fn _ => raise Fail "Signal.Handler.isDefault" | |
380 | val isIgnore = fn _ => raise Fail "Signal.Handler.isIgnore" | |
381 | fun simple _ = () | |
382 | end | |
383 | ||
384 | structure Mask = | |
385 | struct | |
386 | type t = unit | |
387 | ||
388 | val all = () | |
389 | fun allBut _ = () | |
390 | fun block _ = raise Fail "Signal.Mask.block" | |
391 | fun getBlocked _ = () | |
392 | fun isMember _ = raise Fail "Signal.Mask.isMember" | |
393 | val none = () | |
394 | fun setBlocked _ = raise Fail "Signal.Mask.setBlocked" | |
395 | fun some _ = () | |
396 | fun unblock _ = raise Fail "Signal.Mask.unblock" | |
397 | end | |
398 | ||
399 | fun getHandler _ = raise Fail "Signal.getHandler" | |
400 | fun handled _ = raise Fail "Signal.handled" | |
401 | val restart = ref true | |
402 | fun setHandler _ = raise Fail "Signal.setHandler" | |
403 | fun suspend _ = raise Fail "Signal.suspend" | |
404 | end | |
405 | ||
406 | structure TextIO = MkIO (TextIO) | |
407 | ||
408 | structure Thread = MLtonThread | |
409 | ||
410 | structure Vector = | |
411 | struct | |
412 | open Vector | |
413 | ||
414 | fun create n = | |
415 | let | |
416 | val r = ref (Array.fromList []) | |
417 | val subLim = ref 0 | |
418 | fun sub i = | |
419 | if 0 <= i andalso i < !subLim | |
420 | then Array.sub (!r, i) | |
421 | else raise Subscript | |
422 | val updateLim = ref 0 | |
423 | fun update (i, x) = | |
424 | if 0 <= i andalso i < !updateLim | |
425 | then if i = !updateLim andalso i < n | |
426 | then (r := (Array.tabulate (i + 1, fn j => | |
427 | if i = j | |
428 | then x | |
429 | else Array.sub (!r, j))); | |
430 | subLim := i + 1; | |
431 | updateLim := i + 1) | |
432 | else raise Subscript | |
433 | else | |
434 | Array.update (!r, i, x) | |
435 | val gotIt = ref false | |
436 | fun done () = | |
437 | if !gotIt then | |
438 | raise Fail "already got vector" | |
439 | else | |
440 | if n = !updateLim then | |
441 | (gotIt := true; | |
442 | updateLim := 0; | |
443 | Array.vector (!r)) | |
444 | else | |
445 | raise Fail "vector not full" | |
446 | in | |
447 | {done = done, | |
448 | sub = sub, | |
449 | update = update} | |
450 | end | |
451 | ||
452 | fun unfoldi (n, a, f) = | |
453 | let | |
454 | val r = ref a | |
455 | val v = | |
456 | tabulate (n, fn i => | |
457 | let | |
458 | val (b, a') = f (i, !r) | |
459 | val _ = r := a' | |
460 | in | |
461 | b | |
462 | end) | |
463 | in | |
464 | (v, !r) | |
465 | end | |
466 | end | |
467 | ||
468 | structure Weak = | |
469 | struct | |
470 | type 'a t = 'a | |
471 | ||
472 | val get = SOME | |
473 | fun new x = x | |
474 | end | |
475 | ||
476 | structure World = | |
477 | struct | |
478 | datatype status = Clone | Original | |
479 | fun load _ = raise Fail "World.load" | |
480 | fun save _ = raise Fail "World.save" | |
481 | fun saveThread _ = raise Fail "World.saveThread" | |
482 | end | |
483 | ||
484 | structure Word = MkWord(Word) | |
485 | structure Word8 = MkWord(Word8) | |
486 | end |