path: root/gdb/gdbtk/library/regwin.itb

# Register display window for GDBtk.
# Copyright 1998, 1999 Cygnus Solutions
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License (GPL) as published by
# the Free Software Foundation; either version 2 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# ------------------------------------------------------------------
#  CONSTRUCTOR - create new register window
# ------------------------------------------------------------------
body RegWin::constructor {args} {
  global tixOption
  debug "RegWin::constructor"
  wm withdraw [winfo toplevel $itk_interior]
  gdbtk_busy
  
  set NormalForeground $tixOption(fg)
  set HighlightForeground [pref get gdb/reg/highlight_fg]
  
  if {[pref getd gdb/reg/menu] != ""} {
    set mbar 0
  }
  
  init_reg_display_vars 1
  build_win
  eval itk_initialize $args    
  
  gdbtk_idle
  add_hook gdb_update_hook "$this update"
  add_hook gdb_busy_hook [list $this busy]
  add_hook gdb_idle_hook [list $this idle]
  if {[get_disassembly_flavor] != ""} {
    add_hook gdb_set_hook [code $this handle_set_hook]
  }
}

# ------------------------------------------------------------------
#  DESTRUCTOR - destroy window containing widget
# ------------------------------------------------------------------
body RegWin::destructor {} {
  debug "RegWin::destructor"
  save_reg_display_vars
  remove_hook gdb_update_hook "$this update"
  remove_hook gdb_busy_hook [list $this busy]
  remove_hook gdb_idle_hook [list $this idle]
  if {[get_disassembly_flavor] != ""} {
    remove_hook gdb_set_hook [code $this handle_set_hook]
  }
}
  

