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