src/Pure/ML-Systems/mosml.ML
author haftmann
Tue Oct 20 16:13:01 2009 +0200 (2009-10-20)
changeset 33037 b22e44496dc2
parent 32776 1504f9c2d060
child 34136 3dcb46ae6185
permissions -rw-r--r--
replaced old_style infixes eq_set, subset, union, inter and variants by generic versions
wenzelm@9254
     1
(*  Title:      Pure/ML-Systems/mosml.ML
wenzelm@9254
     2
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
wenzelm@29284
     3
    Author:     Makarius
wenzelm@9254
     4
wenzelm@17491
     5
Compatibility file for Moscow ML 2.01
wenzelm@9254
     6
wenzelm@17491
     7
NOTE: saving images does not work; may run it interactively as follows:
wenzelm@9254
     8
wenzelm@23826
     9
$ cd Isabelle/src/Pure
wenzelm@29284
    10
$ isabelle-process RAW_ML_SYSTEM
wenzelm@9254
    11
> val ml_system = "mosml";
wenzelm@9254
    12
> use "ML-Systems/mosml.ML";
wenzelm@9254
    13
> use "ROOT.ML";
wenzelm@16470
    14
> Session.finish ();
wenzelm@23836
    15
> cd "../FOL";
wenzelm@16470
    16
> use "ROOT.ML";
wenzelm@24808
    17
> Session.finish ();
wenzelm@24808
    18
> cd "../ZF";
wenzelm@24808
    19
> use "ROOT.ML";
wenzelm@9254
    20
*)
wenzelm@9254
    21
wenzelm@9254
    22
(** ML system related **)
wenzelm@9254
    23
wenzelm@24597
    24
val ml_system_fix_ints = false;
wenzelm@24597
    25
wenzelm@26474
    26
fun forget_structure _ = ();
wenzelm@26474
    27
wenzelm@16517
    28
load "Obj";
wenzelm@29284
    29
load "Word";
wenzelm@9254
    30
load "Bool";
wenzelm@9254
    31
load "Int";
wenzelm@9254
    32
load "Real";
wenzelm@9254
    33
load "ListPair";
wenzelm@9254
    34
load "OS";
wenzelm@9254
    35
load "Process";
wenzelm@9254
    36
load "FileSys";
wenzelm@21298
    37
load "IO";
wenzelm@29285
    38
load "CharVector";
wenzelm@9254
    39
wenzelm@28443
    40
exception Interrupt;
wenzelm@31427
    41
fun reraise exn = raise exn;
wenzelm@28443
    42
wenzelm@32776
    43
use "ML-Systems/unsynchronized.ML";
wenzelm@23965
    44
use "ML-Systems/exn.ML";
wenzelm@25732
    45
use "ML-Systems/universal.ML";
wenzelm@28489
    46
use "ML-Systems/thread_dummy.ML";
wenzelm@24688
    47
use "ML-Systems/multithreading.ML";
wenzelm@24688
    48
use "ML-Systems/time_limit.ML";
wenzelm@28268
    49
use "ML-Systems/ml_name_space.ML";
wenzelm@30619
    50
use "ML-Systems/ml_pretty.ML";
wenzelm@30672
    51
use "ML-Systems/use_context.ML";
wenzelm@23921
    52
wenzelm@23921
    53
wenzelm@16517
    54
(*low-level pointer equality*)
wenzelm@16517
    55
local val cast : 'a -> int = Obj.magic
wenzelm@16517
    56
in fun pointer_eq (x:'a, y:'a) = (cast x = cast y) end;
wenzelm@16517
    57
wenzelm@16469
    58
(*proper implementation available?*)
wenzelm@16469
    59
structure IntInf =
wenzelm@16469
    60
struct
wenzelm@24808
    61
  fun divMod (x, y) = (x div y, x mod y);
wenzelm@29284
    62
wenzelm@29284
    63
  local
wenzelm@29284
    64
    fun log 1 a = a
wenzelm@29284
    65
      | log n a = log (n div 2) (a + 1);
wenzelm@29284
    66
  in
wenzelm@29284
    67
    fun log2 n = if n > 0 then log n 0 else raise Domain;
wenzelm@29284
    68
  end;
wenzelm@29284
    69
wenzelm@16469
    70
  open Int;
wenzelm@16469
    71
end;
wenzelm@16469
    72
wenzelm@27003
    73
structure Substring =
wenzelm@27003
    74
struct
wenzelm@27003
    75
  open Substring;
wenzelm@27003
    76
  val full = all;
wenzelm@27003
    77
end;
wenzelm@27003
    78
wenzelm@16469
    79
structure Real =
wenzelm@16469
    80
struct
wenzelm@16469
    81
  open Real;
wenzelm@16469
    82
  val realFloor = real o floor;
wenzelm@16469
    83
end;
wenzelm@16469
    84
wenzelm@17491
    85
