src/Pure/ML-Systems/polyml.ML
author wenzelm
Tue Oct 11 13:28:08 2005 +0200 (2005-10-11)
changeset 17824 36b2978d339a
parent 17077 f5af929f0fb4
child 18504 6574d62fe76b
permissions -rw-r--r--
added string_of_pid;
wenzelm@2341
     1
(*  Title:      Pure/ML-Systems/polyml.ML
wenzelm@2341
     2
    ID:         $Id$
wenzelm@2341
     3
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
wenzelm@2341
     4
    Copyright   1991  University of Cambridge
wenzelm@2341
     5
wenzelm@14870
     6
Compatibility file for Poly/ML (version 4.0, 4.1, 4.1.x).
wenzelm@2341
     7
*)
wenzelm@2341
     8
wenzelm@16374
     9
(** ML system and platform related **)
wenzelm@16374
    10
wenzelm@17077
    11
(* String compatibility *)
wenzelm@17077
    12
wenzelm@17077
    13
structure String =
wenzelm@17077
    14
struct
wenzelm@17077
    15
  fun isSuffix s1 s2 =
wenzelm@17077
    16
    let val n1 = size s1 and n2 = size s2
wenzelm@17077
    17
    in if n1 = n2 then s1 = s2 else n1 <= n2 andalso String.substring (s2, n2 - n1, n1) = s1 end;
wenzelm@17077
    18
  open String;
wenzelm@17077
    19
end;
wenzelm@17077
    20
wenzelm@17077
    21
wenzelm@16374
    22
(* cygwin *)
wenzelm@16374
    23
wenzelm@17077
    24
val cygwin_platform = String.isSuffix "cygwin" ml_platform;
wenzelm@16374
    25
fun if_cygwin f x = if cygwin_platform then f x else ();
wenzelm@16374
    26
fun unless_cygwin f x = if not cygwin_platform then f x else ();
wenzelm@16374
    27
wenzelm@2341
    28
wenzelm@16516
    29
(*low-level pointer equality*)
wenzelm@16516
    30
val pointer_eq = Address.wordEq;
wenzelm@16502
    31
wenzelm@16502
    32
wenzelm@11078
    33
(* old Poly/ML emulation *)
wenzelm@2341
    34
wenzelm@11078
    35
local
wenzelm@11078
    36
  val orig_exit = exit;
wenzelm@11078
    37
in
wenzelm@11078
    38
  open PolyML;
wenzelm@11078
    39
  val exit = orig_exit;
wenzelm@11078
    40
  fun quit () = exit 0;
wenzelm@7148
    41
end;
paulson@6042
    42
wenzelm@2341
    43
wenzelm@11078
    44
(* restore old-style character / string functions *)
wenzelm@3588
    45
wenzelm@11078
    46
val ord = SML90.ord;
wenzelm@11078
    47
val chr = SML90.chr;
wenzelm@11078
    48
val explode = SML90.explode;
wenzelm@11078
    49
val implode = SML90.implode;
wenzelm@11078
    50
wenzelm@14870
    51
skalberg@14519
    52
(* compiler-independent timing functions *)
wenzelm@2341
    53
skalberg@14519
    54
use "ML-Systems/cpu-timer-basis.ML";
wenzelm@2341
    55
wenzelm@14870
    56
webertj@14850
    57
(* bounded time execution *)
webertj@14850
    58
wenzelm@16374
    59
unless_cygwin
wenzelm@16374
    60
  use "ML-Systems/polyml-time-limit.ML";
webertj@14850
    61
wenzelm@14870
    62
wenzelm@4977
    63
(* prompts *)
wenzelm@4977
    64
wenzelm@4984
    65
fun ml_prompts p1 p2 = (PolyML.Compiler.prompt1 := p1; PolyML.Compiler.prompt2 := p2);
wenzelm@4977
    66
wenzelm@4977
    67
wenzelm@3588
    68
