merge with trunk at rev 14512ephemeron

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/ephemeron@14514 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

10 files changed, 65 insertions, 64 deletions

diff --git a/debugger/.depend b/debugger/.depend
index 60b0baeff6..13de8ede13 100644
--- a/debugger/.depend
+++ b/debugger/.depend
@@ -172,11 +172,13 @@ program_management.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \
 question.cmo : primitives.cmi lexer.cmi input_handling.cmi question.cmi
 question.cmx : primitives.cmx lexer.cmx input_handling.cmx question.cmi
 show_information.cmo : symbols.cmi source.cmi show_source.cmi printval.cmi \
-    ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi events.cmi \
-    debugcom.cmi checkpoints.cmi breakpoints.cmi show_information.cmi
+    parameters.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi \
+    events.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \
+    show_information.cmi
 show_information.cmx : symbols.cmx source.cmx show_source.cmx printval.cmx \
-    ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx events.cmx \
-    debugcom.cmx checkpoints.cmx breakpoints.cmx show_information.cmi
+    parameters.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx \
+    events.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \
+    show_information.cmi
 show_source.cmo : source.cmi primitives.cmi parameters.cmi \
     ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \
     debugger_config.cmi show_source.cmi
diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared
index 815ab3258b..d85419eb0c 100644
--- a/debugger/Makefile.shared
+++ b/debugger/Makefile.shared
@@ -12,9 +12,9 @@
 
 include ../config/Makefile
 
-CAMLC=$(CAMLC_BIN) -nostdlib -I ../stdlib
-COMPFLAGS=-g -warn-error A $(INCLUDES)
-LINKFLAGS=-g -linkall -I $(UNIXDIR)
+CAMLC=../ocamlcomp.sh
+COMPFLAGS=-warn-error A $(INCLUDES)
+LINKFLAGS=-linkall -I $(UNIXDIR)
 CAMLYACC=../boot/ocamlyacc
 YACCFLAGS=
 CAMLLEX=../boot/ocamlrun ../boot/ocamllex
diff --git a/debugger/command_line.ml b/debugger/command_line.ml
index d108621545..a4647110d6 100644
--- a/debugger/command_line.ml
+++ b/debugger/command_line.ml
@@ -234,16 +234,22 @@ let instr_env ppf lexbuf =
   let cmdarg = argument_list_eol argument lexbuf in
   let cmdarg = string_trim (String.concat " " cmdarg) in
   if cmdarg <> "" then
-    try
-      if (String.index cmdarg '=') > 0 then
-        Debugger_config.environment := cmdarg :: !Debugger_config.environment
-      else
-        eprintf "Environment variables should not have an empty name\n%!"
-    with Not_found ->
-      eprintf "Environment variables should have the \"name=value\" format\n%!"
+    if ask_kill_program () then begin
+      try
+        let eqpos = String.index cmdarg '=' in
+        if eqpos = 0 then raise Not_found;
+        let name = String.sub cmdarg 0 eqpos in
+        let value =
+          String.sub cmdarg (eqpos + 1) (String.length cmdarg - eqpos - 1)
+        in
+        Debugger_config.environment :=
+          (name, value) :: List.remove_assoc name !Debugger_config.environment
+      with Not_found ->
+        eprintf "Environment variable must be in name=value format\n%!"
+    end
   else
     List.iter
-      (printf "%s\n%!")
+      (fun (vvar, vval) -> printf "%s=%s\n%!" vvar vval)
       (List.rev !Debugger_config.environment)
 
 let instr_pwd ppf lexbuf =
diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli
index f725acecf8..ab935d9324 100644
--- a/debugger/debugger_config.mli
+++ b/debugger/debugger_config.mli
@@ -34,4 +34,4 @@ val make_checkpoints : bool ref
 
 (*** Environment variables for debugee. ***)
 
