l4/pkg/ocaml/contrib/debugger/command_line.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
   6 (*          Objective Caml port by John Malecki and Xavier Leroy       *)
   7 (*                                                                     *)
   8 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   9 (*  en Automatique.  All rights reserved.  This file is distributed    *)
  10 (*  under the terms of the Q Public License version 1.0.               *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: command_line.ml 9299 2009-06-17 08:15:39Z xclerc $ *)
  15
  16 (************************ Reading and executing commands ***************)
  17
  18 open Int64ops
  19 open Format
  20 open Misc
  21 open Instruct
  22 open Unix
  23 open Debugger_config
  24 open Types
  25 open Primitives
  26 open Unix_tools
  27 open Parser
  28 open Parser_aux
  29 open Lexer
  30 open Input_handling
  31 open Question
  32 open Debugcom
  33 open Program_loading
  34 open Program_management
  35 open Lexing
  36 open Parameters
  37 open Show_source
  38 open Show_information
  39 open Time_travel
  40 open Events
  41 open Symbols
  42 open Source
  43 open Breakpoints
  44 open Checkpoints
  45 open Frames
  46 open Printval
  47
  48 (** Instructions, variables and infos lists. **)
  49 type dbg_instruction =
  50   { instr_name: string;                 (* Name of command *)
  51     instr_prio: bool;                   (* Has priority *)
  52     instr_action: formatter -> lexbuf -> unit;
  53                                         (* What to do *)
  54     instr_repeat: bool;                 (* Can be repeated *)
  55     instr_help: string }                (* Help message *)
  56
  57 let instruction_list = ref ([] : dbg_instruction list)
  58
  59 type dbg_variable =
  60   { var_name: string;                   (* Name of variable *)
  61     var_action: (lexbuf -> unit) * (formatter -> unit);
  62                                         (* Reading, writing fns *)
  63     var_help: string }                  (* Help message *)
  64
  65 let variable_list = ref ([] : dbg_variable list)
  66
  67 type dbg_info =
  68   { info_name: string;                  (* Name of info *)
  69     info_action: lexbuf -> unit;        (* What to do *)
  70     info_help: string }                 (* Help message *)
  71
  72 let info_list = ref ([] : dbg_info list)
  73
  74 (** Utilities. **)
  75 let error text =
  76   eprintf "%s@." text;
  77   raise Toplevel
  78
  79 let check_not_windows feature =
  80   match Sys.os_type with
  81   | "Win32" ->
  82       error ("'"^feature^"' feature not supported on Windows")
  83   | _ ->
  84       ()
  85
  86 let eol =
  87   end_of_line Lexer.lexeme
  88
  89 let matching_elements list name instr =
  90   List.filter (function a -> isprefix instr (name a)) !list
  91
  92 let all_matching_instructions =
  93   matching_elements instruction_list (fun i -> i.instr_name)
  94
  95 (* itz 04-21-96 don't do priority completion in emacs mode *)
  96 (* XL 25-02-97 why? I find it very confusing. *)
  97
  98 let matching_instructions instr =
  99   let all = all_matching_instructions instr in
 100   let prio = List.filter (fun i -> i.instr_prio) all in
 101   if prio = [] then all else prio
 102
 103 let matching_variables =
 104   matching_elements variable_list (fun v -> v.var_name)
 105
 106 let matching_infos =
 107   matching_elements info_list (fun i -> i.info_name)
 108
 109 let find_ident name matcher action alternative ppf lexbuf =
 110   match identifier_or_eol Lexer.lexeme lexbuf with
 111   | None -> alternative ppf
 112   | Some ident ->
 113       match matcher ident with
 114       | [] -> error ("Unknown " ^ name ^ ".")
 115       | [a] -> action a ppf lexbuf
 116       | _ -> error ("Ambiguous " ^ name ^ ".")
 117
 118 let find_variable action alternative ppf lexbuf =
 119   find_ident "variable name" matching_variables action alternative ppf lexbuf
 120
 121 let find_info action alternative ppf lexbuf =
 122   find_ident "info command" matching_infos action alternative ppf lexbuf
 123
 124 let add_breakpoint_at_pc pc =
 125   try
 126     new_breakpoint (any_event_at_pc pc)
 127   with
 128   | Not_found ->
 129     eprintf "Can't add breakpoint at pc %i : no event there.@." pc;
 130     raise Toplevel
 131
 132 let add_breakpoint_after_pc pc =
 133   let rec try_add n =
 134     if n < 3 then begin
 135       try
 136         new_breakpoint (any_event_at_pc (pc + n * 4))
 137       with
 138       | Not_found ->
 139         try_add (n+1)
 140     end else begin
 141       error
 142         "Can't add breakpoint at beginning of function: no event there"
 143     end
 144   in try_add 0
 145
 146 let module_of_longident id =
 147   match id with
 148   | Some x -> Some (String.concat "." (Longident.flatten x))
 149   | None -> None
 150
 151 let convert_module mdle =
 152   match mdle with
 153   | Some m ->
 154       (* Strip .ml extension if any, and capitalize *)
 155       String.capitalize(if Filename.check_suffix m ".ml"
 156                         then Filename.chop_suffix m ".ml"
 157                         else m)
 158   | None ->
 159       try
 160         (get_current_event ()).ev_module
 161       with
 162       | Not_found ->
 163           error "Not in a module."
 164
 165 (** Toplevel. **)
 166 let current_line = ref ""
 167
 168 let interprete_line ppf line =
 169   current_line := line;
 170   let lexbuf = Lexing.from_string line in
 171     try
 172       match identifier_or_eol Lexer.lexeme lexbuf with
 173       | Some x ->
 174           begin match matching_instructions x with
 175           | [] ->
 176               error "Unknown command."
 177           | [i] ->
 178               i.instr_action ppf lexbuf;
 179               resume_user_input ();
 180               i.instr_repeat
 181           | l ->
 182               error "Ambiguous command."
 183           end
 184       | None ->
 185           resume_user_input ();
 186           false
 187     with
 188     | Parsing.Parse_error ->
 189         error "Syntax error."
 190
 191 let line_loop ppf line_buffer =
 192   resume_user_input ();
 193   let previous_line = ref "" in
 194     try
 195       while true do
 196         if !loaded then
 197           History.add_current_time ();
 198         let new_line = string_trim (line line_buffer) in
 199           let line =
 200             if new_line <> "" then
 201               new_line
 202             else
 203               !previous_line
 204           in
 205             previous_line := "";
 206             if interprete_line ppf line then
 207               previous_line := line
 208       done
 209     with
 210     | Exit ->
 211         stop_user_input ()
 212     | Sys_error s ->
 213         error ("System error : " ^ s)
 214
 215 (** Instructions. **)
 216 let instr_cd ppf lexbuf =
 217   let dir = argument_eol argument lexbuf in
 218     if ask_kill_program () then
 219       try
 220         Sys.chdir (expand_path dir)
 221       with
 222       | Sys_error s ->
 223           error s
 224
 225 let instr_shell ppf lexbuf =
 226   let cmdarg = argument_list_eol argument lexbuf in
 227   let cmd = String.concat " " cmdarg in
 228   (* perhaps we should use $SHELL -c ? *)
 229   let err = Sys.command cmd in
 230   if (err != 0) then
 231     eprintf "Shell command %S failed with exit code %d\n%!" cmd err
 232
 233 let instr_pwd ppf lexbuf =
 234   eol lexbuf;
 235   fprintf ppf "%s@." (Sys.getcwd ())
 236
 237 let instr_dir ppf lexbuf =
 238   let new_directory = argument_list_eol argument lexbuf in
 239     if new_directory = [] then begin
 240       if yes_or_no "Reinitialize directory list" then begin
 241         Config.load_path := !default_load_path;
 242         Envaux.reset_cache ();
 243         Hashtbl.clear Debugger_config.load_path_for;
 244         flush_buffer_list ()
 245         end
 246       end
 247     else begin
 248       let new_directory' = List.rev new_directory in
 249       match new_directory' with
 250       | mdl :: for_keyw :: tl when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 ->
 251           List.iter (function x -> add_path_for mdl (expand_path x)) tl
 252       | _ ->
 253           List.iter (function x -> add_path (expand_path x)) new_directory'
 254     end;
 255     let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in
 256     fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path;
 257     Hashtbl.iter
 258       (fun mdl dirs ->
 259         fprintf ppf "@[<2>Source directories for %s :%a@]@." mdl print_dirs dirs)
 260       Debugger_config.load_path_for
 261
 262 let instr_kill ppf lexbuf =
 263   eol lexbuf;
 264   if not !loaded then error "The program is not being run.";
 265   if (yes_or_no "Kill the program being debugged") then begin
 266     kill_program ();
 267     show_no_point()
 268   end
 269
 270 let instr_run ppf lexbuf =
 271   eol lexbuf;
 272   ensure_loaded ();
 273   reset_named_values ();
 274   run ();
 275   show_current_event ppf;;
 276
 277 let instr_reverse ppf lexbuf =
 278   eol lexbuf;
 279   check_not_windows "reverse";
 280   ensure_loaded ();
 281   reset_named_values();
 282   back_run ();
 283   show_current_event ppf
 284
 285 let instr_step ppf lexbuf =
 286   let step_count =
 287     match opt_signed_int64_eol Lexer.lexeme lexbuf with
 288     | None -> _1
 289     | Some x -> x
 290   in
 291     ensure_loaded ();
 292     reset_named_values();
 293     step step_count;
 294     show_current_event ppf
 295
 296 let instr_back ppf lexbuf =
 297   let step_count =
 298     match opt_signed_int64_eol Lexer.lexeme lexbuf with
 299     | None -> _1
 300     | Some x -> x
 301   in
 302     check_not_windows "backstep";
 303     ensure_loaded ();
 304     reset_named_values();
 305     step (_0 -- step_count);
 306     show_current_event ppf
 307
 308 let instr_finish ppf lexbuf =
 309   eol lexbuf;
 310   ensure_loaded ();
 311   reset_named_values();
 312   finish ();
 313   show_current_event ppf
 314
 315 let instr_next ppf lexbuf =
 316   let step_count =
 317     match opt_integer_eol Lexer.lexeme lexbuf with
 318     | None -> 1
 319     | Some x -> x
 320   in
 321     ensure_loaded ();
 322     reset_named_values();
 323     next step_count;
 324     show_current_event ppf
 325
 326 let instr_start ppf lexbuf =
 327   eol lexbuf;
 328   check_not_windows "start";
 329   ensure_loaded ();
 330   reset_named_values();
 331   start ();
 332   show_current_event ppf
 333
 334 let instr_previous ppf lexbuf =
 335   let step_count =
 336     match opt_integer_eol Lexer.lexeme lexbuf with
 337     | None -> 1
 338     | Some x -> x
 339   in
 340     check_not_windows "previous";
 341     ensure_loaded ();
 342     reset_named_values();
 343     previous step_count;
 344     show_current_event ppf
 345
 346 let instr_goto ppf lexbuf =
 347   let time = int64_eol Lexer.lexeme lexbuf in
 348     ensure_loaded ();
 349     reset_named_values();
 350     go_to time;
 351     show_current_event ppf
 352
 353 let instr_quit _ =
 354   raise Exit
 355
 356 let print_variable_list ppf =
 357   let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in
 358   fprintf ppf "List of variables :%a@." pr_vars !variable_list
 359
 360 let print_info_list ppf =
 361   let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name)  in
 362   fprintf ppf "List of info commands :%a@." pr_infos !info_list
 363
 364 let instr_complete ppf lexbuf =
 365   let ppf = Format.err_formatter in
 366   let rec print_list l =
 367     try
 368       eol lexbuf;
 369       List.iter (function i -> fprintf ppf "%s@." i) l
 370     with _ ->
 371       remove_file !user_channel
 372   and match_list lexbuf =
 373     match identifier_or_eol Lexer.lexeme lexbuf with
 374     | None ->
 375         List.map (fun i -> i.instr_name) !instruction_list
 376     | Some x ->
 377         match matching_instructions x with
 378         | [ {instr_name = ("set" | "show" as i_full)} ] ->
 379             if x = i_full then begin
 380               match identifier_or_eol Lexer.lexeme lexbuf with
 381               | Some ident ->
 382                   begin match matching_variables ident with
 383                   | [v] -> if v.var_name = ident then [] else [v.var_name]
 384                   | l   -> List.map (fun v -> v.var_name) l
 385                   end
 386               | None ->
 387                   List.map (fun v -> v.var_name) !variable_list
 388             end
 389             else [i_full]
 390         | [ {instr_name = "info"} ] ->
 391             if x = "info" then begin
 392               match identifier_or_eol Lexer.lexeme lexbuf with
 393               | Some ident ->
 394                   begin match matching_infos ident with
 395                   | [i] -> if i.info_name = ident then [] else [i.info_name]
 396                   | l   -> List.map (fun i -> i.info_name) l
 397                   end
 398               | None ->
 399                   List.map (fun i -> i.info_name) !info_list
 400             end
 401             else ["info"]
 402         | [ {instr_name = "help"} ] ->
 403             if x = "help" then match_list lexbuf else ["help"]
 404         | [ i ] ->
 405             if x = i.instr_name then [] else [i.instr_name]
 406         | l ->
 407             List.map (fun i -> i.instr_name) l
 408   in
 409     print_list(match_list lexbuf)
 410
 411 let instr_help ppf lexbuf =
 412   let pr_instrs ppf =
 413       List.iter (fun i -> fprintf ppf "%s@ " i.instr_name) in
 414   match identifier_or_eol Lexer.lexeme lexbuf with
 415   | Some x ->
 416       let print_help nm hlp =
 417         eol lexbuf;
 418         fprintf ppf "%s : %s@." nm hlp in
 419       begin match matching_instructions x with
 420       | [] ->
 421           eol lexbuf;
 422           fprintf ppf "No matching command.@."
 423       | [ {instr_name = "set"} ] ->
 424           find_variable
 425             (fun v _ _ ->
 426                print_help ("set " ^ v.var_name) ("set " ^ v.var_help))
 427             (fun ppf ->
 428                print_help "set" "set debugger variable.";
 429                print_variable_list ppf)
 430             ppf
 431             lexbuf
 432       | [ {instr_name = "show"} ] ->
 433           find_variable
 434             (fun v _ _ ->
 435                print_help ("show " ^ v.var_name) ("show " ^ v.var_help))
 436             (fun v ->
 437                print_help "show" "display debugger variable.";
 438                print_variable_list ppf)
 439             ppf
 440             lexbuf
 441       | [ {instr_name = "info"} ] ->
 442           find_info
 443             (fun i _ _ -> print_help ("info " ^ i.info_name) i.info_help)
 444             (fun ppf ->
 445                print_help "info"
 446                  "display infos about the program being debugged.";
 447                print_info_list ppf)
 448             ppf
 449             lexbuf
 450       | [i] ->
 451           print_help i.instr_name i.instr_help
 452       | l ->
 453           eol lexbuf;
 454           fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l
 455       end
 456   | None ->
 457       fprintf ppf "List of commands :%a@." pr_instrs !instruction_list
 458
 459 (* Printing values *)
 460
 461 let print_expr depth ev env ppf expr =
 462   try
 463     let (v, ty) = Eval.expression ev env expr in
 464     print_named_value depth expr env v ppf ty
 465   with
 466   | Eval.Error msg ->
 467     Eval.report_error ppf msg;
 468     raise Toplevel
 469
 470 let print_command depth ppf lexbuf =
 471   let exprs = expression_list_eol Lexer.lexeme lexbuf in
 472   ensure_loaded ();
 473   let env =
 474     try
 475       Envaux.env_of_event !selected_event
 476     with
 477     | Envaux.Error msg ->
 478         Envaux.report_error ppf msg;
 479         raise Toplevel
 480   in
 481   List.iter (print_expr depth !selected_event env ppf) exprs
 482
 483 let instr_print ppf lexbuf = print_command !max_printer_depth ppf lexbuf
 484
 485 let instr_display ppf lexbuf = print_command 1 ppf lexbuf
 486
 487 (* Loading of command files *)
 488
 489 let extract_filename arg =
 490   (* Allow enclosing filename in quotes *)
 491   let l = String.length arg in
 492   let pos1 = if l > 0 && arg.[0] = '"' then 1 else 0 in
 493   let pos2 = if l > 0 && arg.[l-1] = '"' then l-1 else l in
 494   String.sub arg pos1 (pos2 - pos1)
 495
 496 let instr_source ppf lexbuf =
 497   let file = extract_filename(argument_eol argument lexbuf)
 498   and old_state = !interactif
 499   and old_channel = !user_channel in
 500     let io_chan =
 501       try
 502         io_channel_of_descr
 503           (openfile (find_in_path !Config.load_path (expand_path file))
 504              [O_RDONLY] 0)
 505       with
 506       | Not_found -> error "Source file not found."
 507       | (Unix_error _) as x  -> Unix_tools.report_error x; raise Toplevel
 508     in
 509       try
 510         interactif := false;
 511         user_channel := io_chan;
 512         line_loop ppf (Lexing.from_function read_user_input);
 513         close_io io_chan;
 514         interactif := old_state;
 515         user_channel := old_channel
 516       with
 517       | x ->
 518           stop_user_input ();
 519           close_io io_chan;
 520           interactif := old_state;
 521           user_channel := old_channel;
 522           raise x
 523
 524 let instr_set =
 525   find_variable
 526     (fun {var_action = (funct, _)} ppf lexbuf -> funct lexbuf)
 527     (function ppf -> error "Argument required.")
 528
 529 let instr_show =
 530   find_variable
 531     (fun {var_action = (_, funct)} ppf lexbuf -> eol lexbuf; funct ppf)
 532     (function ppf ->
 533        List.iter
 534          (function {var_name = nm; var_action = (_, funct)} ->
 535               fprintf ppf "%s : " nm;
 536               funct ppf)
 537          !variable_list)
 538
 539 let instr_info =
 540   find_info
 541     (fun i ppf lexbuf -> i.info_action lexbuf)
 542     (function ppf ->
 543        error "\"info\" must be followed by the name of an info command.")
 544
 545 let instr_break ppf lexbuf =
 546   let argument = break_argument_eol Lexer.lexeme lexbuf in
 547     ensure_loaded ();
 548     match argument with
 549     |  BA_none ->                                (* break *)
 550         (match !selected_event with
 551          | Some ev ->
 552              new_breakpoint ev
 553          | None ->
 554              error "Can't add breakpoint at this point.")
 555     | BA_pc pc ->                               (* break PC *)
 556         add_breakpoint_at_pc pc
 557     | BA_function expr ->                       (* break FUNCTION *)
 558         let env =
 559           try
 560             Envaux.env_of_event !selected_event
 561           with
 562           | Envaux.Error msg ->
 563               Envaux.report_error ppf msg;
 564               raise Toplevel
 565         in
 566         begin try
 567           let (v, ty) = Eval.expression !selected_event env expr in
 568           match (Ctype.repr ty).desc with
 569           | Tarrow _ ->
 570               add_breakpoint_after_pc (Remote_value.closure_code v)
 571           | _ ->
 572               eprintf "Not a function.@.";
 573               raise Toplevel
 574         with
 575         | Eval.Error msg ->
 576             Eval.report_error ppf msg;
 577             raise Toplevel
 578         end
 579     | BA_pos1 (mdle, line, column) ->         (* break @ [MODULE] LINE [COL] *)
 580         let module_name = convert_module (module_of_longident mdle) in
 581         new_breakpoint
 582           (try
 583              let buffer =
 584                try get_buffer Lexing.dummy_pos module_name with
 585                | Not_found ->
 586                   eprintf "No source file for %s.@." module_name;
 587                   raise Toplevel
 588              in
 589              match column with
 590              | None ->
 591                  event_at_pos module_name (fst (pos_of_line buffer line))
 592              | Some col ->
 593                  event_near_pos module_name (point_of_coord buffer line col)
 594            with
 595            | Not_found -> (* event_at_pos / event_near pos *)
 596                eprintf "Can't find any event there.@.";
 597                raise Toplevel
 598            | Out_of_range -> (* pos_of_line / point_of_coord *)
 599                eprintf "Position out of range.@.";
 600                raise Toplevel)
 601     | BA_pos2 (mdle, position) ->             (* break @ [MODULE] # POSITION *)
 602         try
 603           new_breakpoint (event_near_pos (convert_module (module_of_longident mdle)) position)
 604         with
 605         | Not_found ->
 606             eprintf "Can't find any event there.@."
 607
 608 let instr_delete ppf lexbuf =
 609   match integer_list_eol Lexer.lexeme lexbuf with
 610   | [] ->
 611       if breakpoints_count () <> 0 && yes_or_no "Delete all breakpoints"
 612       then remove_all_breakpoints ()
 613   | breakpoints ->
 614       List.iter
 615         (function x -> try remove_breakpoint x with | Not_found -> ())
 616         breakpoints
 617
 618 let instr_frame ppf lexbuf =
 619   let frame_number =
 620     match opt_integer_eol Lexer.lexeme lexbuf with
 621     | None -> !current_frame
 622     | Some x -> x
 623   in
 624     ensure_loaded ();
 625     try
 626       select_frame frame_number;
 627       show_current_frame ppf true
 628     with
 629     | Not_found ->
 630         error ("No frame number " ^ string_of_int frame_number ^ ".")
 631
 632 let instr_backtrace ppf lexbuf =
 633   let number =
 634     match opt_signed_integer_eol Lexer.lexeme lexbuf with
 635     | None -> 0
 636     | Some x -> x in
 637   ensure_loaded ();
 638   match current_report() with
 639   | None | Some {rep_type = Exited | Uncaught_exc} -> ()
 640   | Some _ ->
 641       let frame_counter = ref 0 in
 642       let print_frame first_frame last_frame = function
 643       | None ->
 644           fprintf ppf
 645            "(Encountered a function with no debugging information)@.";
 646           false
 647       | Some event ->
 648           if !frame_counter >= first_frame then
 649             show_one_frame !frame_counter ppf event;
 650           incr frame_counter;
 651           if !frame_counter >= last_frame then begin
 652             fprintf ppf "(More frames follow)@."
 653           end;
 654           !frame_counter < last_frame in
 655       fprintf ppf "Backtrace:@.";
 656       if number = 0 then
 657         do_backtrace (print_frame 0 max_int)
 658       else if number > 0 then
 659         do_backtrace (print_frame 0 number)
 660       else begin
 661         let num_frames = stack_depth() in
 662         if num_frames < 0 then
 663           fprintf ppf
 664             "(Encountered a function with no debugging information)@."
 665         else
 666           do_backtrace (print_frame (num_frames + number) max_int)
 667       end
 668
 669 let instr_up ppf lexbuf =
 670   let offset =
 671     match opt_signed_integer_eol Lexer.lexeme lexbuf with
 672     | None -> 1
 673     | Some x -> x
 674   in
 675     ensure_loaded ();
 676     try
 677       select_frame (!current_frame + offset);
 678       show_current_frame ppf true
 679     with
 680     | Not_found -> error "No such frame."
 681
 682 let instr_down ppf lexbuf =
 683   let offset =
 684     match opt_signed_integer_eol Lexer.lexeme lexbuf with
 685     | None -> 1
 686     | Some x -> x
 687   in
 688     ensure_loaded ();
 689     try
 690       select_frame (!current_frame - offset);
 691       show_current_frame ppf true
 692     with
 693     | Not_found -> error "No such frame."
 694
 695 let instr_last ppf lexbuf =
 696   let count =
 697     match opt_signed_int64_eol Lexer.lexeme lexbuf with
 698     | None -> _1
 699     | Some x -> x
 700   in
 701     check_not_windows "last";
 702     reset_named_values();
 703     go_to (History.previous_time count);
 704     show_current_event ppf
 705
 706 let instr_list ppf lexbuf =
 707   let (mo, beg, e) = list_arguments_eol Lexer.lexeme lexbuf in
 708     let (curr_mod, line, column) =
 709       try
 710         selected_point ()
 711       with
 712       | Not_found ->
 713           ("", -1, -1)
 714     in
 715       let mdle = convert_module (module_of_longident mo) in
 716       let pos = Lexing.dummy_pos in
 717       let buffer =
 718         try get_buffer pos mdle with
 719         | Not_found -> error ("No source file for " ^ mdle ^ ".") in
 720       let point =
 721         if column <> -1 then
 722           (point_of_coord buffer line 1) + column
 723         else
 724           -1 in
 725         let beginning =
 726           match beg with
 727           | None when (mo <> None) || (line = -1) ->
 728               1
 729           | None ->
 730               begin try
 731                 max 1 (line - 10)
 732               with Out_of_range ->
 733                 1
 734               end
 735           | Some x -> x
 736         in
 737           let en =
 738             match e with
 739             | None -> beginning + 20
 740             | Some x -> x
 741           in
 742             if mdle = curr_mod then
 743               show_listing pos mdle beginning en point
 744                 (current_event_is_before ())
 745             else
 746               show_listing pos mdle beginning en (-1) true
 747
 748 (** Variables. **)
 749 let raw_variable kill name =
 750   (function lexbuf ->
 751      let argument = argument_eol argument lexbuf in
 752        if (not kill) || ask_kill_program () then name := argument),
 753   function ppf -> fprintf ppf "%s@." !name
 754
 755 let raw_line_variable kill name =
 756   (function lexbuf ->
 757      let argument = argument_eol line_argument lexbuf in
 758        if (not kill) || ask_kill_program () then name := argument),
 759   function ppf -> fprintf ppf "%s@." !name
 760
 761 let integer_variable kill min msg name =
 762   (function lexbuf ->
 763      let argument = integer_eol Lexer.lexeme lexbuf in
 764        if argument < min then print_endline msg
 765        else if (not kill) || ask_kill_program () then name := argument),
 766   function ppf -> fprintf ppf "%i@." !name
 767
 768 let int64_variable kill min msg name =
 769   (function lexbuf ->
 770      let argument = int64_eol Lexer.lexeme lexbuf in
 771        if argument < min then print_endline msg
 772        else if (not kill) || ask_kill_program () then name := argument),
 773   function ppf -> fprintf ppf "%Li@." !name
 774
 775 let boolean_variable kill name =
 776   (function lexbuf ->
 777      let argument =
 778        match identifier_eol Lexer.lexeme lexbuf with
 779        | "on" -> true
 780        | "of" | "off" -> false
 781        | _ -> error "Syntax error."
 782      in
 783        if (not kill) || ask_kill_program () then name := argument),
 784   function ppf -> fprintf ppf "%s@." (if !name then "on" else "off")
 785
 786 let path_variable kill name =
 787   (function lexbuf ->
 788        let argument = argument_eol argument lexbuf in
 789          if (not kill) || ask_kill_program () then
 790            name := make_absolute (expand_path argument)),
 791   function ppf -> fprintf ppf "%s@." !name
 792
 793 let loading_mode_variable ppf =
 794   (find_ident
 795      "loading mode"
 796      (matching_elements (ref loading_modes) fst)
 797      (fun (_, mode) ppf lexbuf ->
 798         eol lexbuf; set_launching_function mode)
 799      (function ppf -> error "Syntax error.")
 800      ppf),
 801   function ppf ->
 802     let rec find = function
 803       | [] -> ()
 804       | (name, funct) :: l ->
 805           if funct == !launching_func then fprintf ppf "%s" name else find l
 806     in
 807       find loading_modes;
 808       fprintf ppf "@."
 809
 810 (** Infos. **)
 811
 812 let pr_modules ppf mods =
 813  let pr_mods ppf = List.iter (function x -> fprintf ppf "%s@ " x) in
 814  fprintf ppf "Used modules :@.%a@?" pr_mods mods
 815
 816 let info_modules ppf lexbuf =
 817   eol lexbuf;
 818   ensure_loaded ();
 819   pr_modules ppf !modules
 820 (********
 821   print_endline "Opened modules :";
 822   if !opened_modules_names = [] then
 823     print_endline "(no module opened)."
 824   else
 825     (List.iter (function x -> print_string x; print_space) !opened_modules_names;
 826      print_newline ())
 827 *********)
 828
 829 let info_checkpoints ppf lexbuf =
 830   eol lexbuf;
 831   if !checkpoints = [] then fprintf ppf "No checkpoint.@."
 832   else
 833     (if !debug_breakpoints then
 834        (prerr_endline "               Time   Pid Version";
 835         List.iter
 836           (function
 837              {c_time = time; c_pid = pid; c_breakpoint_version = version} ->
 838                Printf.printf "%19Ld %5d %d\n" time pid version)
 839           !checkpoints)
 840      else
 841        (print_endline "               Time   Pid";
 842         List.iter
 843           (function
 844              {c_time = time; c_pid = pid} ->
 845                Printf.printf "%19Ld %5d\n" time pid)
 846           !checkpoints))
 847
 848 let info_one_breakpoint ppf (num, ev) =
 849   fprintf ppf "%3d %10d  %s@." num ev.ev_pos (Pos.get_desc ev);
 850 ;;
 851
 852 let info_breakpoints ppf lexbuf =
 853   eol lexbuf;
 854   if !breakpoints = [] then fprintf ppf "No breakpoints.@."
 855   else begin
 856     fprintf ppf "Num    Address  Where@.";
 857     List.iter (info_one_breakpoint ppf) (List.rev !breakpoints);
 858   end
 859 ;;
 860
 861 let info_events ppf lexbuf =
 862   ensure_loaded ();
 863   let mdle = convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) in
 864     print_endline ("Module : " ^ mdle);
 865     print_endline "   Address  Characters        Kind      Repr.";
 866     List.iter
 867       (function ev ->
 868         let start_char, end_char =
 869           try
 870             let buffer = get_buffer (Events.get_pos ev) ev.ev_module in
 871             (snd (start_and_cnum buffer ev.ev_loc.Location.loc_start)),
 872             (snd (start_and_cnum buffer ev.ev_loc.Location.loc_end))
 873           with _ ->
 874             ev.ev_loc.Location.loc_start.Lexing.pos_cnum,
 875             ev.ev_loc.Location.loc_end.Lexing.pos_cnum in
 876         Printf.printf
 877            "%10d %6d-%-6d  %10s %10s\n"
 878            ev.ev_pos
 879            start_char
 880            end_char
 881            ((match ev.ev_kind with
 882                Event_before   -> "before"
 883              | Event_after _  -> "after"
 884              | Event_pseudo   -> "pseudo")
 885             ^
 886             (match ev.ev_info with
 887                Event_function -> "/fun"
 888              | Event_return _ -> "/ret"
 889              | Event_other    -> ""))
 890            (match ev.ev_repr with
 891               Event_none        -> ""
 892             | Event_parent _    -> "(repr)"
 893             | Event_child repr  -> string_of_int !repr))
 894       (events_in_module mdle)
 895
 896 (** User-defined printers **)
 897
 898 let instr_load_printer ppf lexbuf =
 899   let filename = extract_filename(argument_eol argument lexbuf) in
 900   try
 901     Loadprinter.loadfile ppf filename
 902   with Loadprinter.Error e ->
 903     Loadprinter.report_error ppf e; raise Toplevel
 904
 905 let instr_install_printer ppf lexbuf =
 906   let lid = longident_eol Lexer.lexeme lexbuf in
 907   try
 908     Loadprinter.install_printer ppf lid
 909   with Loadprinter.Error e ->
 910     Loadprinter.report_error ppf e; raise Toplevel
 911
 912 let instr_remove_printer ppf lexbuf =
 913   let lid = longident_eol Lexer.lexeme lexbuf in
 914   try
 915     Loadprinter.remove_printer lid
 916   with Loadprinter.Error e ->
 917     Loadprinter.report_error ppf e; raise Toplevel
 918
 919 (** Initialization. **)
 920 let init ppf =
 921   instruction_list := [
 922      { instr_name = "cd"; instr_prio = false;
 923        instr_action = instr_cd; instr_repeat = true; instr_help =
 924 "set working directory to DIR for debugger and program being debugged." };
 925      { instr_name = "complete"; instr_prio = false;
 926        instr_action = instr_complete; instr_repeat = false; instr_help =
 927 "complete word at cursor according to context. Useful for Emacs." };
 928      { instr_name = "pwd"; instr_prio = false;
 929        instr_action = instr_pwd; instr_repeat = true; instr_help =
 930 "print working directory." };
 931      { instr_name = "directory"; instr_prio = false;
 932        instr_action = instr_dir; instr_repeat = false; instr_help =
 933 "add directory DIR to beginning of search path for source and\n\
 934 interface files.\n\
 935 Forget cached info on source file locations and line positions.\n\
 936 With no argument, reset the search path." };
 937      { instr_name = "kill"; instr_prio = false;
 938        instr_action = instr_kill; instr_repeat = true; instr_help =
 939 "kill the program being debugged." };
 940      { instr_name = "help"; instr_prio = false;
 941        instr_action = instr_help; instr_repeat = true; instr_help =
 942 "print list of commands." };
 943      { instr_name = "quit"; instr_prio = false;
 944        instr_action = instr_quit; instr_repeat = false; instr_help =
 945 "exit the debugger." };
 946      { instr_name = "shell"; instr_prio = false;
 947        instr_action = instr_shell; instr_repeat = true; instr_help =
 948 "Execute a given COMMAND thru the system shell." };
 949       (* Displacements *)
 950      { instr_name = "run"; instr_prio = true;
 951        instr_action = instr_run; instr_repeat = true; instr_help =
 952 "run the program from current position." };
 953      { instr_name = "reverse"; instr_prio = false;
 954        instr_action = instr_reverse; instr_repeat = true; instr_help =
 955 "run the program backward from current position." };
 956      { instr_name = "step"; instr_prio = true;
 957        instr_action = instr_step; instr_repeat = true; instr_help =
 958 "step program until it reaches the next event.\n\
 959 Argument N means do this N times (or till program stops for another reason)." };
 960      { instr_name = "backstep"; instr_prio = true;
 961        instr_action = instr_back; instr_repeat = true; instr_help =
 962 "step program backward until it reaches the previous event.\n\
 963 Argument N means do this N times (or till program stops for another reason)." };
 964      { instr_name = "goto"; instr_prio = false;
 965        instr_action = instr_goto; instr_repeat = true; instr_help =
 966 "go to the given time." };
 967      { instr_name = "finish"; instr_prio = true;
 968        instr_action = instr_finish; instr_repeat = true; instr_help =
 969 "execute until topmost stack frame returns." };
 970      { instr_name = "next"; instr_prio = true;
 971        instr_action = instr_next; instr_repeat = true; instr_help =
 972 "step program until it reaches the next event.\n\
 973 Skip over function calls.\n\
 974 Argument N means do this N times (or till program stops for another reason)." };
 975      { instr_name = "start"; instr_prio = false;
 976        instr_action = instr_start; instr_repeat = true; instr_help =
 977 "execute backward until the current function is exited." };
 978      { instr_name = "previous"; instr_prio = false;
 979        instr_action = instr_previous; instr_repeat = true; instr_help =
 980 "step program until it reaches the previous event.\n\
 981 Skip over function calls.\n\
 982 Argument N means do this N times (or till program stops for another reason)." };
 983      { instr_name = "print"; instr_prio = true;
 984        instr_action = instr_print; instr_repeat = true; instr_help =
 985 "print value of expressions (deep printing)." };
 986      { instr_name = "display"; instr_prio = true;
 987        instr_action = instr_display; instr_repeat = true; instr_help =
 988 "print value of expressions (shallow printing)." };
 989      { instr_name = "source"; instr_prio = false;
 990        instr_action = instr_source; instr_repeat = true; instr_help =
 991 "read command from file FILE." };
 992      (* Breakpoints *)
 993      { instr_name = "break"; instr_prio = false;
 994        instr_action = instr_break; instr_repeat = false; instr_help =
 995 "Set breakpoint at specified line or function.\n\
 996 Syntax: break function-name\n\
 997         break @ [module] linenum\n\
 998         break @ [module] # characternum" };
 999      { instr_name = "delete"; instr_prio = false;
1000        instr_action = instr_delete; instr_repeat = false; instr_help =
1001 "delete some breakpoints.\n\
1002 Arguments are breakpoint numbers with spaces in between.\n\
1003 To delete all breakpoints, give no argument." };
1004      { instr_name = "set"; instr_prio = false;
1005        instr_action = instr_set; instr_repeat = false; instr_help =
1006 "--unused--" };
1007      { instr_name = "show"; instr_prio = false;
1008        instr_action = instr_show; instr_repeat = true; instr_help =
1009 "--unused--" };
1010      { instr_name = "info"; instr_prio = false;
1011        instr_action = instr_info; instr_repeat = true; instr_help =
1012 "--unused--" };
1013      (* Frames *)
1014      { instr_name = "frame"; instr_prio = false;
1015        instr_action = instr_frame; instr_repeat = true; instr_help =
1016 "select and print a stack frame.\n\
1017 With no argument, print the selected stack frame.\n\
1018 An argument specifies the frame to select." };
1019      { instr_name = "backtrace"; instr_prio = false;
1020        instr_action = instr_backtrace; instr_repeat = true; instr_help =
1021 "print backtrace of all stack frames, or innermost COUNT frames.\n\
1022 With a negative argument, print outermost -COUNT frames." };
1023      { instr_name = "bt"; instr_prio = false;
1024        instr_action = instr_backtrace; instr_repeat = true; instr_help =
1025 "print backtrace of all stack frames, or innermost COUNT frames.\n\
1026 With a negative argument, print outermost -COUNT frames." };
1027      { instr_name = "up"; instr_prio = false;
1028        instr_action = instr_up; instr_repeat = true; instr_help =
1029 "select and print stack frame that called this one.\n\
1030 An argument says how many frames up to go." };
1031      { instr_name = "down"; instr_prio = false;
1032        instr_action = instr_down; instr_repeat = true; instr_help =
1033 "select and print stack frame called by this one.\n\
1034 An argument says how many frames down to go." };
1035      { instr_name = "last"; instr_prio = true;
1036        instr_action = instr_last; instr_repeat = true; instr_help =
1037 "go back to previous time." };
1038      { instr_name = "list"; instr_prio = false;
1039        instr_action = instr_list; instr_repeat = true; instr_help =
1040 "list the source code." };
1041      (* User-defined printers *)
1042      { instr_name = "load_printer"; instr_prio = false;
1043        instr_action = instr_load_printer; instr_repeat = false; instr_help =
1044 "load in the debugger a .cmo or .cma file containing printing functions." };
1045      { instr_name = "install_printer"; instr_prio = false;
1046        instr_action = instr_install_printer; instr_repeat = false; instr_help =
1047 "use the given function for printing values of its input type.\n\
1048 The code for the function must have previously been loaded in the debugger\n\
1049 using \"load_printer\"." };
1050      { instr_name = "remove_printer"; instr_prio = false;
1051        instr_action = instr_remove_printer; instr_repeat = false; instr_help =
1052 "stop using the given function for printing values of its input type." }
1053 ];
1054   variable_list := [
1055     (* variable name, (writing, reading), help reading, help writing *)
1056      { var_name = "arguments";
1057        var_action = raw_line_variable true arguments;
1058        var_help =
1059 "arguments to give program being debugged when it is started." };
1060      { var_name = "program";
1061        var_action = path_variable true program_name;
1062        var_help =
1063 "name of program to be debugged." };
1064      { var_name = "loadingmode";
1065        var_action = loading_mode_variable ppf;
1066        var_help =
1067 "mode of loading.\n\
1068 It can be either :
1069   direct : the program is directly called by the debugger.\n\
1070   runtime : the debugger execute `ocamlrun programname arguments'.\n\
1071   manual : the program is not launched by the debugger,\n\
1072     but manually by the user." };
1073      { var_name = "processcount";
1074        var_action = integer_variable false 1 "Must be >= 1."
1075                                      checkpoint_max_count;
1076        var_help =
1077 "maximum number of process to keep." };
1078      { var_name = "checkpoints";
1079        var_action = boolean_variable false make_checkpoints;
1080        var_help =
1081 "whether to make checkpoints or not." };
1082      { var_name = "bigstep";
1083        var_action = int64_variable false _1 "Must be >= 1."
1084                                      checkpoint_big_step;
1085        var_help =
1086 "step between checkpoints during long displacements." };
1087      { var_name = "smallstep";
1088        var_action = int64_variable false _1 "Must be >= 1."
1089                                      checkpoint_small_step;
1090        var_help =
1091 "step between checkpoints during small displacements." };
1092      { var_name = "socket";
1093        var_action = raw_variable true socket_name;
1094        var_help =
1095 "name of the socket used by communications debugger-runtime." };
1096      { var_name = "history";
1097        var_action = integer_variable false 0 "" history_size;
1098        var_help =
1099 "history size." };
1100      { var_name = "print_depth";
1101        var_action = integer_variable false 1 "Must be at least 1"
1102                                      max_printer_depth;
1103        var_help =
1104 "maximal depth for printing of values." };
1105      { var_name = "print_length";
1106        var_action = integer_variable false 1 "Must be at least 1"
1107                                      max_printer_steps;
1108        var_help =
1109 "maximal number of value nodes printed." }];
1110
1111   info_list :=
1112     (* info name, function, help *)
1113     [{ info_name = "modules";
1114        info_action = info_modules ppf;
1115        info_help = "list opened modules." };
1116      { info_name = "checkpoints";
1117        info_action = info_checkpoints ppf;
1118        info_help = "list checkpoints." };
1119      { info_name = "breakpoints";
1120        info_action = info_breakpoints ppf;
1121        info_help = "list breakpoints." };
1122      { info_name = "events";
1123        info_action = info_events ppf;
1124        info_help = "list events in MODULE (default is current module)." }]
1125
1126 let _ = init std_formatter