(* toplevel pretty printing (see also Pure/install_pp.ML) *)
wenzelm@2341
    69
wenzelm@11078
    70
fun make_pp _ pprint (str, blk, brk, en) _ _ obj =
wenzelm@2341
    71
  pprint obj (str, fn ind => blk (ind, false), fn wd => brk (wd, 0),
wenzelm@2341
    72
    fn () => brk (99999, 0), en);
wenzelm@2341
    73
wenzelm@2341
    74
wenzelm@3588
    75
(* ML command execution -- 'eval' *)
wenzelm@3588
    76
wenzelm@7890
    77
local
wenzelm@7890
    78
wenzelm@7890
    79
fun drop_last [] = []
wenzelm@7890
    80
  | drop_last [x] = []
wenzelm@7890
    81
  | drop_last (x :: xs) = x :: drop_last xs;
wenzelm@7890
    82
wenzelm@7890
    83
in
wenzelm@7890
    84
wenzelm@10914
    85
fun use_text (print, err) verbose txt =
wenzelm@3588
    86
  let
wenzelm@5090
    87
    val in_buffer = ref (explode txt);
wenzelm@5090
    88
    val out_buffer = ref ([]: string list);
wenzelm@15832
    89
    fun output () = implode (drop_last (rev (! out_buffer)));
wenzelm@5090
    90
wenzelm@5038
    91
    fun get () =
wenzelm@5090
    92
      (case ! in_buffer of
wenzelm@5038
    93
        [] => ""
wenzelm@5090
    94
      | c :: cs => (in_buffer := cs; c));
wenzelm@5090
    95
    fun put s = out_buffer := s :: ! out_buffer;
wenzelm@5090
    96
wenzelm@5038
    97
    fun exec () =
wenzelm@5090
    98
      (case ! in_buffer of
wenzelm@5038
    99
        [] => ()
wenzelm@5090
   100
      | _ => (PolyML.compiler (get, put) (); exec ()));
wenzelm@5090
   101
  in
wenzelm@10914
   102
    exec () handle exn => (err (output ()); raise exn);
wenzelm@10914
   103
    if verbose then print (output ()) else ()
wenzelm@5090
   104
  end;
wenzelm@3588
   105
wenzelm@11078
   106
end;
wenzelm@11078
   107
wenzelm@11078
   108
wenzelm@15832
   109
(*eval command line arguments*)
wenzelm@15832
   110
local
wenzelm@15832
   111
  fun println s =
wenzelm@15832
   112
    (TextIO.output (TextIO.stdOut, s ^ "\n"); TextIO.flushOut TextIO.stdOut);
wenzelm@15851
   113
  val eval = use_text (println, println) true;
wenzelm@15832
   114
in
wenzelm@15832
   115
  val _ = PolyML.onEntry (fn () => app eval (CommandLine.arguments ()));
wenzelm@15832
   116
end;
wenzelm@15832
   117
wenzelm@15832
   118
wenzelm@11078
   119
wenzelm@11078
   120
(** interrupts **)
wenzelm@11078
   121
wenzelm@11078
   122
exception Interrupt = SML90.Interrupt;
wenzelm@11078
   123
wenzelm@11078
   124
local
wenzelm@11078
   125
wenzelm@12989
   126
fun capture f x = ((f x): unit; NONE) handle exn => SOME exn;
wenzelm@11078
   127
wenzelm@12989
   128
fun release NONE = ()
wenzelm@12989
   129
  | release (SOME exn) = raise exn;
wenzelm@3588
   130
wenzelm@11078
   131
val sig_int = 2;
wenzelm@11078
   132
wenzelm@11078
   133
fun change_signal new_handler f x =
wenzelm@11078
   134
  let
wenzelm@11078
   135
    (*RACE wrt. other signals*)
wenzelm@11078
   136
    val old_handler = Signal.signal (sig_int, new_handler);
wenzelm@11078
   137
    val result = capture f x;
