src/Pure/ML-Systems/mosml.ML
author berghofe
Mon Jan 21 14:18:49 2008 +0100 (2008-01-21)
changeset 25939 ddea202704b4
parent 25732 308315ee2b6d
child 26084 a7475459c740
permissions -rw-r--r--
Removed Logic.auto_rename.
wenzelm@9254
     1
(*  Title:      Pure/ML-Systems/mosml.ML
wenzelm@9254
     2
    ID:         $Id$
wenzelm@9254
     3
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
wenzelm@9254
     4
    Copyright   1999  University of Cambridge
wenzelm@9254
     5
wenzelm@17491
     6
Compatibility file for Moscow ML 2.01
wenzelm@9254
     7
wenzelm@17491
     8
NOTE: saving images does not work; may run it interactively as follows:
wenzelm@9254
     9
wenzelm@23826
    10
$ cd Isabelle/src/Pure
wenzelm@9254
    11
$ isabelle RAW_ML_SYSTEM
wenzelm@9254
    12
> val ml_system = "mosml";
wenzelm@9254
    13
> use "ML-Systems/mosml.ML";
wenzelm@9254
    14
> use "ROOT.ML";
wenzelm@16470
    15
> Session.finish ();
wenzelm@23836
    16
> cd "../FOL";
wenzelm@16470
    17
> use "ROOT.ML";
wenzelm@24808
    18
> Session.finish ();
wenzelm@24808
    19
> cd "../ZF";
wenzelm@24808
    20
> use "ROOT.ML";
wenzelm@9254
    21
*)
wenzelm@9254
    22
wenzelm@9254
    23
(** ML system related **)
wenzelm@9254
    24
wenzelm@24597
    25
val ml_system_fix_ints = false;
wenzelm@24597
    26
wenzelm@16517
    27
load "Obj";
wenzelm@9254
    28
load "Bool";
wenzelm@9254
    29
load "Int";
wenzelm@9254
    30
load "Real";
wenzelm@9254
    31
load "ListPair";
wenzelm@9254
    32
load "OS";
wenzelm@9254
    33
load "Process";
wenzelm@9254
    34
load "FileSys";
wenzelm@21298
    35
load "IO";
wenzelm@9254
    36
wenzelm@23965
    37
use "ML-Systems/exn.ML";
wenzelm@25732
    38
use "ML-Systems/universal.ML";
wenzelm@24688
    39
use "ML-Systems/multithreading.ML";
wenzelm@24688
    40
use "ML-Systems/time_limit.ML";
wenzelm@23921
    41
wenzelm@23921
    42
wenzelm@16517
    43
(*low-level pointer equality*)
wenzelm@16517
    44
local val cast : 'a -> int = Obj.magic
wenzelm@16517
    45
in fun pointer_eq (x:'a, y:'a) = (cast x = cast y) end;
wenzelm@16517
    46
wenzelm@16469
    47
(*proper implementation available?*)
wenzelm@16469
    48
structure IntInf =
wenzelm@16469
    49
struct
wenzelm@24808
    50
  fun divMod (x, y) = (x div y, x mod y);
wenzelm@16469
    51
  open Int;
wenzelm@16469
    52
end;
wenzelm@16469
    53
wenzelm@16469
    54
structure Real =
wenzelm@16469
    55
struct
wenzelm@16469
    56
  open Real;
wenzelm@16469
    57
  val realFloor = real o floor;
wenzelm@16469
    58
end;
wenzelm@16469
    59
wenzelm@17491
    60
structure String =
wenzelm@17491
    61
struct
wenzelm@17491
    62
  fun isSuffix s1 s2 =
wenzelm@17491
    63
    let val n1 = size s1 and n2 = size s2
wenzelm@17491
    64
    in if n1 = n2 then s1 = s2 else n1 <= n2 andalso String.substring (s2, n2 - n1, n1) = s1 end;
wenzelm@17491
    65
  open String;
wenzelm@17491
    66
end;
wenzelm@17491
    67
wenzelm@16469
    68
structure Time =
wenzelm@16469
    69