# ------------------------------------------------------------------
#  METHOD:  build_win - build the main register window
# ------------------------------------------------------------------
body RegWin::build_win {} {
  global reg_display tixOption tcl_platform
  
  set dim [dimensions]
  set nRows [lindex $dim 0]
  set nCols [lindex $dim 1]
  if {$tcl_platform(platform) == "windows"} {
    tixScrolledWindow $itk_interior.scrolled -scrollbar both -sizebox 1
  } else {
    tixScrolledWindow $itk_interior.scrolled -scrollbar auto
  }
  set ScrolledWin [$itk_interior.scrolled subwidget window]
  
  # Calculate the maximum length of a register name
  set regMaxLen 0
  foreach r [gdb_regnames] {
    set l [string length $r]
    if {$l > $regMaxLen} {
      set regMaxLen $l
    }
  }
  
  # Calculate the minimum size for each column so that the register values fit.
  set row 0
  set col 0
  foreach r $reg_display_list {
    if {$row == 0} {
      # A minimum of 10 so the appearence is nice
      set vmax($col) 10
    }

    # Typed registers natural values start with a brace (escaped by a slash)
    if {[catch {gdb_fetch_registers {} $r} valtest]} {
      set values($r) ""
    } else {
      if {[string index $valtest 1] == "\{"} {
        # If it is a typed register, we print it raw
        set format r
        set reg_display($r,format) r
        set reg_display($r,typed) 1
        set reg_display($r,editable) 0
      } else {
        set format $reg_display($r,format)
        set reg_display($r,editable) 1
      }
      if {[catch {gdb_fetch_registers $format $r} values($r)]} {
        set values($r) ""
      } else {
        set values($r) [string trim $values($r) \ ]
      }
    }

    set l [string length $values($r)]
    if {$l > $vmax($col)} {
      set vmax($col) $l
    }
    incr row
    if {$row == $nRows} {
      set row 0
      incr col
    }
  }
  
  # Create labels
  set row 0
  set col 0
  foreach r $reg_display_list {
    if {$row == $nRows} {
      grid columnconfigure $ScrolledWin $col -weight 1
      set row 0
      incr col
    }
    
    frame $ScrolledWin.$r -takefocus 1
    bind $ScrolledWin.$r <Up> "$this reg_select_up"
    bind $ScrolledWin.$r <Down> "$this reg_select_down"
    bind $ScrolledWin.$r <Tab> "$this reg_select_down"
    bind $ScrolledWin.$r <Left> "$this reg_select_left"
    bind $ScrolledWin.$r <Right> "$this reg_select_right"
    if {![pref get gdb/mode]} {
      bind $ScrolledWin.$r <Return> "$this edit $r"
    }
    
    label $ScrolledWin.$r.lbl -text [fixLength $reg_display($r,name) $regMaxLen left] \
      -relief solid -bd 1 -font src-font 
    label $ScrolledWin.$r.val -anchor e -text [fixLength $values($r) $vmax($col) right] \
      -relief ridge -bd 1 -font src-font -bg $tixOption(input1_bg)
    
    grid $ScrolledWin.$r.lbl $ScrolledWin.$r.val -sticky nsew
    grid columnconfigure $ScrolledWin.$r 1 -weight 1
    grid $ScrolledWin.$r -colum $col -row $row -sticky nsew
    #      grid rowconfigure $ScrolledWin $row -weight 1
    bind $ScrolledWin.$r.val <1> "$this reg_select $r"
    bind $ScrolledWin.$r.lbl <1> "$this reg_select $r"
    bind $ScrolledWin.$r.val <3> "$this but3 $r %X %Y"
    bind $ScrolledWin.$r.lbl <3> "$this but3 $r %X %Y"
    if {![pref get gdb/mode]} {
      bind $ScrolledWin.$r.lbl <Double-1> "$this edit $r"
      bind $ScrolledWin.$r.val <Double-1> "$this edit $r"
    }
    incr row
  }
  grid columnconfigure $ScrolledWin $col -weight 1
  
  
  if { $mbar } {
    menu $itk_interior.m -tearoff 0
    [winfo toplevel $itk_interior] configure -menu $itk_interior.m
    $itk_interior.m add cascade -menu $itk_interior.m.reg -label "Register" -underline 0
    set m [menu $itk_interior.m.reg]
    if {![pref get gdb/mode]} {
      $m add command -label "Edit" -underline 0 -state disabled
    }
    $m add cascade -menu $itk_interior.m.reg.format -label "Format" -underline 0
    set f [menu $itk_interior.m.reg.format]
    $f add radio -label "Hex" -value x -underline 0 -state disabled \
      -command "$this update"
    $f add radio -label "Decimal" -value d -underline 0 -state disabled \
      -command "$this update"
    $f add radio -label "Natural" -value {} -underline 0 -state disabled \
      -command "$this update"
    $f add radio -label "Binary" -value t -underline 0 -state disabled \
      -command "$this update"
    $f add radio -label "Octal" -value o -underline 0 -state disabled \
      -command "$this update"
    $f add radio -label "Raw" -value r -underline 0 -state disabled \
      -command "$this update"
    $m add command -label "Remove from Display" -underline 0 -state disabled
    $m add separator
    $m add command -label "Add to Watch" -underline 7 -state disabled
    $m add separator
    $m add command -label "Display All Registers" -underline 0 -state disabled \
			      -command "$this display_all"
    set disp_all_menu_item [$m index last]

    if {!$all_regs_shown} {
      $m entryconfigure $disp_all_menu_item -state normal
    }
  }
  
  set Menu [menu $ScrolledWin.pop -tearoff 0]
  set disabled_fg [$Menu cget -fg]
  $Menu configure -disabledforeground $disabled_fg
  
  # Clear gdb's changed list
  catch {gdb_changed_register_list}
  
  pack $itk_interior.scrolled -anchor nw -fill both -expand yes
  
  window_name "Registers" "Regs"
}

# ------------------------------------------------------------------------------
# NAME: init_reg_display_vars
# DESC: Initialize the list of registers displayed.
#	args - not used
# RETURNS:
# NOTES:
# ------------------------------------------------------------------------------
body RegWin::init_reg_display_vars {args} {
  global reg_display max_regs
  set reg_display_list {}
  set regnames [gdb_regnames -numbers]

  set i 1
  set x 0
  foreach r $regnames {
    incr x
    set name [lindex $r 0]
    set rn   [lindex $r 1]
    set reg_display($rn,name) $name

    # All registers shall be considered editable
    # and non-typed until proved otherwise
    set reg_display($rn,typed) 0
    set reg_display($rn,editable) 0

    # If user has no preference, show register in hex (if we can)
    set format [pref getd gdb/reg/$name-format]
    if {$format == ""} { set format x }
    set reg_display($rn,format) $format

    # Check if the user prefers not to show this register
    if {$args != "" && [pref getd gdb/reg/$name] == "no"} {
      set all_regs_shown 0
      set reg_display($rn,line) 0
    } else {
      set reg_display($rn,line) $i
      lappend reg_display_list $rn
      incr i
    }
  }

  set num_regs [expr {$i - 1}]
  set max_regs $x
  set reg_names_dirty 0
}

body RegWin::handle_set_hook {var value} {
  switch $var {
    disassembly-flavor {
        disassembly_changed
    } 
  }
}

