################################################################################
#
# gdb_help.tcl -- find out which commands gdb understands and build the help
#                 facility and the command completor for tgdb from that info
#
# (c) 1994 HighTec EDV-Systeme GmbH
#          Neue Bahnhofstr. 71
#          66386 St.Ingbert, Germany
#          Email: tgdb@HighTec.saarlink.de
#
# *** ALL RIGHTS RESERVED ***
#
################################################################################

################################################################################
#
# check which arguments are passed to gdb and build appropriate gdb_argv vector;
# we're mainly interested in core-file and attach commands, since they cause
# phase problems if they were passed directly (since gdb tells tgdb to load
# the source file corresponding to the PC contained in the core file, which
# requires that the tgdb/gdb interface is already established - which it ain't
# at that time for it is just being built...)
#
################################################################################
proc process_gdb_args {} {
  global argv gdb_argv gdb_execfile gdb_symfile gdb_corefile
  global gdb_cmdfile gdb_attach_pid std_out gdb_nx

  set gdb_argv ""
  set gdb_execfile ""
  set gdb_corefile ""
  set gdb_symfile ""
  set gdb_cmdfile ""
  set gdb_attach_pid ""
  set gdb_nx 0

  set i 0
  set fileargno 0
  # these gdb commandline args take an additional parameter:
  set cmds "core exec se symbols command tty directory b cd"
  while { 1 } {
    if { [cequal [set arg [lindex $argv $i]] ""] } break
    if { [cequal $arg --] } {
      incr i
      continue
    }
    if { ![cequal [cindex $arg 0] "-"] } {
      if { $fileargno == 0 } {
	set gdb_execfile $arg
	set gdb_symfile $arg
	lappend gdb_argv $arg
      } elseif { $fileargno == 1 } {
	if { [ctype digit $arg] } {
	  set gdb_attach_pid $arg
	} else {
	  set gdb_corefile $arg
	}
      } else {
	lappend gdb_argv $arg
      }
      incr fileargno
    } else {
      if { [cequal [cindex $arg 1] "-"] } {
	set arg [crange $arg 2 end]
      } else {
	set arg [crange $arg 1 end]
      }
      if { [regexp {(.*)=(.*)} $arg {} cmd arg] } {
        set opts [lmatch $cmds "$cmd*"]
	if { [llength $opts] == 0 } {
	  lappend gdb_args "-$arg"
	  incr i
	  continue
	} elseif { [llength $opts] > 1 } {
	  puts $std_out "gdb: option \`[lindex $argv $i]\' is ambiguous:"
	  puts $std_out "     \"[join $opts ", "]\""
	  exit 1
	}
	set cmd $opts
      } else {
	set cmd $arg
	set opts [lmatch $cmds "$cmd*"]
	switch [llength $opts] {
	  0 { lappend gdb_args "-$arg"
	      incr i
	      if { [cequal $arg nx] } {
		set gdb_nx 1
	      }
	      continue
	    }
	  1 { set cmd $opts
	      incr i; while { [cequal [lindex $argv $i] "="] } { incr i }
	      set arg [lindex $argv $i]
	    }
          default {
	      puts $std_out "gdb: option \`[lindex $argv $i]\' is ambiguous:"
	      puts $std_out "     \"[join $opts ", "]\""
	      exit 1
	    }
        }
      }

      if { [cequal $cmd "core"] } {
	set gdb_corefile $arg
      } elseif { [cequal $cmd "exec"] } {
	set gdb_execfile $arg
	append gdb_argv " -exec $arg"
      } elseif { [cequal $cmd "symbols"] } {
	set gdb_symfile $arg
	append gdb_argv " -symbols $arg"
      } elseif { [cequal $cmd "se"] } {
	set gdb_execfile $arg
	set gdb_symfile $arg
	append gdb_argv " -se $arg"
      } elseif { [cequal $cmd "command"] } {
	set gdb_cmdfile $arg
      } else {
	append gdb_argv " -$cmd $arg"
      }
    }
    incr i
  }
  set gdb_argv [string trim $gdb_argv]
}
################################################################################
#
# find gdb commands (this is done recursively). h_cmd is the command we're
# interested in ("" means: all); h_class is the optional class of the cmd.
#
################################################################################
proc find_gdb_cmds { h_cmd h_class } {
  global gdb_cmd gdb_class gdb_hcmd gdb_scmd

  proc find_gdb_cmds0 { h_cmd h_class } {
    global gdb_cmd gdb_class

    set answer [do_dialog "help $h_cmd" silent]
    set sub 0
    foreach line [split $answer "\n"] {
      if { [regexp {(^.*) -- (.*)$} $line {} subcmd] } {
        incr sub
        find_gdb_cmds $subcmd [expr {"$h_class" == "" ? "$subcmd" : "$h_class"}]
      }
    }
    if { ($sub == 0) && ("$h_cmd" != "$h_class") } {
      set gdb_cmd($h_cmd) $answer
      if {   (![cequal $h_class ""]) && (![info exists gdb_class($h_class)]
	  || ([lsearch -exact $gdb_class($h_class) "$h_cmd"] == -1))} {
        lappend gdb_class($h_class) "$h_cmd"
      }
    }
  }

  find_gdb_cmds0 $h_cmd $h_class
  set gdb_hcmd [lsort "[array names gdb_cmd] [array names gdb_class]"]
  set gdb_scmd [lsort [array names gdb_cmd]]
}
################################################################################
#
# display the help window, start with topic (if def'd; may be a cmd or a class)
#
################################################################################
proc show_help { {topic ""} } {
  global gdb_helpmode gdb_class old_focus WinPos WinProc HelpOK

  proc show_help_by_index { {idx "a"} } {
    global gdb_class gdb_cmd gdb_help_index
    
    proc show_help_index { idx } {
      global gdb_cmd

      .help.f3.txt configure -state normal
      .help.f3.txt delete 1.0 end
      .help.f3.txt configure -state disabled
      .help.f2.lb delete 0 end
      set f_letter [string index $idx 0]
      if { $idx == $f_letter } {
        foreach cmdname [lsort [array names gdb_cmd]] {
	  if { [string index $cmdname 0] == $f_letter } {
	    .help.f2.lb insert end $cmdname
	  }
	}
      } else {
        foreach cmdname [lsort [array names gdb_cmd]] {
	  if { [string index $cmdname 0] == $f_letter } {
	    .help.f2.lb insert end $cmdname
	  }
	  if { ![string compare $cmdname $idx] } {
	    .help.f2.lb select clear
	    .help.f2.lb select from end
	    .help.f3.txt configure -state normal
	    .help.f3.txt delete 1.0 end
	    .help.f3.txt insert 1.0 $gdb_cmd($cmdname)
	    .help.f3.txt configure -state disabled
	  }
        }
        if { ![cequal [set selidx [.help.f2.lb curselection]] ""] } {
	  .help.f2.lb yview $selidx
        }
      }
      focus .help
    }

    catch {destroy .help.f1}
    if { $idx == "" } {
      set idx "a"
    }
    set gdb_help_index [string tolower [string index $idx 0]]
    frame .help.f1 -relief raised -border 2
    frame .help.f1.f0
    frame .help.f1.f1
    foreach but "a b c d e f g h i j k l m" {
      radiobutton .help.f1.f0.$but -value $but -variable gdb_help_index \
        -text $but -width 1 -command "show_help_index $but"
      pack .help.f1.f0.$but -side left -fill x -expand 1
    }
    foreach but "n o p q r s t u v w x y z" {
      radiobutton .help.f1.f1.$but -value $but -variable gdb_help_index \
        -text $but -width 1 -command "show_help_index $but"
      pack .help.f1.f1.$but -side left -fill x -expand 1
    }
    pack .help.f1.f0 -side top -fill x -expand 1
    pack .help.f1.f1 -side top -fill x -expand 1
    pack after .help.f0 .help.f1 {fillx expand}
    show_help_index $idx
  }

  proc show_help_by_class { {class ""} } {
    global gdb_class gdb_cmd gdb_help_class
    
    proc show_help_class { class } {
      global gdb_class gdb_cmd

      .help.f3.txt configure -state normal
      .help.f3.txt delete 1.0 end
      .help.f3.txt configure -state disabled
      .help.f2.lb delete 0 end
      foreach cmd [lsort $gdb_class($class)] {
	.help.f2.lb insert end $cmd
      }
      focus .help
    }

    catch {destroy .help.f1}
    if { [lsearch [array names gdb_class] $class] == -1 } {
      set class [lindex [lsort [array names gdb_class]] 0]
    }
    set gdb_help_class $class
	
    frame .help.f1 -relief raised -border 2
    foreach but [lsort [array names gdb_class]] {
      radiobutton .help.f1.$but -value $but -variable gdb_help_class \
	-text $but -command "show_help_class $but" -anchor w
      pack .help.f1.$but -side left -fill x -expand 1
    }
    pack after .help.f0 .help.f1 {top fillx expand}
    show_help_class $class
  }

  if { [winfo exists .help] } {
    set geo [wm geometry .help]
    wm withdraw .help
    wm geometry .help $geo
    wm deiconify .help
    tkwait visibility .help
    raise .help
    focus .help
    return
  }

  set WinProc(.help) show_help
  catch {destroy .help}
  set old_focus(.help) [focus]
  focus none

  if { [clength $topic] != 0 } {
    if { [lsearch -exact [array names gdb_class] $topic] != -1 } {
      set gdb_helpmode "class"
    } else {
      set gdb_helpmode "index"
    }
  }
  if { ![info exists gdb_helpmode] } {
    set gdb_helpmode "index"
  }
  catch {foreach cmd $gdb_class(user) { catch {unset gdb_cmd($cmd)} }}
  catch {unset gdb_class(user)}
  find_gdb_cmds "user" "user"

  toplevel .help
  frame .help.f0 -relief raised -border 2
  radiobutton .help.f0.index -text "Index" -value "index" \
    -variable gdb_helpmode -command {show_help_by_index}
  radiobutton .help.f0.class -text "Class" -value "class" \
    -variable gdb_helpmode -command {show_help_by_class}
  frame .help.f1 -relief raised -border 2
  frame .help.f2 -relief raised -border 2
  listbox .help.f2.lb -yscrollcommand {.help.f2.scr set} -setgrid 1
  scrollbar .help.f2.scr -orient vertical -command {.help.f2.lb yview}
  frame .help.f3 -relief raised -border 2
  text .help.f3.txt -yscrollcommand {.help.f3.scr set} -state disabled \
    -wrap word
  scrollbar .help.f3.scr -orient vertical -command {.help.f3.txt yview}
  frame .help.f4 -relief raised -border 2
  frame .help.f4.f0 -relief sunken -border 1
  button .help.f4.f0.ok -text "  Dismiss  " -relief raised -border 2 \
    -command {set HelpOK 1}

  pack .help.f0.index -side left -fill x -expand 1
  pack .help.f0.class -side left -fill x -expand 1
  pack .help.f0 -side top -fill x
  if { $gdb_helpmode == "index" } {
    show_help_by_index $topic
  } else {
    show_help_by_class $topic
  }
  pack .help.f2.lb -side left -fill both -expand 1
  pack .help.f2.scr -side left -fill y
  pack .help.f2 -side top -fill both
  pack .help.f3.txt -side left -fill both -expand 1
  pack .help.f3.scr -side left -fill y
  pack .help.f3 -side top -fill both -expand 1
  pack .help.f4.f0.ok -fill x -expand 1 -padx 6 -pady 6
  pack .help.f4.f0 -fill x -expand 1 -padx 10 -pady 10
  pack .help.f4 -side top -fill x

  # define bindings

  bind .help <Return> {.help.f4.f0.ok invoke}
  bind .help <KP_Enter> [bind .help <Return>]
  bind .help <Control-c> [bind .help <Return>]

  bind .help.f2.lb <1> {
    %W select clear
    %W select from [%W nearest %y]
    if { [clength [%W curselection]] != 0 } {
      .help.f3.txt configure -state normal
      .help.f3.txt delete 1.0 end
      .help.f3.txt insert 1.0 $gdb_cmd([%W get [%W nearest %y]])
      .help.f3.txt configure -state disabled
    }
  }
  bind .help.f2.lb <B1-Motion> [bind .help.f2.lb <1>]
  bind .help.f2.lb <Shift-1> { }
  bind .help.f2.lb <Shift-B1-Motion> { }

  bind .help.f3.txt <1> { }
  bind .help.f3.txt <Double-1> { }
  bind .help.f3.txt <Triple-1> { }
  bind .help.f3.txt <B1-Motion> { }
  bind .help.f3.txt <Shift-1> { }

  wm title .help "Help on gdb commands"
  if { [catch {wm geometry .help $WinPos(.help)}] } {
    wm geometry .help +150+150
  }
  wm protocol .help WM_DELETE_WINDOW {set HelpOK 1}
  wm protocol .help WM_TAKE_FOCUS {focus .help}
  tkwait visibility .help
  focus .help
  tkwait variable HelpOK
  set WinPos(.help) [wm geometry .help]
  destroy .help
  catch {focus $old_focus(.help)}
  update idletasks
}
################################################################################
#
# initialize help facility: either load ~/.t*_help or talk to gdb directly
#
################################################################################
proc init_gdb_help {} {
  global debugger gdb_cmd gdb_class gdb_hcmd gdb_scmd gdb_cmd_short
  global gdb_dont_repeat

  append fname "~/.t" $debugger "_help"
  if { [file readable $fname] } {
    show_status "Reading \"$fname\"..." steady
    update idletasks
    source $fname
  } else {
    show_status "Creating \"$fname\" (may take a while!)..." steady
    update idletasks
    find_gdb_cmds "" ""
    save_gdb_help
  }
  #
  # define various command aliases and abbreviations
  #
  catch {set gdb_cmd(delete) $gdb_cmd([list delete breakpoints])}
  catch {set gdb_cmd(disable) $gdb_cmd([list disable breakpoints])}
  set gdb_cmd_short(b) break
  set gdb_cmd_short(br) break
  set gdb_cmd_short(bre) break
  set gdb_cmd_short(brea) break
  set gdb_cmd_short(bt) backtrace
  set gdb_cmd_short(c) continue
  set gdb_cmd_short(d) delete
  set gdb_cmd_short(del) delete
  set gdb_cmd_short(dis) disable
  set gdb_cmd_short(disa) disable
  set gdb_cmd_short(do) down
  set gdb_cmd_short(dow) down
  set gdb_cmd_short(f) frame
  set gdb_cmd_short(h) help
  set gdb_cmd_short(i) info
  set gdb_cmd_short([list info f]) "info frame"
  set gdb_cmd_short([list info s]) "info stack"
  set gdb_cmd_short(j) jump
  set gdb_cmd_short(k) kill
  set gdb_cmd_short(l) list
  set gdb_cmd_short(n) next
  set gdb_cmd_short(ni) nexti
  set gdb_cmd_short(p) print
  set gdb_cmd_short(pr) print
  set gdb_cmd_short(q) quit
  set gdb_cmd_short(r) run
  set gdb_cmd_short(s) step
  set gdb_cmd_short(si) stepi
  set gdb_cmd_short(search) forward-search
  set gdb_cmd_short(u) until
  set gdb_cmd_short(where) backtrace
  if { $debugger == "gdb166" } {
    set gdb_cmd(file) "Use FILE as executable and symbol file."
    set gdb_cmd(continue) $gdb_cmd(cont)
    set gdb_cmd([list show history]) $gdb_cmd([list info editing])
    set gdb_cmd([list show commands]) $gdb_cmd([list info editing])
    set gdb_cmd_short([list set pp]) "set prettyprint"
    set gdb_cmd_short(unset) delete
  } else {
    set gdb_cmd_short(fg) continue
    set gdb_cmd_short(mt) maintenance
    set gdb_cmd_short(t) thread
    set gdb_cmd_short([list set p]) "set print"
    set gdb_cmd_short([list set pr]) "set print"
    set gdb_cmd_short([list show p]) "show print"
    set gdb_cmd_short([list show pr]) "show print"
  }
  set gdb_hcmd [lsort "[array names gdb_cmd] [array names gdb_class]"]
  set gdb_scmd [lsort [array names gdb_cmd]]
  #
  # mark some commands as "unrepeatable" from the command line
  #
  set gdb_dont_repeat(quit) 1
  set gdb_dont_repeat(core-file) 1
  set gdb_dont_repeat(exec-file) 1
  set gdb_dont_repeat(symbol-file) 1
  set gdb_dont_repeat(add-symbol-file) 1
  set gdb_dont_repeat(run) 1
  set gdb_dont_repeat(signal) 1
  set gdb_dont_repeat(directory) 1
  set gdb_dont_repeat(attach) 1
  set gdb_dont_repeat(detach) 1
  set gdb_dont_repeat(cd) 1
  set gdb_dont_repeat(display) 1
  set gdb_dont_repeat([list info line]) 1
  set gdb_dont_repeat([list maintenance print symbols]) 1
  set gdb_dont_repeat([list maintenance print psymbols]) 1
  set gdb_dont_repeat([list maintenance print msymbols]) 1
  set gdb_dont_repeat([list maintenance print objfiles]) 1
  set gdb_dont_repeat([list maintenance print type]) 1
  set gdb_dont_repeat([list target remote]) 1
  if { $debugger == "gdb166" } {
    set gdb_dont_repeat(load) 1
    set gdb_dont_repeat(reset) 1
  }

  show_status ""
  update idletasks
}
################################################################################
#
# the name says is all...
#
################################################################################
proc save_gdb_help {} {
  global gdb_cmd gdb_class debugger

  append fname "~/.t" $debugger "_help"
  set desc [open $fname "w"]
  puts $desc "global gdb_class gdb_cmd"
  foreach class [array names gdb_class] {
    puts $desc "set gdb_class(\[list $class\]) \"$gdb_class($class)\""
  }
  foreach cmd [array names gdb_cmd] {
    puts $desc "set gdb_cmd(\[list $cmd\]) \{$gdb_cmd($cmd)\}"
  }
  close $desc
}
################################################################################
#
# the tcl version of gdb's command completion :-)
# cmdline_ptr is the name of a variable containing any command (plus args);
# argline_ptr is the name of a variable that will finally contain the args,
# while $cmdline_ptr will contain the fully expanded command.
# class defaults to cmd, but if specified otherwise, expand_cmd also uses
# class names (such as "running", "data" or "stack") to find the command
# (useful only for the "help" command).
#
################################################################################
proc expand_cmd { cmdline_ptr argline_ptr {class cmd} } {
  upvar $cmdline_ptr cmdline $argline_ptr argline
  global gdb_cmd gdb_scmd gdb_hcmd gdb_cmd_short

  set argline ""
  foreach word [split $cmdline] {
    if { [clength $word] != 0 } {
      lappend words $word
    }
  }
  if { ![info exists words] } {
    return
  }

  set arg(0) [lindex $words 0]
  # see if the command contains a format specification (e.g. "disp/i $pc");
  # if so, separate it from the command so that it appears as an argument
  if { [set pos [string first "/" $arg(0)]] != -1 } {
    lvarpop words
    set words [linsert $words 0 [crange $arg(0) $pos end]]
    set words [linsert $words 0 [crange $arg(0) 0 $pos-1]]
    set cmdline "[crange $cmdline 0 $pos-1] [crange $cmdline $pos end]"
    set arg(0) [lindex $words 0]
  }

  if { [info exists gdb_cmd_short($arg(0))] } {
    set arg(0) $gdb_cmd_short($arg(0))
  }
  if { $class == "cmd" } {
    set pos [lmatch $gdb_scmd "$arg(0)*"]
  } else {
    set pos [lmatch $gdb_hcmd "$arg(0)*"]
  }
  set main [lindex [split [lindex $pos 0] "\{ \t\}"] 0]
  set i 0
  if { [llength $pos] > 0 } {
    # there exist at least 2 commands starting with $main; see if it is a
    # base command (e.g. "enable" as in "{enable breakpoint} {enable display}") 
    if { [llength [lmatch $pos "$main*"]] == [llength $pos] } {
      set words [lreplace $words 0 0 $main]
    } else {
      return
    }
    # and now the funny stuff: try to match all of command's words, starting
    # with the second one (algorithm basically the same as above)...
    for { set i 1 } { 1 } { incr i } {
      if { [clength [lindex $words $i]] == 0 } break
      set arg($i) [join [lrange $words 0 $i]]
      if { [info exists gdb_cmd_short($arg($i))] } {
	set arg($i) $gdb_cmd_short($arg($i))
      }
      foreach word $pos { lappend sub [lrange $word 0 $i] }
      set sub [lrmdups $sub]
      set npos [lmatch $sub "$arg($i)*"]
      if { [llength $npos] == 1 } {
	set subword [lindex [split [lindex $npos 0] "\{ \t\}"] $i]
	set words [lreplace $words $i $i $subword]
	unset sub
      } elseif { [llength [set npos [lmatch -exact $sub $arg($i)]]] == 1 } {
	set subword [lindex [split [lindex $npos 0] "\{ \t\}"] $i]
	set words [lreplace $words $i $i $subword]
	unset sub
      } else break
    }
  }

  # now put arguments into argline and fill cmdline with the completed command
  if { $i > 0 } {
    set argline $cmdline
    set cmdline [join [lrange $words 0 [expr $i - 1]]]
    for { } { $i > 0 } {incr i -1} {
      regsub "(^\[ \t\]*\[^ \t\]*)" $argline "" argline
    }
    set argline [string trim $argline]
  }
}
### EOF ########################################################################