structure String =
wenzelm@17491
    86
struct
wenzelm@17491
    87
  fun isSuffix s1 s2 =
wenzelm@17491
    88
    let val n1 = size s1 and n2 = size s2
wenzelm@17491
    89
    in if n1 = n2 then s1 = s2 else n1 <= n2 andalso String.substring (s2, n2 - n1, n1) = s1 end;
wenzelm@17491
    90
  open String;
wenzelm@17491
    91
end;
wenzelm@17491
    92
wenzelm@16469
    93
structure Time =
wenzelm@16469
    94
struct
wenzelm@16469
    95
  open Time;
wenzelm@16469
    96
  fun toString t = Time.toString t
wenzelm@16469
    97
    handle Overflow => Real.toString (Time.toReal t);   (*workaround Y2004 bug*)
wenzelm@16469
    98
end;
wenzelm@16469
    99
wenzelm@9254
   100
structure OS =
wenzelm@16469
   101
struct
wenzelm@9254
   102
  open OS
wenzelm@28489
   103
  structure Process =
wenzelm@28489
   104
  struct
wenzelm@28489
   105
    open Process
wenzelm@28489
   106
    fun sleep _ = raise Fail "OS.Process.sleep undefined"
wenzelm@28489
   107
  end;
wenzelm@9254
   108
  structure FileSys = FileSys
wenzelm@16469
   109
end;
wenzelm@16993
   110
wenzelm@22252
   111
exception Option = Option.Option;
wenzelm@22252
   112
wenzelm@22252
   113
wenzelm@9254
   114
(*limit the printing depth*)
wenzelm@24329
   115
local
wenzelm@24329
   116
  val depth = ref 10;
wenzelm@24329
   117
in
wenzelm@24329
   118
  fun get_print_depth () = ! depth;
wenzelm@24329
   119
  fun print_depth n =
wenzelm@24329
   120
   (depth := n;
wenzelm@24329
   121
    Meta.printDepth := n div 2;
wenzelm@24329
   122
    Meta.printLength := n);
wenzelm@24329
   123
end;
wenzelm@9254
   124
wenzelm@30625
   125
(*dummy implementation*)
wenzelm@30672
   126
fun toplevel_pp _ _ _ = ();
wenzelm@9254
   127
wenzelm@16681
   128
(*dummy implementation*)
wenzelm@16681
   129
fun ml_prompts p1 p2 = ();
wenzelm@16681
   130
wenzelm@16681
   131
(*dummy implementation*)
wenzelm@16660
   132
fun profile (n: int) f x = f x;
wenzelm@16660
   133
haftmann@18384
   134
(*dummy implementation*)
wenzelm@16681
   135
fun exception_trace f = f ();
wenzelm@9254
   136
haftmann@18384
   137
wenzelm@9254
   138
wenzelm@9254
   139
(** Compiler-independent timing functions **)
wenzelm@9254
   140
wenzelm@9254
   141
load "Timer";
wenzelm@9254
   142
wenzelm@21298
   143
fun start_timing () =
wenzelm@30187
   144
  let
wenzelm@30187
   145
    val timer = Timer.startCPUTimer ();
wenzelm@30187
   146
    val time = Timer.checkCPUTimer timer;
wenzelm@30187
   147
  in (timer, time) end;
wenzelm@21298
   148
wenzelm@30187
   149
fun end_timing (timer, {gc, sys, usr}) =
wenzelm@30187
   150
  let
wenzelm@30187
   151
    open Time;  (*...for Time.toString, Time.+ and Time.- *)
wenzelm@30187
   152
    val {gc = gc2, sys = sys2, usr = usr2} = Timer.checkCPUTimer timer;
wenzelm@30187
   153
    val user = usr2 - usr + gc2 - gc;
wenzelm@30187
   154
    val all = user + sys2 - sys;
wenzelm@30187
   155
    val message = "User " ^ toString user ^ "  All "^ toString all ^ " secs" handle Time => "";
wenzelm@30187
   156
  in {message = message, user = user, all = all} end;
wenzelm@21298
   157
wenzelm@21298
   158
wenzelm@21298
   159
(* SML basis library fixes *)
wenzelm@21298
   160
wenzelm@21298
   161
structure TextIO =
wenzelm@21298
   162
struct
wenzelm@21298
   163
  fun canInput _ = raise IO.Io {cause = Fail "undefined", function = "canInput", name = ""};
wenzelm@21298
   164
  open TextIO;
wenzelm@23836
   165
  fun inputLine is =
wenzelm@23836
   166
    let val s = TextIO.inputLine is
wenzelm@23836
   167
    in if s = "" then NONE else SOME s end;
wenzelm@28489
   168
  fun getOutstream _ = ();
wenzelm@28489
   169
  structure StreamIO =
wenzelm@28489
   170
  struct
wenzelm@28489
   171
    fun setBufferMode _ = ();