body RegWin::disassembly_changed {} {
  set reg_names_dirty 1
}
# ------------------------------------------------------------------------------
# NAME: save_reg_display_vars
# DESC: save the list of displayed registers to the preferences file.
# ------------------------------------------------------------------------------
body RegWin::save_reg_display_vars {} {
  global reg_display max_regs
  set regnames [gdb_regnames -numbers]
  foreach r $regnames {
    set rn   [lindex $r 1]
    set name $reg_display($rn,name)
    if {$reg_display($rn,line) == 0} {
      pref setd gdb/reg/$name no
      } else {
	pref setd gdb/reg/$name {}
      }
    if {$reg_display($rn,format) != "x"} {
      pref setd gdb/reg/$name-format $reg_display($rn,format)
    } else {
      pref setd gdb/reg/$name-format {}
    }
  }
  pref_save ""
}

# ------------------------------------------------------------------
#  PUBLIC METHOD:  reg_select_up
# ------------------------------------------------------------------
body RegWin::reg_select_up { } {
  if { $selected == -1 || $Running} {
    return
  }
  set current_index [lsearch -exact $reg_display_list $selected]
  set new_reg [lindex $reg_display_list [expr {$current_index - 1}]]
  if { $new_reg != {} } {
    $this reg_select $new_reg
  }
}

# ------------------------------------------------------------------
#  PUBLIC METHOD:  reg_select_down
# ------------------------------------------------------------------
body RegWin::reg_select_down { } {
  if { $selected == -1 || $Running} {
    return
  }
  set current_index [lsearch -exact $reg_display_list $selected]
  set new_reg [lindex $reg_display_list [expr {$current_index + 1}]]
  if { $new_reg != {} } {
      $this reg_select $new_reg
  }
}

# ------------------------------------------------------------------
#  PUBLIC METHOD:  reg_select_right
# ------------------------------------------------------------------
body RegWin::reg_select_right { } {
  if { $selected == -1 || $Running} {
    return
  }
  set current_index [lsearch -exact $reg_display_list $selected]
  set new_reg [lindex $reg_display_list [expr {$current_index + $nRows}]]
  if { $new_reg != {} } {
    $this reg_select $new_reg
  }
}

# ------------------------------------------------------------------
#  PUBLIC METHOD:  reg_select_left
# ------------------------------------------------------------------
body RegWin::reg_select_left { } {
  if { $selected == -1 || $Running} {
    return
  }
  set current_index [lsearch -exact $reg_display_list $selected]
  set new_reg [lindex $reg_display_list [expr {$current_index - $nRows}]]
  if { $new_reg != {} } {
    $this reg_select $new_reg
  }
}

# ------------------------------------------------------------------
#  PUBLIC METHOD:  reg_select - select a register
# ------------------------------------------------------------------
body RegWin::reg_select { r } {
  global reg_display tixOption 
  
  if {$Running} { return }
  if {$selected != -1} {
    catch {$ScrolledWin.$selected.lbl configure -fg $tixOption(fg) -bg $tixOption(bg)}
    catch {$ScrolledWin.$selected.val configure -fg $tixOption(fg) \
	     -bg $tixOption(input1_bg)}
  }
  
  # if we click on the same line, unselect it and return
  if {$selected == $r} {
    set selected -1
    $itk_interior.m.reg entryconfigure 0 -state disabled
    $itk_interior.m.reg entryconfigure 2 -state disabled
    for {set i 0} {$i < 6} {incr i} {
      $itk_interior.m.reg.format entryconfigure $i -state disabled
    }
    return
  }
  
  if {$Editing != -1} {
    unedit
  }
  
  $ScrolledWin.$r.lbl configure -fg $tixOption(select_fg) -bg $tixOption(select_bg)
  $ScrolledWin.$r.val configure -fg $tixOption(fg) -bg $tixOption(bg)
  
  if {![pref get gdb/mode] && $reg_display($r,editable)} {
    $itk_interior.m.reg entryconfigure 0 -state normal -command "$this edit $r"
  }
  $itk_interior.m.reg entryconfigure 2 -state normal \
    -command "$this delete_from_display_list $r"
  if {$reg_display($r,typed)} {
    set state disabled
  } else {
    set state normal
  }
  for {set i 0} {$i < 6} {incr i} {
    debug "RegWin format $i $state"
    $itk_interior.m.reg.format entryconfigure $i -state $state \
      -variable reg_display($r,format)
  }
  $itk_interior.m.reg entryconfigure 4 -state normal \
    -command "$this addToWatch $r"
  focus -force $ScrolledWin.$r
  set selected $r
}

