Source

ocaml / debugger / command_line.ml

Full commit
   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
(*          OCaml port by John Malecki and Xavier Leroy                *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

(************************ Reading and executing commands ***************)

open Int64ops
open Format
open Misc
open Instruct
open Unix
open Debugger_config
open Types
open Primitives
open Unix_tools
open Parser
open Parser_aux
open Lexer
open Input_handling
open Question
open Debugcom
open Program_loading
open Program_management
open Lexing
open Parameters
open Show_source
open Show_information
open Time_travel
open Events
open Symbols
open Source
open Breakpoints
open Checkpoints
open Frames
open Printval

(** Instructions, variables and infos lists. **)
type dbg_instruction =
  { instr_name: string;                 (* Name of command *)
    instr_prio: bool;                   (* Has priority *)
    instr_action: formatter -> lexbuf -> unit;
                                        (* What to do *)
    instr_repeat: bool;                 (* Can be repeated *)
    instr_help: string }                (* Help message *)

let instruction_list = ref ([] : dbg_instruction list)

type dbg_variable =
  { var_name: string;                   (* Name of variable *)
    var_action: (lexbuf -> unit) * (formatter -> unit);
                                        (* Reading, writing fns *)
    var_help: string }                  (* Help message *)

let variable_list = ref ([] : dbg_variable list)

type dbg_info =
  { info_name: string;                  (* Name of info *)
    info_action: lexbuf -> unit;        (* What to do *)
    info_help: string }                 (* Help message *)

let info_list = ref ([] : dbg_info list)

(** Utilities. **)
let error text =
  eprintf "%s@." text;
  raise Toplevel

let check_not_windows feature =
  match Sys.os_type with
  | "Win32" ->
      error ("'"^feature^"' feature not supported on Windows")
  | _ ->
      ()

let eol =
  end_of_line Lexer.lexeme

let matching_elements list name instr =
  List.filter (function a -> isprefix instr (name a)) !list

let all_matching_instructions =
  matching_elements instruction_list (fun i -> i.instr_name)

(* itz 04-21-96 don't do priority completion in emacs mode *)
(* XL 25-02-97 why? I find it very confusing. *)

let matching_instructions instr =
  let all = all_matching_instructions instr in
  let prio = List.filter (fun i -> i.instr_prio) all in
  if prio = [] then all else prio

let matching_variables =
  matching_elements variable_list (fun v -> v.var_name)

let matching_infos =
  matching_elements info_list (fun i -> i.info_name)

let find_ident name matcher action alternative ppf lexbuf =
  match identifier_or_eol Lexer.lexeme lexbuf with
  | None -> alternative ppf
  | Some ident ->
      match matcher ident with
      | [] -> error ("Unknown " ^ name ^ ".")
      | [a] -> action a ppf lexbuf
      | _ -> error ("Ambiguous " ^ name ^ ".")

let find_variable action alternative ppf lexbuf =
  find_ident "variable name" matching_variables action alternative ppf lexbuf

let find_info action alternative ppf lexbuf =
  find_ident "info command" matching_infos action alternative ppf lexbuf

let add_breakpoint_at_pc pc =
  try
    new_breakpoint (any_event_at_pc pc)
  with
  | Not_found ->
    eprintf "Can't add breakpoint at pc %i : no event there.@." pc;
    raise Toplevel

let add_breakpoint_after_pc pc =
  let rec try_add n =
    if n < 3 then begin
      try
        new_breakpoint (any_event_at_pc (pc + n * 4))
      with
      | Not_found ->
        try_add (n+1)
    end else begin
      error
        "Can't add breakpoint at beginning of function: no event there"
    end
  in try_add 0

let module_of_longident id =
  match id with
  | Some x -> Some (String.concat "." (Longident.flatten x))
  | None -> None

let convert_module mdle =
  match mdle with
  | Some m ->
      (* Strip .ml extension if any, and capitalize *)
      String.capitalize(if Filename.check_suffix m ".ml"
                        then Filename.chop_suffix m ".ml"
                        else m)
  | None ->
      try
        (get_current_event ()).ev_module
      with
      | Not_found ->
          error "Not in a module."

(** Toplevel. **)
let current_line = ref ""

let interprete_line ppf line =
  current_line := line;
  let lexbuf = Lexing.from_string line in
    try
      match identifier_or_eol Lexer.lexeme lexbuf with
      | Some x ->
          begin match matching_instructions x with
          | [] ->
              error "Unknown command."
          | [i] ->
              i.instr_action ppf lexbuf;
              resume_user_input ();
              i.instr_repeat
          | l ->
              error "Ambiguous command."
          end
      | None ->
          resume_user_input ();
          false
    with
    | Parsing.Parse_error ->
        error "Syntax error."

let line_loop ppf line_buffer =
  resume_user_input ();
  let previous_line = ref "" in
    try
      while true do
        if !loaded then
          History.add_current_time ();
        let new_line = string_trim (line line_buffer) in
          let line =
            if new_line <> "" then
              new_line
            else
              !previous_line
          in
            previous_line := "";
            if interprete_line ppf line then
              previous_line := line
      done
    with
    | Exit ->
        stop_user_input ()
(*    | Sys_error s ->
        error ("System error : " ^ s) *)

(** Instructions. **)
let instr_cd ppf lexbuf =
  let dir = argument_eol argument lexbuf in
    if ask_kill_program () then
      try
        Sys.chdir (expand_path dir)
      with
      | Sys_error s ->
          error s

let instr_shell ppf lexbuf =
  let cmdarg = argument_list_eol argument lexbuf in
  let cmd = String.concat " " cmdarg in
  (* perhaps we should use $SHELL -c ? *)
  let err = Sys.command cmd in
  if (err != 0) then
    eprintf "Shell command %S failed with exit code %d\n%!" cmd err

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%!"
  else
    List.iter
      (printf "%s\n%!")
      (List.rev !Debugger_config.environment)

let instr_pwd ppf lexbuf =
  eol lexbuf;
  fprintf ppf "%s@." (Sys.getcwd ())

let instr_dir ppf lexbuf =
  let new_directory = argument_list_eol argument lexbuf in
    if new_directory = [] then begin
      if yes_or_no "Reinitialize directory list" then begin
        Config.load_path := !default_load_path;
        Envaux.reset_cache ();
        Hashtbl.clear Debugger_config.load_path_for;
        flush_buffer_list ()
        end
      end
    else begin
      let new_directory' = List.rev new_directory in
      match new_directory' with
      | mdl :: for_keyw :: tl when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 ->
          List.iter (function x -> add_path_for mdl (expand_path x)) tl
      | _ ->
          List.iter (function x -> add_path (expand_path x)) new_directory'
    end;
    let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in
    fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path;
    Hashtbl.iter
      (fun mdl dirs ->
        fprintf ppf "@[<2>Source directories for %s :%a@]@." mdl print_dirs dirs)
      Debugger_config.load_path_for

let instr_kill ppf lexbuf =
  eol lexbuf;
  if not !loaded then error "The program is not being run.";
  if (yes_or_no "Kill the program being debugged") then begin
    kill_program ();
    show_no_point()
  end

let instr_run ppf lexbuf =
  eol lexbuf;
  ensure_loaded ();
  reset_named_values ();
  run ();
  show_current_event ppf;;

let instr_reverse ppf lexbuf =
  eol lexbuf;
  check_not_windows "reverse";
  ensure_loaded ();
  reset_named_values();
  back_run ();
  show_current_event ppf

let instr_step ppf lexbuf =
  let step_count =
    match opt_signed_int64_eol Lexer.lexeme lexbuf with
    | None -> _1
    | Some x -> x
  in
    ensure_loaded ();
    reset_named_values();
    step step_count;
    show_current_event ppf

let instr_back ppf lexbuf =
  let step_count =
    match opt_signed_int64_eol Lexer.lexeme lexbuf with
    | None -> _1
    | Some x -> x
  in
    check_not_windows "backstep";
    ensure_loaded ();
    reset_named_values();
    step (_0 -- step_count);
    show_current_event ppf

let instr_finish ppf lexbuf =
  eol lexbuf;
  ensure_loaded ();
  reset_named_values();
  finish ();
  show_current_event ppf

let instr_next ppf lexbuf =
  let step_count =
    match opt_integer_eol Lexer.lexeme lexbuf with
    | None -> 1
    | Some x -> x
  in
    ensure_loaded ();
    reset_named_values();
    next step_count;
    show_current_event ppf

let instr_start ppf lexbuf =
  eol lexbuf;
  check_not_windows "start";
  ensure_loaded ();
  reset_named_values();
  start ();
  show_current_event ppf

let instr_previous ppf lexbuf =
  let step_count =
    match opt_integer_eol Lexer.lexeme lexbuf with
    | None -> 1
    | Some x -> x
  in
    check_not_windows "previous";
    ensure_loaded ();
    reset_named_values();
    previous step_count;
    show_current_event ppf

let instr_goto ppf lexbuf =
  let time = int64_eol Lexer.lexeme lexbuf in
    ensure_loaded ();
    reset_named_values();
    go_to time;
    show_current_event ppf

let instr_quit _ =
  raise Exit

let print_variable_list ppf =
  let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in
  fprintf ppf "List of variables :%a@." pr_vars !variable_list

let print_info_list ppf =
  let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name)  in
  fprintf ppf "List of info commands :%a@." pr_infos !info_list

let instr_complete ppf lexbuf =
  let ppf = Format.err_formatter in
  let rec print_list l =
    try
      eol lexbuf;
      List.iter (function i -> fprintf ppf "%s@." i) l
    with _ ->
      remove_file !user_channel
  and match_list lexbuf =
    match identifier_or_eol Lexer.lexeme lexbuf with
    | None ->
        List.map (fun i -> i.instr_name) !instruction_list
    | Some x ->
        match matching_instructions x with
        | [ {instr_name = ("set" | "show" as i_full)} ] ->
            if x = i_full then begin
              match identifier_or_eol Lexer.lexeme lexbuf with
              | Some ident ->
                  begin match matching_variables ident with
                  | [v] -> if v.var_name = ident then [] else [v.var_name]
                  | l   -> List.map (fun v -> v.var_name) l
                  end
              | None ->
                  List.map (fun v -> v.var_name) !variable_list
            end
            else [i_full]
        | [ {instr_name = "info"} ] ->
            if x = "info" then begin
              match identifier_or_eol Lexer.lexeme lexbuf with
              | Some ident ->
                  begin match matching_infos ident with
                  | [i] -> if i.info_name = ident then [] else [i.info_name]
                  | l   -> List.map (fun i -> i.info_name) l
                  end
              | None ->
                  List.map (fun i -> i.info_name) !info_list
            end
            else ["info"]
        | [ {instr_name = "help"} ] ->
            if x = "help" then match_list lexbuf else ["help"]
        | [ i ] ->
            if x = i.instr_name then [] else [i.instr_name]
        | l ->
            List.map (fun i -> i.instr_name) l
  in
    print_list(match_list lexbuf)

let instr_help ppf lexbuf =
  let pr_instrs ppf =
      List.iter (fun i -> fprintf ppf "%s@ " i.instr_name) in
  match identifier_or_eol Lexer.lexeme lexbuf with
  | Some x ->
      let print_help nm hlp =
        eol lexbuf;
        fprintf ppf "%s : %s@." nm hlp in
      begin match matching_instructions x with
      | [] ->
          eol lexbuf;
          fprintf ppf "No matching command.@."
      | [ {instr_name = "set"} ] ->
          find_variable
            (fun v _ _ ->
               print_help ("set " ^ v.var_name) ("set " ^ v.var_help))
            (fun ppf ->
               print_help "set" "set debugger variable.";
               print_variable_list ppf)
            ppf
            lexbuf
      | [ {instr_name = "show"} ] ->
          find_variable
            (fun v _ _ ->
               print_help ("show " ^ v.var_name) ("show " ^ v.var_help))
            (fun v ->
               print_help "show" "display debugger variable.";
               print_variable_list ppf)
            ppf
            lexbuf
      | [ {instr_name = "info"} ] ->
          find_info
            (fun i _ _ -> print_help ("info " ^ i.info_name) i.info_help)
            (fun ppf ->
               print_help "info"
                 "display infos about the program being debugged.";
               print_info_list ppf)
            ppf
            lexbuf
      | [i] ->
          print_help i.instr_name i.instr_help
      | l ->
          eol lexbuf;
          fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l
      end
  | None ->
      fprintf ppf "List of commands : %a@." pr_instrs !instruction_list

(* Printing values *)

let print_expr depth ev env ppf expr =
  try
    let (v, ty) = Eval.expression ev env expr in
    print_named_value depth expr env v ppf ty
  with
  | Eval.Error msg ->
    Eval.report_error ppf msg;
    raise Toplevel

let env_of_event =
  function
    None    -> Env.empty
  | Some ev -> Envaux.env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst

let print_command depth ppf lexbuf =
  let exprs = expression_list_eol Lexer.lexeme lexbuf in
  ensure_loaded ();
  let env =
    try
      env_of_event !selected_event
    with
    | Envaux.Error msg ->
        Envaux.report_error ppf msg;
        raise Toplevel
  in
  List.iter (print_expr depth !selected_event env ppf) exprs

let instr_print ppf lexbuf = print_command !max_printer_depth ppf lexbuf

let instr_display ppf lexbuf = print_command 1 ppf lexbuf

(* Loading of command files *)

let extract_filename arg =
  (* Allow enclosing filename in quotes *)
  let l = String.length arg in
  let pos1 = if l > 0 && arg.[0] = '"' then 1 else 0 in
  let pos2 = if l > 0 && arg.[l-1] = '"' then l-1 else l in
  String.sub arg pos1 (pos2 - pos1)

let instr_source ppf lexbuf =
  let file = extract_filename(argument_eol argument lexbuf)
  and old_state = !interactif
  and old_channel = !user_channel in
    let io_chan =
      try
        io_channel_of_descr
          (openfile (find_in_path !Config.load_path (expand_path file))
             [O_RDONLY] 0)
      with
      | Not_found -> error "Source file not found."
      | (Unix_error _) as x  -> Unix_tools.report_error x; raise Toplevel
    in
      try
        interactif := false;
        user_channel := io_chan;
        line_loop ppf (Lexing.from_function read_user_input);
        close_io io_chan;
        interactif := old_state;
        user_channel := old_channel
      with
      | x ->
          stop_user_input ();
          close_io io_chan;
          interactif := old_state;
          user_channel := old_channel;
          raise x

let instr_set =
  find_variable
    (fun {var_action = (funct, _)} ppf lexbuf -> funct lexbuf)
    (function ppf -> error "Argument required.")

let instr_show =
  find_variable
    (fun {var_action = (_, funct)} ppf lexbuf -> eol lexbuf; funct ppf)
    (function ppf ->
       List.iter
         (function {var_name = nm; var_action = (_, funct)} ->
              fprintf ppf "%s : " nm;
              funct ppf)
         !variable_list)

let instr_info =
  find_info
    (fun i ppf lexbuf -> i.info_action lexbuf)
    (function ppf ->
       error "\"info\" must be followed by the name of an info command.")

let instr_break ppf lexbuf =
  let argument = break_argument_eol Lexer.lexeme lexbuf in
    ensure_loaded ();
    match argument with
    |  BA_none ->                                (* break *)
        (match !selected_event with
         | Some ev ->
             new_breakpoint ev
         | None ->
             error "Can't add breakpoint at this point.")
    | BA_pc pc ->                               (* break PC *)
        add_breakpoint_at_pc pc
    | BA_function expr ->                       (* break FUNCTION *)
        let env =
          try
            env_of_event !selected_event
          with
          | Envaux.Error msg ->
              Envaux.report_error ppf msg;
              raise Toplevel
        in
        begin try
          let (v, ty) = Eval.expression !selected_event env expr in
          match (Ctype.repr ty).desc with
          | Tarrow _ ->
              add_breakpoint_after_pc (Remote_value.closure_code v)
          | _ ->
              eprintf "Not a function.@.";
              raise Toplevel
        with
        | Eval.Error msg ->
            Eval.report_error ppf msg;
            raise Toplevel
        end
    | BA_pos1 (mdle, line, column) ->         (* break @ [MODULE] LINE [COL] *)
        let module_name = convert_module (module_of_longident mdle) in
        new_breakpoint
          (try
             let buffer =
               try get_buffer Lexing.dummy_pos module_name with
               | Not_found ->
                  eprintf "No source file for %s.@." module_name;
                  raise Toplevel
             in
             match column with
             | None ->
                 event_at_pos module_name (fst (pos_of_line buffer line))
             | Some col ->
                 event_near_pos module_name (point_of_coord buffer line col)
           with
           | Not_found -> (* event_at_pos / event_near pos *)
               eprintf "Can't find any event there.@.";
               raise Toplevel
           | Out_of_range -> (* pos_of_line / point_of_coord *)
               eprintf "Position out of range.@.";
               raise Toplevel)
    | BA_pos2 (mdle, position) ->             (* break @ [MODULE] # POSITION *)
        try
          new_breakpoint (event_near_pos (convert_module (module_of_longident mdle)) position)
        with
        | Not_found ->
            eprintf "Can't find any event there.@."

let instr_delete ppf lexbuf =
  match integer_list_eol Lexer.lexeme lexbuf with
  | [] ->
      if breakpoints_count () <> 0 && yes_or_no "Delete all breakpoints"
      then remove_all_breakpoints ()
  | breakpoints ->
      List.iter
        (function x -> try remove_breakpoint x with | Not_found -> ())
        breakpoints

let instr_frame ppf lexbuf =
  let frame_number =
    match opt_integer_eol Lexer.lexeme lexbuf with
    | None -> !current_frame
    | Some x -> x
  in
    ensure_loaded ();
    try
      select_frame frame_number;
      show_current_frame ppf true
    with
    | Not_found ->
        error ("No frame number " ^ string_of_int frame_number ^ ".")

let instr_backtrace ppf lexbuf =
  let number =
    match opt_signed_integer_eol Lexer.lexeme lexbuf with
    | None -> 0
    | Some x -> x in
  ensure_loaded ();
  match current_report() with
  | None | Some {rep_type = Exited | Uncaught_exc} -> ()
  | Some _ ->
      let frame_counter = ref 0 in
      let print_frame first_frame last_frame = function
      | None ->
          fprintf ppf
           "(Encountered a function with no debugging information)@.";
          false
      | Some event ->
          if !frame_counter >= first_frame then
            show_one_frame !frame_counter ppf event;
          incr frame_counter;
          if !frame_counter >= last_frame then begin
            fprintf ppf "(More frames follow)@."
          end;
          !frame_counter < last_frame in
      fprintf ppf "Backtrace:@.";
      if number = 0 then
        do_backtrace (print_frame 0 max_int)
      else if number > 0 then
        do_backtrace (print_frame 0 number)
      else begin
        let num_frames = stack_depth() in
        if num_frames < 0 then
          fprintf ppf
            "(Encountered a function with no debugging information)@."
        else
          do_backtrace (print_frame (num_frames + number) max_int)
      end

let instr_up ppf lexbuf =
  let offset =
    match opt_signed_integer_eol Lexer.lexeme lexbuf with
    | None -> 1
    | Some x -> x
  in
    ensure_loaded ();
    try
      select_frame (!current_frame + offset);
      show_current_frame ppf true
    with
    | Not_found -> error "No such frame."

let instr_down ppf lexbuf =
  let offset =
    match opt_signed_integer_eol Lexer.lexeme lexbuf with
    | None -> 1
    | Some x -> x
  in
    ensure_loaded ();
    try
      select_frame (!current_frame - offset);
      show_current_frame ppf true
    with
    | Not_found -> error "No such frame."

let instr_last ppf lexbuf =
  let count =
    match opt_signed_int64_eol Lexer.lexeme lexbuf with
    | None -> _1
    | Some x -> x
  in
    check_not_windows "last";
    reset_named_values();
    go_to (History.previous_time count);
    show_current_event ppf

let instr_list ppf lexbuf =
  let (mo, beg, e) = list_arguments_eol Lexer.lexeme lexbuf in
    let (curr_mod, line, column) =
      try
        selected_point ()
      with
      | Not_found ->
          ("", -1, -1)
    in
      let mdle = convert_module (module_of_longident mo) in
      let pos = Lexing.dummy_pos in
      let buffer =
        try get_buffer pos mdle with
        | Not_found -> error ("No source file for " ^ mdle ^ ".") in
      let point =
        if column <> -1 then
          (point_of_coord buffer line 1) + column
        else
          -1 in
        let beginning =
          match beg with
          | None when (mo <> None) || (line = -1) ->
              1
          | None ->
              begin try
                max 1 (line - 10)
              with Out_of_range ->
                1
              end
          | Some x -> x
        in
          let en =
            match e with
            | None -> beginning + 20
            | Some x -> x
          in
            if mdle = curr_mod then
              show_listing pos mdle beginning en point
                (current_event_is_before ())
            else
              show_listing pos mdle beginning en (-1) true

(** Variables. **)
let raw_variable kill name =
  (function lexbuf ->
     let argument = argument_eol argument lexbuf in
       if (not kill) || ask_kill_program () then name := argument),
  function ppf -> fprintf ppf "%s@." !name

let raw_line_variable kill name =
  (function lexbuf ->
     let argument = argument_eol line_argument lexbuf in
       if (not kill) || ask_kill_program () then name := argument),
  function ppf -> fprintf ppf "%s@." !name

let integer_variable kill min msg name =
  (function lexbuf ->
     let argument = integer_eol Lexer.lexeme lexbuf in
       if argument < min then print_endline msg
       else if (not kill) || ask_kill_program () then name := argument),
  function ppf -> fprintf ppf "%i@." !name

let int64_variable kill min msg name =
  (function lexbuf ->
     let argument = int64_eol Lexer.lexeme lexbuf in
       if argument < min then print_endline msg
       else if (not kill) || ask_kill_program () then name := argument),
  function ppf -> fprintf ppf "%Li@." !name

let boolean_variable kill name =
  (function lexbuf ->
     let argument =
       match identifier_eol Lexer.lexeme lexbuf with
       | "on" -> true
       | "of" | "off" -> false
       | _ -> error "Syntax error."
     in
       if (not kill) || ask_kill_program () then name := argument),
  function ppf -> fprintf ppf "%s@." (if !name then "on" else "off")

let path_variable kill name =
  (function lexbuf ->
       let argument = argument_eol argument lexbuf in
         if (not kill) || ask_kill_program () then
           name := make_absolute (expand_path argument)),
  function ppf -> fprintf ppf "%s@." !name

let loading_mode_variable ppf =
  (find_ident
     "loading mode"
     (matching_elements (ref loading_modes) fst)
     (fun (_, mode) ppf lexbuf ->
        eol lexbuf; set_launching_function mode)
     (function ppf -> error "Syntax error.")
     ppf),
  function ppf ->
    let rec find = function
      | [] -> ()
      | (name, funct) :: l ->
          if funct == !launching_func then fprintf ppf "%s" name else find l
    in
      find loading_modes;
      fprintf ppf "@."

let follow_fork_variable =
  (function lexbuf ->
     let mode =
       match identifier_eol Lexer.lexeme lexbuf with
       | "child" -> Fork_child
       | "parent" -> Fork_parent
       | _ -> error "Syntax error."
     in
       fork_mode := mode;
       if !loaded then update_follow_fork_mode ()),
  function ppf ->
    fprintf ppf "%s@."
      (match !fork_mode with
         Fork_child -> "child"
       | Fork_parent -> "parent")

(** Infos. **)

let pr_modules ppf mods =
 let pr_mods ppf = List.iter (function x -> fprintf ppf "%s@ " x) in
 fprintf ppf "Used modules :@.%a@?" pr_mods mods

let info_modules ppf lexbuf =
  eol lexbuf;
  ensure_loaded ();
  pr_modules ppf !modules
(********
  print_endline "Opened modules :";
  if !opened_modules_names = [] then
    print_endline "(no module opened)."
  else
    (List.iter (function x -> print_string x; print_space) !opened_modules_names;
     print_newline ())
*********)

let info_checkpoints ppf lexbuf =
  eol lexbuf;
  if !checkpoints = [] then fprintf ppf "No checkpoint.@."
  else
    (if !debug_breakpoints then
       (prerr_endline "               Time   Pid Version";
        List.iter
          (function
             {c_time = time; c_pid = pid; c_breakpoint_version = version} ->
               Printf.printf "%19Ld %5d %d\n" time pid version)
          !checkpoints)
     else
       (print_endline "               Time   Pid";
        List.iter
          (function
             {c_time = time; c_pid = pid} ->
               Printf.printf "%19Ld %5d\n" time pid)
          !checkpoints))

let info_one_breakpoint ppf (num, ev) =
  fprintf ppf "%3d %10d  %s@." num ev.ev_pos (Pos.get_desc ev);
;;

let info_breakpoints ppf lexbuf =
  eol lexbuf;
  if !breakpoints = [] then fprintf ppf "No breakpoints.@."
  else begin
    fprintf ppf "Num    Address  Where@.";
    List.iter (info_one_breakpoint ppf) (List.rev !breakpoints);
  end
;;

let info_events ppf lexbuf =
  ensure_loaded ();
  let mdle = convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) in
    print_endline ("Module : " ^ mdle);
    print_endline "   Address  Characters        Kind      Repr.";
    List.iter
      (function ev ->
        let start_char, end_char =
          try
            let buffer = get_buffer (Events.get_pos ev) ev.ev_module in
            (snd (start_and_cnum buffer ev.ev_loc.Location.loc_start)),
            (snd (start_and_cnum buffer ev.ev_loc.Location.loc_end))
          with _ ->
            ev.ev_loc.Location.loc_start.Lexing.pos_cnum,
            ev.ev_loc.Location.loc_end.Lexing.pos_cnum in
        Printf.printf
           "%10d %6d-%-6d  %10s %10s\n"
           ev.ev_pos
           start_char
           end_char
           ((match ev.ev_kind with
               Event_before   -> "before"
             | Event_after _  -> "after"
             | Event_pseudo   -> "pseudo")
            ^
            (match ev.ev_info with
               Event_function -> "/fun"
             | Event_return _ -> "/ret"
             | Event_other    -> ""))
           (match ev.ev_repr with
              Event_none        -> ""
            | Event_parent _    -> "(repr)"
            | Event_child repr  -> string_of_int !repr))
      (events_in_module mdle)

(** User-defined printers **)

let instr_load_printer ppf lexbuf =
  let filename = extract_filename(argument_eol argument lexbuf) in
  try
    Loadprinter.loadfile ppf filename
  with Loadprinter.Error e ->
    Loadprinter.report_error ppf e; raise Toplevel

let instr_install_printer ppf lexbuf =
  let lid = longident_eol Lexer.lexeme lexbuf in
  try
    Loadprinter.install_printer ppf lid
  with Loadprinter.Error e ->
    Loadprinter.report_error ppf e; raise Toplevel

let instr_remove_printer ppf lexbuf =
  let lid = longident_eol Lexer.lexeme lexbuf in
  try
    Loadprinter.remove_printer lid
  with Loadprinter.Error e ->
    Loadprinter.report_error ppf e; raise Toplevel

(** Initialization. **)
let init ppf =
  instruction_list := [
     { instr_name = "cd"; instr_prio = false;
       instr_action = instr_cd; instr_repeat = true; instr_help =
"set working directory to DIR for debugger and program being debugged." };
     { instr_name = "complete"; instr_prio = false;
       instr_action = instr_complete; instr_repeat = false; instr_help =
"complete word at cursor according to context. Useful for Emacs." };
     { instr_name = "pwd"; instr_prio = false;
       instr_action = instr_pwd; instr_repeat = true; instr_help =
"print working directory." };
     { instr_name = "directory"; instr_prio = false;
       instr_action = instr_dir; instr_repeat = false; instr_help =
"add directory DIR to beginning of search path for source and\n\
interface files.\n\
Forget cached info on source file locations and line positions.\n\
With no argument, reset the search path." };
     { instr_name = "kill"; instr_prio = false;
       instr_action = instr_kill; instr_repeat = true; instr_help =
"kill the program being debugged." };
     { instr_name = "help"; instr_prio = false;
       instr_action = instr_help; instr_repeat = true; instr_help =
"print list of commands." };
     { instr_name = "quit"; instr_prio = false;
       instr_action = instr_quit; instr_repeat = false; instr_help =
"exit the debugger." };
     { instr_name = "shell"; instr_prio = false;
       instr_action = instr_shell; instr_repeat = true; instr_help =
"Execute a given COMMAND thru the system shell." };
     { instr_name = "environment"; instr_prio = false;
       instr_action = instr_env; instr_repeat = false; instr_help =
"environment variable to give to program being debugged when it is started." };
      (* Displacements *)
     { instr_name = "run"; instr_prio = true;
       instr_action = instr_run; instr_repeat = true; instr_help =
"run the program from current position." };
     { instr_name = "reverse"; instr_prio = false;
       instr_action = instr_reverse; instr_repeat = true; instr_help =
"run the program backward from current position." };
     { instr_name = "step"; instr_prio = true;
       instr_action = instr_step; instr_repeat = true; instr_help =
"step program until it reaches the next event.\n\
Argument N means do this N times (or till program stops for another reason)." };
     { instr_name = "backstep"; instr_prio = true;
       instr_action = instr_back; instr_repeat = true; instr_help =
"step program backward until it reaches the previous event.\n\
Argument N means do this N times (or till program stops for another reason)." };
     { instr_name = "goto"; instr_prio = false;
       instr_action = instr_goto; instr_repeat = true; instr_help =
"go to the given time." };
     { instr_name = "finish"; instr_prio = true;
       instr_action = instr_finish; instr_repeat = true; instr_help =
"execute until topmost stack frame returns." };
     { instr_name = "next"; instr_prio = true;
       instr_action = instr_next; instr_repeat = true; instr_help =
"step program until it reaches the next event.\n\
Skip over function calls.\n\
Argument N means do this N times (or till program stops for another reason)." };
     { instr_name = "start"; instr_prio = false;
       instr_action = instr_start; instr_repeat = true; instr_help =
"execute backward until the current function is exited." };
     { instr_name = "previous"; instr_prio = false;
       instr_action = instr_previous; instr_repeat = true; instr_help =
"step program until it reaches the previous event.\n\
Skip over function calls.\n\
Argument N means do this N times (or till program stops for another reason)." };
     { instr_name = "print"; instr_prio = true;
       instr_action = instr_print; instr_repeat = true; instr_help =
"print value of expressions (deep printing)." };
     { instr_name = "display"; instr_prio = true;
       instr_action = instr_display; instr_repeat = true; instr_help =
"print value of expressions (shallow printing)." };
     { instr_name = "source"; instr_prio = false;
       instr_action = instr_source; instr_repeat = true; instr_help =
"read command from file FILE." };
     (* Breakpoints *)
     { instr_name = "break"; instr_prio = false;
       instr_action = instr_break; instr_repeat = false; instr_help =
"Set breakpoint at specified line or function.\
\nSyntax: break function-name\
\n        break @ [module] linenum\
\n        break @ [module] # characternum" };
     { instr_name = "delete"; instr_prio = false;
       instr_action = instr_delete; instr_repeat = false; instr_help =
"delete some breakpoints.\n\
Arguments are breakpoint numbers with spaces in between.\n\
To delete all breakpoints, give no argument." };
     { instr_name = "set"; instr_prio = false;
       instr_action = instr_set; instr_repeat = false; instr_help =
"--unused--" };
     { instr_name = "show"; instr_prio = false;
       instr_action = instr_show; instr_repeat = true; instr_help =
"--unused--" };
     { instr_name = "info"; instr_prio = false;
       instr_action = instr_info; instr_repeat = true; instr_help =
"--unused--" };
     (* Frames *)
     { instr_name = "frame"; instr_prio = false;
       instr_action = instr_frame; instr_repeat = true; instr_help =
"select and print a stack frame.\n\
With no argument, print the selected stack frame.\n\
An argument specifies the frame to select." };
     { instr_name = "backtrace"; instr_prio = false;
       instr_action = instr_backtrace; instr_repeat = true; instr_help =
"print backtrace of all stack frames, or innermost COUNT frames.\n\
With a negative argument, print outermost -COUNT frames." };
     { instr_name = "bt"; instr_prio = false;
       instr_action = instr_backtrace; instr_repeat = true; instr_help =
"print backtrace of all stack frames, or innermost COUNT frames.\n\
With a negative argument, print outermost -COUNT frames." };
     { instr_name = "up"; instr_prio = false;
       instr_action = instr_up; instr_repeat = true; instr_help =
"select and print stack frame that called this one.\n\
An argument says how many frames up to go." };
     { instr_name = "down"; instr_prio = false;
       instr_action = instr_down; instr_repeat = true; instr_help =
"select and print stack frame called by this one.\n\
An argument says how many frames down to go." };
     { instr_name = "last"; instr_prio = true;
       instr_action = instr_last; instr_repeat = true; instr_help =
"go back to previous time." };
     { instr_name = "list"; instr_prio = false;
       instr_action = instr_list; instr_repeat = true; instr_help =
"list the source code." };
     (* User-defined printers *)
     { instr_name = "load_printer"; instr_prio = false;
       instr_action = instr_load_printer; instr_repeat = false; instr_help =
"load in the debugger a .cmo or .cma file containing printing functions." };
     { instr_name = "install_printer"; instr_prio = false;
       instr_action = instr_install_printer; instr_repeat = false; instr_help =
"use the given function for printing values of its input type.\n\
The code for the function must have previously been loaded in the debugger\n\
using \"load_printer\"." };
     { instr_name = "remove_printer"; instr_prio = false;
       instr_action = instr_remove_printer; instr_repeat = false; instr_help =
"stop using the given function for printing values of its input type." }
];
  variable_list := [
    (* variable name, (writing, reading), help reading, help writing *)
     { var_name = "arguments";
       var_action = raw_line_variable true arguments;
       var_help =
"arguments to give program being debugged when it is started." };
     { var_name = "program";
       var_action = path_variable true program_name;
       var_help =
"name of program to be debugged." };
     { var_name = "loadingmode";
       var_action = loading_mode_variable ppf;
       var_help =
"mode of loading.\n\
It can be either :\n\
  direct : the program is directly called by the debugger.\n\
  runtime : the debugger execute `ocamlrun programname arguments'.\n\
  manual : the program is not launched by the debugger,\n\
    but manually by the user." };
     { var_name = "processcount";
       var_action = integer_variable false 1 "Must be >= 1."
                                     checkpoint_max_count;
       var_help =
"maximum number of process to keep." };
     { var_name = "checkpoints";
       var_action = boolean_variable false make_checkpoints;
       var_help =
"whether to make checkpoints or not." };
     { var_name = "bigstep";
       var_action = int64_variable false _1 "Must be >= 1."
                                     checkpoint_big_step;
       var_help =
"step between checkpoints during long displacements." };
     { var_name = "smallstep";
       var_action = int64_variable false _1 "Must be >= 1."
                                     checkpoint_small_step;
       var_help =
"step between checkpoints during small displacements." };
     { var_name = "socket";
       var_action = raw_variable true socket_name;
       var_help =
"name of the socket used by communications debugger-runtime." };
     { var_name = "history";
       var_action = integer_variable false 0 "" history_size;
       var_help =
"history size." };
     { var_name = "print_depth";
       var_action = integer_variable false 1 "Must be at least 1"
                                     max_printer_depth;
       var_help =
"maximal depth for printing of values." };
     { var_name = "print_length";
       var_action = integer_variable false 1 "Must be at least 1"
                                     max_printer_steps;
       var_help =
"maximal number of value nodes printed." };
     { var_name = "follow_fork_mode";
       var_action = follow_fork_variable;
       var_help =
"process to follow after forking.\n\
It can be either :
  child : the newly created process.\n\
  parent : the process that called fork.\n" }];

  info_list :=
    (* info name, function, help *)
    [{ info_name = "modules";
       info_action = info_modules ppf;
       info_help = "list opened modules." };
     { info_name = "checkpoints";
       info_action = info_checkpoints ppf;
       info_help = "list checkpoints." };
     { info_name = "breakpoints";
       info_action = info_breakpoints ppf;
       info_help = "list breakpoints." };
     { info_name = "events";
       info_action = info_events ppf;
       info_help = "list events in MODULE (default is current module)." }]

let _ = init std_formatter