-val environment : string list ref
+val environment : (string * string) list ref
diff --git a/debugger/main.ml b/debugger/main.ml
index 85bc9afb6b..52c1ed9952 100644
--- a/debugger/main.ml
+++ b/debugger/main.ml
@@ -26,10 +26,7 @@ open Primitives
 
 let line_buffer = Lexing.from_function read_user_input
 
-let rec loop ppf =
-  line_loop ppf line_buffer;
-  if !loaded && (not (yes_or_no "The program is running. Quit anyway")) then
-    loop ppf
+let rec loop ppf = line_loop ppf line_buffer
 
 let current_duration = ref (-1L)
 
@@ -170,10 +167,12 @@ let speclist = [
       "<count>  Set max number of checkpoints kept";
    "-cd", Arg.String set_directory,
       "<dir>  Change working directory";
-   "-emacs", Arg.Set emacs,
-      "For running the debugger under emacs";
+   "-emacs", Arg.Tuple [Arg.Set emacs; Arg.Set machine_readable],
+      "For running the debugger under emacs; implies -machine-readable";
    "-I", Arg.String add_include,
       "<dir>  Add <dir> to the list of include directories";
+   "-machine-readable", Arg.Set machine_readable,
+      "Print information in a format more suitable for machines";
    "-s", Arg.String set_socket,
       "<filename>  Set the name of the communication socket";
    "-version", Arg.Unit print_version,
diff --git a/debugger/parameters.ml b/debugger/parameters.ml
index 2e1d4a7530..d8c85efe00 100644
--- a/debugger/parameters.ml
+++ b/debugger/parameters.ml
@@ -35,3 +35,5 @@ let add_path_for mdl dir =
 
 (* Used by emacs ? *)
 let emacs = ref false
+
+let machine_readable = ref false
diff --git a/debugger/parameters.mli b/debugger/parameters.mli
index 244d24b35f..44c850d5c7 100644
--- a/debugger/parameters.mli
+++ b/debugger/parameters.mli
@@ -23,3 +23,5 @@ val add_path_for : string -> string -> unit
 
 (* Used by emacs ? *)
 val emacs : bool ref
+
+val machine_readable : bool ref
diff --git a/debugger/printval.ml b/debugger/printval.ml
index 0fa2eced2d..5170ef3b24 100644
--- a/debugger/printval.ml
+++ b/debugger/printval.ml
@@ -47,7 +47,7 @@ module EvalPath =
   struct
     type valu = Debugcom.Remote_value.t
     exception Error
-    let rec eval_path = function
+    let rec eval_path env = function
       Pident id ->
         begin try
           Debugcom.Remote_value.global (Symtable.get_global_position id)
@@ -55,7 +55,7 @@ module EvalPath =
           raise Error
         end
     | Pdot(root, fieldname, pos) ->
-        let v = eval_path root in
+        let v = eval_path env root in
         if not (Debugcom.Remote_value.is_block v)
         then raise Error
         else Debugcom.Remote_value.field v pos
diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml
index 99bfe6b478..b2d472a7dc 100644
--- a/debugger/program_loading.ml
+++ b/debugger/program_loading.ml
@@ -33,38 +33,19 @@ let load_program () =
 
 (*** Launching functions. ***)
 
-(* Returns the environment to be passed to debugee *)
-let get_environment () =
-  let env = Unix.environment () in
-  let have_same_name x y =
-    let split = Primitives.split_string '=' in
-    match split x, split y with
-      (hd1 :: _), (hd2 :: _) -> hd1 = hd2
-    | _ -> false in
-  let have_name_in_config_env x =
-    List.exists
-      (have_same_name x)
-      !Debugger_config.environment in
-  let env =
-    Array.fold_right
-      (fun elem acc ->
-        if have_name_in_config_env elem then
-          acc
-        else
-          elem :: acc)
-      env
-      [] in
-  Array.of_list (env @ !Debugger_config.environment)
-
-(* Returns the environment to be passed to debugee *)
+(* Returns a command line prefix to set environment for the debuggee *)
+let get_unix_environment () =
+  let f (vname, vvalue) =
+    Printf.sprintf "%s=%s " vname (Filename.quote vvalue)
+  in
+  String.concat "" (List.map f !Debugger_config.environment)
+;;
+
+(* Returns a command line prefix to set environment for the debuggee *)
 let get_win32_environment () =
-  let res = Buffer.create 256 in
-  let env = get_environment () in
-  let len = Array.length env in
-  for i = 0 to pred len do
-    Buffer.add_string res (Printf.sprintf "set %s && " env.(i))
-  done;
-  Buffer.contents res
+  (* Note: no space before the & or Windows will add it to the value *)
+  let f (vname, vvalue) = Printf.sprintf "set %s=%s&" vname vvalue in
+  String.concat "" (List.map f !Debugger_config.environment)
 
 (* A generic function for launching the program *)
 let generic_exec_unix cmdline = function () ->
@@ -83,7 +64,7 @@ let generic_exec_unix cmdline = function () ->
            0 -> (* Try to detach the process from the controlling terminal,
                    so that it does not receive SIGINT on ctrl-C. *)
                 begin try ignore(setsid()) with Invalid_argument _ -> () end;
-                execve shell [| shell; "-c"; cmdline() |] (get_environment ())
+                execv shell [| shell; "-c"; cmdline() |]
          | _ -> exit 0
        with x ->
          Unix_tools.report_error x;
@@ -113,18 +94,19 @@ let exec_with_runtime =
     (function () ->
       match Sys.os_type with
         "Win32" ->
-          (* This fould fail on a file name with spaces
+          (* This would fail on a file name with spaces
              but quoting is even worse because Unix.create_process
              thinks each command line parameter is a file.
              So no good solution so far *)
-          Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s %s"
+          Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s& %s %s %s"
                      (get_win32_environment ())
                      !socket_name
                      runtime_program
                      !program_name
                      !arguments
       | _ ->
-          Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s %s"
+          Printf.sprintf "%sCAML_DEBUG_SOCKET=%s %s %s %s"
+                     (get_unix_environment ())
                      !socket_name
                      (Filename.quote runtime_program)
                      (Filename.quote !program_name)
@@ -137,13 +119,14 @@ let exec_direct =
       match Sys.os_type with
         "Win32" ->
           (* See the comment above *)
-          Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s"
+          Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s& %s %s"
                      (get_win32_environment ())
                      !socket_name
                      !program_name
                      !arguments
       | _ ->
-          Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s"
+          Printf.sprintf "%sCAML_DEBUG_SOCKET=%s %s %s"
+                     (get_unix_environment ())
                      !socket_name
                      (Filename.quote !program_name)
                      !arguments)
diff --git a/debugger/show_information.ml b/debugger/show_information.ml
index 89111d3cc9..690645dfe2 100644
--- a/debugger/show_information.ml
+++ b/debugger/show_information.ml
@@ -21,6 +21,7 @@ open Frames
 open Source
 open Show_source
 open Breakpoints
+open Parameters
 
 (* Display information about the current event. *)
 let show_current_event ppf =
@@ -73,9 +74,15 @@ let show_one_frame framenum ppf event =
       let buffer = get_buffer pos event.ev_module in
       snd (start_and_cnum buffer pos)
     with _ -> pos.Lexing.pos_cnum in
-  fprintf ppf "#%i  Pc: %i  %s char %i@."
-         framenum event.ev_pos event.ev_module
-         cnum
+  if !machine_readable then
+    fprintf ppf "#%i  Pc: %i  %s char %i@."
+           framenum event.ev_pos event.ev_module
+           cnum
+  else
+    fprintf ppf "#%i %s %s:%i:%i@."
+           framenum event.ev_module
+           pos.Lexing.pos_fname pos.Lexing.pos_lnum
+           (pos.Lexing.pos_cnum - pos.Lexing.pos_bol + 1)
 
 (* Display information about the current frame. *)
 (* --- `select frame' must have succeded before calling this function. *)