src/Pure/ML-Systems/polyml.ML
author wenzelm
Wed Nov 26 14:35:55 2014 +0100 (2014-11-26 ago)
changeset 59055 5a7157b8e870
parent 57834 0d295e339f52
child 59127 723b11f8ffbf
permissions -rw-r--r--
more informative failure of protocol commands, with exception trace;
eliminated obsolete Runtime.TERMINATE (left-over from former 'exit' command);
     1 (*  Title:      Pure/ML-Systems/polyml.ML
     2     Author:     Makarius
     3 
     4 Compatibility wrapper for Poly/ML.
     5 *)
     6 
     7 (* ML name space *)
     8 
     9 structure ML_Name_Space =
    10 struct
    11   open PolyML.NameSpace;
    12   type T = PolyML.NameSpace.nameSpace;
    13   val global = PolyML.globalNameSpace;
    14   val initial_val =
    15     List.filter (fn (a, _) => a <> "use" andalso a <> "exit" andalso a <> "commit")
    16       (#allVal global ());
    17   val initial_type = #allType global ();
    18   val initial_fixity = #allFix global ();
    19   val initial_structure = #allStruct global ();
    20   val initial_signature = #allSig global ();
    21   val initial_functor = #allFunct global ();
    22 end;
    23 
    24 
    25 (* ML system operations *)
    26 
    27 use "ML-Systems/ml_system.ML";
    28 
    29 if ML_System.name = "polyml-5.3.0"
    30 then use "ML-Systems/share_common_data_polyml-5.3.0.ML"
    31 else ();
    32 
    33 structure ML_System =
    34 struct
    35 
    36 open ML_System;
    37 
    38 fun share_common_data () = PolyML.shareCommonData PolyML.rootFunction;
    39 val save_state = PolyML.SaveState.saveState;
    40 
    41 end;
    42 
    43 
    44 (* exceptions *)
    45 
    46 fun reraise exn =
    47   (case PolyML.exceptionLocation exn of
    48     NONE => raise exn
    49   | SOME location => PolyML.raiseWithLocation (exn, location));
    50 
    51 exception Interrupt = SML90.Interrupt;
    52 
    53 use "General/exn.ML";
    54 
    55 
    56 (* multithreading *)
    57 
    58 val seconds = Time.fromReal;
    59 
    60 if List.exists (fn s => s = "SingleAssignment") (PolyML.Compiler.structureNames ())
    61 then ()
    62 else use "ML-Systems/single_assignment_polyml.ML";
    63 
    64 open Thread;
    65 use "ML-Systems/multithreading.ML";
    66 use "ML-Systems/multithreading_polyml.ML";
    67 
    68 use "ML-Systems/unsynchronized.ML";
    69 val _ = PolyML.Compiler.forgetValue "ref";
    70 val _ = PolyML.Compiler.forgetType "ref";
    71 
    72 
    73 (* pervasive environment *)
    74 
    75 val _ = PolyML.Compiler.forgetValue "isSome";
    76 val _ = PolyML.Compiler.forgetValue "getOpt";
    77 val _ = PolyML.Compiler.forgetValue "valOf";
    78 val _ = PolyML.Compiler.forgetValue "foldl";
    79 val _ = PolyML.Compiler.forgetValue "foldr";
    80 val _ = PolyML.Compiler.forgetValue "print";
    81 val _ = PolyML.Compiler.forgetValue "explode";
    82 val _ = PolyML.Compiler.forgetValue "concat";
    83 
    84 val ord = SML90.ord;
    85 val chr = SML90.chr;
    86 val raw_explode = SML90.explode;
    87 val implode = SML90.implode;
    88 
    89 val io_buffer_size = 4096;
    90 
    91 fun quit () = exit 0;
    92 
    93 
    94 (* ML runtime system *)
    95 
    96 fun print_exception_trace (_: exn -> string) (_: string -> unit) = PolyML.exception_trace;
    97 val timing = PolyML.timing;
    98 val profiling = PolyML.profiling;
    99 
   100 fun profile 0 f x = f x
   101   | profile n f x =
   102       let
   103         val _ = RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler n;
   104         val res = Exn.capture f x;
   105         val _ = RunCall.run_call1 RuntimeCalls.POLY_SYS_profiler 0;
   106       in Exn.release res end;
   107 
   108 val pointer_eq = PolyML.pointerEq;
   109 
   110 
   111 (* ML compiler *)
   112 
   113 use "ML-Systems/use_context.ML";
   114 use "ML-Systems/ml_positions.ML";
   115 use "ML-Systems/compiler_polyml.ML";
   116 
   117 PolyML.Compiler.reportUnreferencedIds := true;
   118 PolyML.Compiler.printInAlphabeticalOrder := false;
   119 PolyML.Compiler.maxInlineSize := 80;
   120 
   121 fun ml_prompts p1 p2 = (PolyML.Compiler.prompt1 := p1; PolyML.Compiler.prompt2 := p2);
   122 
   123 
   124 (* ML toplevel pretty printing *)
   125 
   126 use "ML-Systems/ml_pretty.ML";
   127 
   128 local
   129   val depth = Unsynchronized.ref 10;
   130 in
   131   fun get_default_print_depth () = ! depth;
   132   fun default_print_depth n = (depth := n; PolyML.print_depth n);
   133   val _ = default_print_depth 10;
   134 end;
   135 
   136 val error_depth = PolyML.error_depth;
   137 
   138 val pretty_ml =
   139   let
   140     fun convert _ (PolyML.PrettyBreak (wd, _)) = ML_Pretty.Break (false, wd)
   141       | convert _ (PolyML.PrettyBlock (_, _,
   142             [PolyML.ContextProperty ("fbrk", _)], [PolyML.PrettyString " "])) =
   143           ML_Pretty.Break (true, 1)
   144       | convert len (PolyML.PrettyBlock (ind, _, context, prts)) =
   145           let
   146             fun property name default =
   147               (case List.find (fn PolyML.ContextProperty (a, _) => name = a | _ => false) context of
   148                 SOME (PolyML.ContextProperty (_, b)) => b
   149               | _ => default);
   150             val bg = property "begin" "";
   151             val en = property "end" "";
   152             val len' = property "length" len;
   153           in ML_Pretty.Block ((bg, en), map (convert len') prts, ind) end
   154       | convert len (PolyML.PrettyString s) =
   155           ML_Pretty.String (s, case Int.fromString len of SOME i => i | NONE => size s)
   156   in convert "" end;
   157 
   158 fun ml_pretty (ML_Pretty.Break (false, wd)) = PolyML.PrettyBreak (wd, 0)
   159   | ml_pretty (ML_Pretty.Break (true, _)) =
   160       PolyML.PrettyBlock (0, false, [PolyML.ContextProperty ("fbrk", "")],
   161         [PolyML.PrettyString " "])
   162   | ml_pretty (ML_Pretty.Block ((bg, en), prts, ind)) =
   163       let val context =
   164         (if bg = "" then [] else [PolyML.ContextProperty ("begin", bg)]) @
   165         (if en = "" then [] else [PolyML.ContextProperty ("end", en)])
   166       in PolyML.PrettyBlock (ind, false, context, map ml_pretty prts) end
   167   | ml_pretty (ML_Pretty.String (s, len)) =
   168       if len = size s then PolyML.PrettyString s
   169       else PolyML.PrettyBlock
   170         (0, false, [PolyML.ContextProperty ("length", Int.toString len)], [PolyML.PrettyString s]);
   171 
   172 fun toplevel_pp context (_: string list) pp =
   173   use_text context (1, "pp") false
   174     ("PolyML.addPrettyPrinter (fn _ => fn _ => ml_pretty o Pretty.to_ML o (" ^ pp ^ "))");
   175 
   176 val ml_make_string =
   177   "(fn x => Pretty.string_of (Pretty.from_ML (pretty_ml (PolyML.prettyRepresentation (x, Isabelle.ML_print_depth ())))))";
   178