wenzelm@28489
   172
  end
wenzelm@28489
   173
end;
wenzelm@28489
   174
wenzelm@28489
   175
structure IO =
wenzelm@28489
   176
struct
wenzelm@28489
   177
  open IO;
wenzelm@28489
   178
  val BLOCK_BUF = ();
wenzelm@21298
   179
end;
wenzelm@21298
   180
wenzelm@9254
   181
wenzelm@9254
   182
(* ML command execution *)
wenzelm@9254
   183
wenzelm@9254
   184
(*Can one redirect 'use' directly to an instream?*)
wenzelm@30672
   185
fun use_text ({tune_source, ...}: use_context) _ _ txt =
wenzelm@9254
   186
  let
wenzelm@9254
   187
    val tmp_name = FileSys.tmpName ();
wenzelm@9254
   188
    val tmp_file = TextIO.openOut tmp_name;
wenzelm@9254
   189
  in
wenzelm@30672
   190
    TextIO.output (tmp_file, tune_source txt);
wenzelm@9254
   191
    TextIO.closeOut tmp_file;
wenzelm@9254
   192
    use tmp_name;
wenzelm@9254
   193
    FileSys.remove tmp_name
wenzelm@9254
   194
  end;
wenzelm@9254
   195
wenzelm@30672
   196
fun use_file _ _ name = use name;
wenzelm@21770
   197
wenzelm@9254
   198
wenzelm@9254
   199
wenzelm@16993
   200
(** interrupts **)      (*Note: may get into race conditions*)
wenzelm@9254
   201
wenzelm@9254
   202
(* FIXME proper implementation available? *)
wenzelm@9254
   203
wenzelm@26084
   204
fun interruptible f x = f x;
wenzelm@26084
   205
fun uninterruptible f x = f (fn (g: 'c -> 'd) => g) x;
wenzelm@9254
   206
wenzelm@9254
   207
wenzelm@9254
   208
wenzelm@9254
   209
(** OS related **)
wenzelm@9254
   210
wenzelm@26223
   211
(*dummy implementation*)
wenzelm@26223
   212
structure Posix =
wenzelm@26223
   213
struct
wenzelm@26223
   214
  structure ProcEnv =
wenzelm@26223
   215
  struct
wenzelm@26223
   216
    fun getpid () = 0;
wenzelm@26223
   217
  end;  
wenzelm@26223
   218
end;
wenzelm@26223
   219
wenzelm@26223
   220
local
wenzelm@26223
   221
wenzelm@26223
   222
fun read_file name =
wenzelm@26223
   223
  let val is = TextIO.openIn name
wenzelm@26504
   224
  in Exn.release (Exn.capture TextIO.inputAll is before TextIO.closeIn is) end;
wenzelm@26223
   225
wenzelm@26223
   226
fun write_file name txt =
wenzelm@26223
   227
  let val os = TextIO.openOut name
wenzelm@26504
   228
  in Exn.release (Exn.capture TextIO.output (os, txt) before TextIO.closeOut os) end;
wenzelm@26223
   229
wenzelm@26223
   230
in
wenzelm@26223
   231
wenzelm@26223
   232
fun system_out script =
wenzelm@26223
   233
  let
wenzelm@26223
   234
    val script_name = OS.FileSys.tmpName ();
wenzelm@26223
   235
    val _ = write_file script_name script;
wenzelm@26223
   236
wenzelm@26223
   237
    val output_name = OS.FileSys.tmpName ();
wenzelm@26223
   238
wenzelm@26223
   239
    val status =
wenzelm@26223
   240
      OS.Process.system ("perl -w \"$ISABELLE_HOME/lib/scripts/system.pl\" nogroup " ^
wenzelm@26223
   241
        script_name ^ " /dev/null " ^ output_name);
wenzelm@26223
   242
    val rc = if status = OS.Process.success then 0 else 1;
wenzelm@26223
   243
wenzelm@26223
   244
    val output = read_file output_name handle IO.Io _ => "";
wenzelm@26223
   245
    val _ = OS.FileSys.remove script_name handle OS.SysErr _ => ();
wenzelm@26223
   246
    val _ = OS.FileSys.remove output_name handle OS.SysErr _ => ();
wenzelm@26223
   247
  in (output, rc) end;
wenzelm@26223
   248
wenzelm@26223
   249
end;
wenzelm@26223
   250
wenzelm@23826
   251
val cd = OS.FileSys.chDir;
wenzelm@23826
   252
val pwd = OS.FileSys.getDir;
wenzelm@23826
   253
wenzelm@28489
   254
val process_id = Int.toString o Posix.ProcEnv.getpid;
wenzelm@17824
   255
wenzelm@9254
   256
fun getenv var =
wenzelm@9254
   257
  (case Process.getEnv var of
wenzelm@9254
   258
    NONE => ""
wenzelm@9254
   259
  | SOME txt => txt);