# ------------------------------------------------------------------
# PRIVATE METHOD:  dimensions - determine square-like dimensions for
#          register window
# ------------------------------------------------------------------
body RegWin::dimensions {} {
  set rows [pref get gdb/reg/rows]
  #    set rows [expr int(floor(sqrt($num_regs)))]
  set cols [expr {int(ceil(sqrt($num_regs)))}]
  
  return [list $rows $cols]
}

# ------------------------------------------------------------------------------
# NAME: 
#	private method RegWin::fixLength
#
# SYNOPSIS:
#	fixLength {s size where}
#	
# DESC: 
#	Makes a string into a fixed-length string, inserting spaces as
#	necessary. If 'where' is "left" spaces will be added to the left,
#	if 'where' is "right" spaces will be added to the right.
# ARGS:
#	s - input string
#	size - size of string to output
#	where - "left" or "right"
#
# RETURNS: 
#	Padded string of length 'size'
#
# NOTES: 
#	This should really be a proc, not a method.
# ------------------------------------------------------------------------------
body RegWin::fixLength {s size where} {
  set blank "                                                                   "
  set len [string length $s]
  set bl  [expr {$size - $len}]
  set b [string range $blank 0 $bl]
  
  switch $where {
    left  { set fl "$s$b"}
    right { set fl "$b$s"}
  }
  return $fl
}

# ------------------------------------------------------------------
#  PUBLIC METHOD:  but3 - generate and display a popup window on button 3 
#  over the register value
# ------------------------------------------------------------------
body RegWin::but3 {rn X Y} {
  global reg_display max_regs
  
  if {!$Running} {
    $Menu delete 0 end
    $Menu add command -label $reg_display($rn,name) -state disabled
    $Menu add separator
    if {!$reg_display($rn,typed)} {
      $Menu add radio -label "Hex" -command "$this update" \
        -value x -variable reg_display($rn,format)
      $Menu add radio -label "Decimal" -command "$this update" \
        -value d -variable reg_display($rn,format)
      $Menu add radio -label "Natural" -command "$this update" \
        -value {} -variable reg_display($rn,format)
      $Menu add radio -label "Binary" -command "$this update" \
        -value t -variable reg_display($rn,format) -underline 0
      $Menu add radio -label "Octal" -command "$this update" \
        -value o -variable reg_display($rn,format)
      $Menu add radio -label "Raw" -command "$this update" \
        -value r -variable reg_display($rn,format)
      $Menu add separator
    }
    $Menu add command  -command "$this addToWatch $rn" \
      -label "Add $reg_display($rn,name) to Watch"
    $Menu add separator
    $Menu add command  -command "$this delete_from_display_list $rn" \
      -label "Remove $reg_display($rn,name) from Display"
    if {$max_regs != $num_regs} {
      $Menu add separator
      $Menu add command -command "$this display_all" \
	-label "Display all registers"
    }
    tk_popup $Menu $X $Y
  }
}

# ------------------------------------------------------------------
#  PUBLIC METHOD:  display_all - add all registers to the display list
# ------------------------------------------------------------------
body RegWin::display_all {} {
  init_reg_display_vars
  $itk_interior.m.reg entryconfigure $disp_all_menu_item -state disabled
  set all_regs_shown 1
  reconfig
}

# ------------------------------------------------------------------
#  PUBLIC METHOD:  delete_from_display_list - remove a register from the
#  display list
# ------------------------------------------------------------------
body RegWin::delete_from_display_list {rn} {
  global reg_display max_regs
  set reg_display($rn,line) 0
  set reg_display_list {}
  set regnames [gdb_regnames -numbers]
  set i 0
  foreach r $regnames {
    set rnx [lindex $r 1]
    if {$reg_display($rnx,line) > 0} {
      lappend reg_display_list $rnx
      incr i
      set reg_display($rnx,line) $i
    }
  }
  set num_regs $i
  reconfig
  $itk_interior.m.reg entryconfigure 6 -state normal
}



# ------------------------------------------------------------------
#  PUBLIC METHOD:  edit - edit a cell
# ------------------------------------------------------------------
body RegWin::edit {r} {
  global reg_display
  if {$Running} { return }
  if {!$reg_display($r,editable)} {return}
  unedit
  
  set Editing $r
  set txt [$ScrolledWin.$r.val cget -text]
  set len [string length $txt]
  set entry [entry $ScrolledWin.$r.ent -width $len -bd 0 -font src-font]
  $entry insert 0 $txt
  
  grid remove $ScrolledWin.$r.val
  grid $entry -row 0 -col 1
  bind $entry <Return> "$this acceptEdit $r"
  bind $entry <Escape> "$this unedit"
  $entry selection to end
  focus $entry    
}

