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