wenzelm@11078
   138
    val _ = Signal.signal (sig_int, old_handler);
wenzelm@11078
   139
  in release result end;
wenzelm@5813
   140
wenzelm@11078
   141
val default_handler = Signal.SIG_HANDLE (fn _ => Process.interruptConsoleProcesses ());
wenzelm@11078
   142
wenzelm@11078
   143
in
wenzelm@11078
   144
wenzelm@11078
   145
val _ = Signal.signal (sig_int, default_handler);
wenzelm@11078
   146
wenzelm@12989
   147
fun ignore_interrupt f = change_signal Signal.SIG_IGN f;
wenzelm@12989
   148
fun raise_interrupt f = change_signal default_handler f;
wenzelm@11078
   149
wenzelm@11078
   150
end;
wenzelm@5813
   151
wenzelm@5813
   152
wenzelm@5813
   153
wenzelm@3588
   154
(** OS related **)
wenzelm@2341
   155
wenzelm@16659
   156
unless_cygwin
wenzelm@16659
   157
  use "ML-Systems/polyml-posix.ML";
wenzelm@16659
   158
wenzelm@16659
   159
wenzelm@3588
   160
(* system command execution *)
wenzelm@2341
   161
wenzelm@3588
   162
(*execute Unix command which doesn't take any input from stdin and
wenzelm@11078
   163
  sends its output to stdout; could be done more easily by Unix.execute,
wenzelm@11078
   164
  but that function doesn't use the PATH*)
wenzelm@3588
   165
fun execute command =
wenzelm@3588
   166
  let
wenzelm@11078
   167
    val tmp_name = OS.FileSys.tmpName ();
wenzelm@11078
   168
    val is = (OS.Process.system (command ^ " > " ^ tmp_name); TextIO.openIn tmp_name);
wenzelm@11078
   169
    val result = TextIO.inputAll is;
wenzelm@11078
   170
  in
wenzelm@11078
   171
    TextIO.closeIn is;
wenzelm@11078
   172
    OS.FileSys.remove tmp_name;
wenzelm@11078
   173
    result
wenzelm@11078
   174
  end;
wenzelm@7855
   175
wenzelm@11078
   176
(*plain version; with return code*)
wenzelm@11078
   177
fun system cmd =
wenzelm@11078
   178
  if OS.Process.isSuccess (OS.Process.system cmd) then 0 else 1;
wenzelm@2341
   179
wenzelm@2341
   180
wenzelm@17824
   181
(*Convert a process ID to a decimal string (chiefly for tracing)*)
wenzelm@17824
   182
fun string_of_pid pid = 
wenzelm@17824
   183
    Word.fmt StringCvt.DEC (Word.fromLargeWord (Posix.Process.pidToWord pid));
wenzelm@17824
   184
wenzelm@17824
   185
wenzelm@3588
   186
(* getenv *)
wenzelm@3588
   187
wenzelm@11078
   188
fun getenv var =
wenzelm@11078
   189
  (case OS.Process.getEnv var of
wenzelm@11078
   190
    NONE => ""
wenzelm@11078
   191
  | SOME txt => txt);
paulson@15028
   192
paulson@15028
   193
wenzelm@16659
   194
(* profile execution *)
wenzelm@16659
   195
wenzelm@16659
   196
local
wenzelm@16659
   197
wenzelm@16659
   198
fun no_profile () =
wenzelm@16659
   199
  RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler 0;
paulson@15028
   200
wenzelm@16659
   201
in
paulson@15699
   202
wenzelm@16659
   203
fun profile 0 f x = f x
wenzelm@16659
   204
  | profile n f x =
wenzelm@16659
   205
     (RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler n;
wenzelm@16659
   206
      let val y = f x handle exn => (no_profile (); raise exn)
wenzelm@16659
   207
      in no_profile (); y end);
wenzelm@16659
   208
wenzelm@16659
   209
end;