struct
wenzelm@16469
    70
  open Time;
wenzelm@16469
    71
  fun toString t = Time.toString t
wenzelm@16469
    72
    handle Overflow => Real.toString (Time.toReal t);   (*workaround Y2004 bug*)
wenzelm@16469
    73
end;
wenzelm@16469
    74
wenzelm@9254
    75
structure OS =
wenzelm@16469
    76
struct
wenzelm@9254
    77
  open OS
wenzelm@9254
    78
  structure Process = Process
wenzelm@9254
    79
  structure FileSys = FileSys
wenzelm@16469
    80
end;
wenzelm@16993
    81
wenzelm@22252
    82
exception Option = Option.Option;
wenzelm@22252
    83
wenzelm@22252
    84
wenzelm@9254
    85
(*limit the printing depth*)
wenzelm@24329
    86
local
wenzelm@24329
    87
  val depth = ref 10;
wenzelm@24329
    88
in
wenzelm@24329
    89
  fun get_print_depth () = ! depth;
wenzelm@24329
    90
  fun print_depth n =
wenzelm@24329
    91
   (depth := n;
wenzelm@24329
    92
    Meta.printDepth := n div 2;
wenzelm@24329
    93
    Meta.printLength := n);
wenzelm@24329
    94
end;
wenzelm@9254
    95
wenzelm@24290
    96
(*interface for toplevel pretty printers, see also Pure/pure_setup.ML*)
wenzelm@9254
    97