# ------------------------------------------------------------------
# PUBLIC METHOD:  acceptEdit - callback invoked when enter key pressed
#          in an editing entry
# ------------------------------------------------------------------
body RegWin::acceptEdit {r} {
  global reg_display
  
  set value [string trimleft [$ScrolledWin.$r.ent get]]
  debug "value=${value}="
  if {$value == ""} {
    set value 0
  }
  if {[catch {gdb_cmd "set \$$reg_display($r,name)=$value"} result]} {
    tk_messageBox -icon error -type ok -message $result \
      -title "Error in Expression" -parent [winfo toplevel $itk_interior]
    focus $ScrolledWin.$r.ent
    $ScrolledWin.$r.ent selection to end
  } else {
    unedit
    gdbtk_update
  }
}

# ------------------------------------------------------------------
# PUBLIC METHOD:  addToWatch - add a register to the watch window
# ------------------------------------------------------------------
body RegWin::addToWatch {reg} {
  global reg_display
  [ManagedWin::open WatchWin] add "\$$reg_display($reg,name)"
}

# ------------------------------------------------------------------
# PUBLIC METHOD:  unedit - clear any editing entry on the screen
# ------------------------------------------------------------------
body RegWin::unedit {} {
  if {$Editing != -1} {
    destroy $ScrolledWin.$Editing.ent
    
    # Fill the entry with the old label, updating value
    grid $ScrolledWin.$Editing.val -column 1 -row 0
    focus -force $ScrolledWin.$Editing
    set Editing -1
    update
  }
}

# ------------------------------------------------------------------
#  PRIVATE METHOD:  update - update widget when PC changes
# ------------------------------------------------------------------
body RegWin::update {} {
  global reg_display
  debug "START REGISTER UPDATE CALLBACK"
  if {$reg_display_list == ""
      || [catch {eval gdb_changed_register_list $reg_display_list} changed_reg_list]} {
    set changed_reg_list {}
  }
  
  set row 0
  set col 0
  foreach r $reg_display_list {
    if {$row == 0} {
      # A minimum of 10 so the appearence is nice
      set vmax($col) 10
    }

    # Typed registers natural values start with a brace (escaped by a slash)
    if {[catch {gdb_fetch_registers {} $r} valtest]} {
      set values($r) ""
    } else {
      if {[string index $valtest 1] == "\{"} {
        # If it is a typed register, we print it raw
        set format r
        set reg_display($r,format) r
        set reg_display($r,typed) 1
        set reg_display($r,editable) 0
      } else {
        set format $reg_display($r,format)
        set reg_display($r,editable) 1
      }
      if {[catch {gdb_fetch_registers $format $r} values($r)]} {
        set values($r) ""
      } else {
        set values($r) [string trim $values($r) \ ]
      }
    }

    set l [string length $values($r)]
    if {$l > $vmax($col)} {
      set vmax($col) $l
    }
    incr row
    if {$row == $nRows} {
      set row 0
      incr col
    }
  }
  
  set row 0
  set col 0
  foreach r $reg_display_list {
    if {[lsearch -exact $changed_reg_list $r] != -1} {
      set fg $HighlightForeground
    } else {
      set fg $NormalForeground
    }
    $ScrolledWin.$r.val configure -text [fixLength $values($r) $vmax($col) right] \
      -fg $fg
    incr row
    if {$row == $nRows} {
      set row 0
      incr col
    }
  }
  debug "END REGISTER UPDATE CALLBACK" 
}

body RegWin::idle {} {
  [winfo toplevel $itk_interior] configure -cursor {}
  set Running 0
}

# ------------------------------------------------------------------
#  PRIVATE METHOD:  reconfig - used when preferences change
# ------------------------------------------------------------------
body RegWin::reconfig {} {
  if {$reg_names_dirty} {
    init_reg_display_vars
  }
  destroy $Menu $itk_interior.g $itk_interior.scrolled $itk_interior.m
  gdbtk_busy
  build_win
  gdbtk_idle
}
  
# ------------------------------------------------------------------
#  PRIVATE METHOD:  busy - gdb_busy_hook
# ------------------------------------------------------------------
body RegWin::busy {} {
  # Cancel edits
  unedit
  
  # Fencepost
  set Running 1
  
  # cursor
  [winfo toplevel $itk_interior] configure -cursor watch
}