(*the documentation refers to an installPP but I couldn't fine it!*)
wenzelm@9254
    98
fun make_pp path pprint = ();
wenzelm@9254
    99
fun install_pp _ = ();
wenzelm@9254
   100
wenzelm@16681
   101
(*dummy implementation*)
wenzelm@16681
   102
fun ml_prompts p1 p2 = ();
wenzelm@16681
   103
wenzelm@16681
   104
(*dummy implementation*)
wenzelm@16660
   105
fun profile (n: int) f x = f x;
wenzelm@16660
   106
haftmann@18384
   107
(*dummy implementation*)
wenzelm@16681
   108
fun exception_trace f = f ();
wenzelm@9254
   109
haftmann@18384
   110
(*dummy implementation*)
haftmann@18384
   111
fun print x = x;
haftmann@18384
   112
wenzelm@9254
   113
wenzelm@9254
   114
(** Compiler-independent timing functions **)
wenzelm@9254
   115
wenzelm@9254
   116
load "Timer";
wenzelm@9254
   117
wenzelm@21298
   118
fun start_timing () =
wenzelm@21298
   119
  let val CPUtimer = Timer.startCPUTimer();
wenzelm@21298
   120
      val time = Timer.checkCPUTimer(CPUtimer)
wenzelm@21298
   121
  in  (CPUtimer,time)  end;
wenzelm@21298
   122
wenzelm@21298
   123
fun end_timing (CPUtimer, {gc,sys,usr}) =
wenzelm@21298
   124
  let open Time  (*...for Time.toString, Time.+ and Time.- *)
wenzelm@21298
   125
      val {gc=gc2,sys=sys2,usr=usr2} = Timer.checkCPUTimer(CPUtimer)
wenzelm@21298
   126
  in  "User " ^ toString (usr2-usr) ^
wenzelm@21298
   127
      "  GC " ^ toString (gc2-gc) ^
wenzelm@21298
   128
      "  All "^ toString (sys2-sys + usr2-usr + gc2-gc) ^
wenzelm@21298
   129
      " secs"
wenzelm@21298
   130
      handle Time => ""
wenzelm@21298
   131
  end;
wenzelm@21298
   132
wenzelm@21298
   133
fun check_timer timer =
wenzelm@21298
   134
  let val {sys, usr, gc} = Timer.checkCPUTimer timer
wenzelm@21298
   135
  in (sys, usr, gc) end;
wenzelm@21298
   136
wenzelm@21298
   137
wenzelm@21298
   138
(* SML basis library fixes *)
wenzelm@21298
   139
wenzelm@21298
   140
structure TextIO =
wenzelm@21298
   141
struct
wenzelm@21298
   142
  fun canInput _ = raise IO.Io {cause = Fail "undefined", function = "canInput", name = ""};
wenzelm@21298
   143
  open TextIO;
wenzelm@23836
   144
  fun inputLine is =
wenzelm@23836
   145
    let val s = TextIO.inputLine is
wenzelm@23836
   146
    in if s = "" then NONE else SOME s end;
wenzelm@21298
   147
end;
wenzelm@21298
   148
wenzelm@9254
   149
wenzelm@9254
   150
(* ML command execution *)
wenzelm@9254
   151
wenzelm@9254
   152
(*Can one redirect 'use' directly to an instream?*)
wenzelm@24808
   153
fun use_text (tune: string -> string) _ _ _ txt =
wenzelm@9254
   154
  let
wenzelm@9254
   155
    val tmp_name = FileSys.tmpName ();
wenzelm@9254
   156
    val tmp_file = TextIO.openOut tmp_name;
wenzelm@9254
   157
  in
wenzelm@24808
   158
    TextIO.output (tmp_file, tune txt);
wenzelm@9254
   159
    TextIO.closeOut tmp_file;
wenzelm@9254
   160
    use tmp_name;
wenzelm@9254
   161
    FileSys.remove tmp_name
wenzelm@9254
   162
  end;
wenzelm@9254
   163
wenzelm@24808
   164
fun use_file _ _ _ name = use name;
wenzelm@21770
   165
wenzelm@9254
   166
wenzelm@9254
   167
wenzelm@16993
   168
(** interrupts **)      (*Note: may get into race conditions*)
wenzelm@9254
   169
wenzelm@9254
   170
(* FIXME proper implementation available? *)
wenzelm@9254
   171
wenzelm@9254
   172
exception Interrupt;
wenzelm@9254
   173
wenzelm@16993
   174
fun ignore_interrupt f x = f x;
wenzelm@12988
   175
fun raise_interrupt f x = f x;
wenzelm@9254
   176
wenzelm@9254
   177
wenzelm@9254
   178
wenzelm@9254
   179
(** OS related **)
wenzelm@9254
   180
wenzelm@23826
   181
(* current directory *)
wenzelm@23826
   182
wenzelm@23826
   183
val cd = OS.FileSys.chDir;
wenzelm@23826
   184
val pwd = OS.FileSys.getDir;
wenzelm@23826
   185
wenzelm@23826
   186
wenzelm@9254
   187
(* system command execution *)
wenzelm@9254
   188
wenzelm@9254
   189
(*execute Unix command which doesn't take any input from stdin and
wenzelm@9254
   190
  sends its output to stdout; could be done more easily by Unix.execute,
wenzelm@9254
   191
  but that function doesn't use the PATH*)
wenzelm@9254
   192
fun execute command =
wenzelm@9254
   193
  let
wenzelm@9254
   194
    val tmp_name = FileSys.tmpName ();
wenzelm@16993
   195
    val is = (Process.system (command ^ " > " ^ tmp_name); TextIO.openIn tmp_name);
wenzelm@9254
   196
    val result = TextIO.inputAll is;
wenzelm@9254
   197
  in
wenzelm@9254
   198
    TextIO.closeIn is;
wenzelm@9254
   199
    FileSys.remove tmp_name;
wenzelm@9254
   200
    result
wenzelm@9254
   201
  end;
wenzelm@9254
   202
wenzelm@9254
   203
(*plain version; with return code*)
wenzelm@9254
   204
fun system cmd =
wenzelm@9254
   205
  if Process.system cmd = Process.success then 0 else 1;
wenzelm@9254
   206
wenzelm@9254
   207
wenzelm@17824
   208
val string_of_pid = Int.toString;
wenzelm@17824
   209
wenzelm@17824
   210
wenzelm@9254
   211
(* getenv *)
wenzelm@9254
   212
wenzelm@9254
   213
fun getenv var =
wenzelm@9254
   214
  (case Process.getEnv var of
wenzelm@9254
   215
    NONE => ""
wenzelm@9254
   216
  | SOME txt => txt);