static int gdb_set_mem (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
static int gdb_immediate_command (ClientData, Tcl_Interp *, int,
Tcl_Obj * CONST[]);
+static int gdb_incr_addr (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
static int gdb_listfiles (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
static int gdb_listfuncs (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
static int gdb_loadfile (ClientData, Tcl_Interp *, int,
Tcl_CreateObjCommand (interp, "gdb_disassemble", gdbtk_call_wrapper,
gdb_disassemble, NULL);
Tcl_CreateObjCommand (interp, "gdb_eval", gdbtk_call_wrapper, gdb_eval, NULL);
+ Tcl_CreateObjCommand (interp, "gdb_incr_addr", gdbtk_call_wrapper, gdb_incr_addr, NULL);
Tcl_CreateObjCommand (interp, "gdb_clear_file", gdbtk_call_wrapper,
gdb_clear_file, NULL);
Tcl_CreateObjCommand (interp, "gdb_confirm_quit", gdbtk_call_wrapper,
*
* Tcl Arguments:
* expression - the expression to evaluate.
+ * format - optional format character. Valid chars are:
+ * o - octal
+ * x - hex
+ * d - decimal
+ * u - unsigned decimal
+ * t - binary
+ * f - float
+ * a - address
+ * c - char
* Tcl Result:
* The result of the evaluation.
*/
static int
-gdb_eval (clientData, interp, objc, objv)
- ClientData clientData;
- Tcl_Interp *interp;
- int objc;
- Tcl_Obj *CONST objv[];
+gdb_eval (ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
{
struct expression *expr;
struct cleanup *old_chain = NULL;
+ int format = 0;
value_ptr val;
- if (objc != 2)
+ if (objc != 2 && objc != 3)
{
- Tcl_WrongNumArgs (interp, 1, objv, "expression");
+ Tcl_WrongNumArgs (interp, 1, objv, "expression [format]");
return TCL_ERROR;
}
- expr = parse_expression (Tcl_GetStringFromObj (objv[1], NULL));
+ if (objc == 3)
+ format = *(Tcl_GetStringFromObj (objv[2], NULL));
+ expr = parse_expression (Tcl_GetStringFromObj (objv[1], NULL));
old_chain = make_cleanup (free_current_contents, &expr);
-
val = evaluate_expression (expr);
/*
val_print (VALUE_TYPE (val), VALUE_CONTENTS (val),
VALUE_EMBEDDED_OFFSET (val), VALUE_ADDRESS (val),
- gdb_stdout, 0, 0, 0, 0);
+ gdb_stdout, format, 0, 0, 0);
do_cleanups (old_chain);
-
return TCL_OK;
}
static int
hex2bin (const char *hex, char *bin, int count)
{
- int i;
- int m, n;
+ int i, m, n;
+ int incr = 2;
- for (i = 0; i < count; i++)
+
+ if (TARGET_BYTE_ORDER == LITTLE_ENDIAN)
+ {
+ /* need to read string in reverse */
+ hex += count - 2;
+ incr = -2;
+ }
+
+ for (i = 0; i < count; i += 2)
{
if (hex[0] == 0 || hex[1] == 0)
{
if (m == -1 || n == -1)
return -1;
*bin++ = m * 16 + n;
- hex += 2;
+ hex += incr;
}
return i;
Tcl_SetObjResult (interp, Tcl_NewStringObj (buf, -1));
xfree(buf);
}
+
+
+/* This implements the tcl command 'gdb_incr_addr'.
+ * It increments addresses, which must be implemented
+ * this way because tcl cannot handle 64-bit values.
+ *
+ * Tcl Arguments:
+ * addr - 32 or 64-bit address
+ * number - optional number to add to the address
+ * default is 1.
+ *
+ * Tcl Result:
+ * addr + number
+ */
+
+static int
+gdb_incr_addr (ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ CORE_ADDR address;
+ int number = 1;
+
+ if (objc != 2 && objc != 3)
+ {
+ Tcl_WrongNumArgs (interp, 1, objv, "address [number]");
+ return TCL_ERROR;
+ }
+
+ address = string_to_core_addr (Tcl_GetStringFromObj (objv[1], NULL));
+
+ if (objc == 3)
+ {
+ if (Tcl_GetIntFromObj (interp, objv[2], &number) != TCL_OK)
+ return TCL_ERROR;
+ }
+
+ address += number;
+
+ Tcl_SetStringObj (result_ptr->obj_ptr, (char *)core_addr_to_string (address), -1);
+
+ return TCL_OK;
+}
-decrement "after idle $this incr_addr 1" \
-validate {} \
-textbackground white
-
$itk_interior.f.cntl delete 0 end
$itk_interior.f.cntl insert end $addr_exp
+ label $itk_interior.f.endian -text "Target is [gdbtk_endian] endian"
+
balloon register [$itk_interior.f.cntl childsite].uparrow \
"Scroll Up (Decrement Address)"
balloon register [$itk_interior.f.cntl childsite].downarrow \
balloon register $itk_interior.f.upd "Update Now"
checkbutton $itk_interior.cb -variable _mem($this,enabled) -command "$this toggle_enabled"
balloon register $itk_interior.cb "Toggles Automatic Display Updates"
- grid $itk_interior.f.upd $itk_interior.f.cntl -sticky ew -padx 5
+ grid $itk_interior.f.upd $itk_interior.f.cntl $itk_interior.f.endian -sticky ew -padx 5
} else {
- grid $itk_interior.f.cntl x -sticky w
+ grid $itk_interior.f.cntl x $itk_interior.f.endian -sticky e
grid columnconfigure $itk_interior.f 1 -weight 1
}
if {$col == $Numcols} {
# editing the ASCII field
- set addr [expr {$current_addr + $bytes_per_row * $row}]
+ set addr [gdb_incr_addr $current_addr + [expr {$bytes_per_row * $row}]]
set start_addr $addr
# calculate number of rows to modify
return
}
}
- incr addr
+ set addr [gdb_incr_addr $addr]
}
set addr $start_addr
set nextval 0
}
set ${this}_memval($row,$col) [lindex $vals $nextval]
incr nextval
- incr addr $bytes_per_row
+ set addr [gdb_incr_addr $addr $bytes_per_row]
incr row
}
return
}
# calculate address based on row and column
- set addr [expr {$current_addr + $bytes_per_row * $row + $size * $col}]
- #debug " edit $row,$col [format "%x" $addr] = $val"
+ set addr [gdb_incr_addr $current_addr [expr {$bytes_per_row * $row + $size * $col}]]
+ #debug " edit $row,$col $addr = $val"
# Pad the value with zeros, if necessary
set s [expr {$size * 2}]
set val [format "0x%0${s}x" $val]
# set memory
+ #debug "set_mem $addr $val $size"
if {[catch {gdb_set_mem $addr $val $size} res]} {
error_dialog $res
# cursor
cursor watch
+ # go away if window is not finished drawing
+ if {![winfo exists $itk_interior.f.cntl]} { return }
+
# Disable menus
if {$mbar} {
for {set i 0} {$i <= [$itk_interior.m.addr index last]} {incr i} {
# window is resized.
# ------------------------------------------------------------------
body MemWin::newsize {height} {
+
if {$dont_size || $Running} {
return
}
# METHOD: update_address - update address and data displayed
# ------------------------------------------------------------------
body MemWin::update_address { {ae ""} } {
+ debug $ae
if {$ae == ""} {
set addr_exp [string trimleft [$itk_interior.f.cntl get]]
} else {
set addr_exp $ae
}
+ set bad_expr 0
set saved_addr $current_addr
if {[string match {[a-zA-Z_&0-9\*]*} $addr_exp]} {
# Looks like an expression
- set retVal [catch {gdb_eval "$addr_exp"} current_addr]
+ set retVal [catch {gdb_eval "$addr_exp" x} current_addr]
+ #debug "retVal=$retVal current_addr=$current_addr"
if {$retVal || [string match "No symbol*" $current_addr] || \
[string match "Invalid *" $current_addr]} {
BadExpr $current_addr
}
} elseif {[regexp {\$[a-zA-Z_]} $addr_exp]} {
# Looks like a local variable
- catch {gdb_eval "$addr_exp"} current_addr
- if {$current_addr == "No registers.\n"} {
- # we asked for a register value and debugging hasn't started yet
- return
+ set retVal [catch {gdb_eval "$addr_exp" x} current_addr]
+ #debug "retVal=$retVal current_addr=$current_addr"
+ if {$retVal} {
+ BadExpr $current_addr
+ return
}
if {$current_addr == "void"} {
- BadExpr "No Local Variable Named \"$addr_ex\""
+ BadExpr "No Local Variable Named \"$addr_exp\""
return
}
} else {
BadExpr "Can't Evaluate \"$addr_exp\""
return
}
-
+
# Check for spaces
set index [string first \ $current_addr]
if {$index != -1} {
$itk_interior.t config -bg gray -state disabled
set current_addr $saved_addr
set saved_addr ""
+ set bad_expr 1
}
# ------------------------------------------------------------------
# the current address.
# ------------------------------------------------------------------
body MemWin::incr_addr {num} {
-
if {$current_addr == ""} {
return
}
set old_addr $current_addr
-
- # You have to be careful with address calculations here, since the memory
- # space of the target may be bigger than a long, which will cause Tcl to
- # overflow. Let gdb do the calculations instead.
-
- set current_addr [gdb_cmd "printf \"%u\", $current_addr + $num * $bytes_per_row"]
+ set current_addr [gdb_incr_addr $current_addr + [expr {$bytes_per_row * $num}]]
# A memory address less than zero is probably not a good thing...
#
# ------------------------------------------------------------------
# METHOD: update_addr - read in data starting at $current_addr
-# This is just a helper function for update_address.
+# This is just a helper function for update_address.
# ------------------------------------------------------------------
body MemWin::update_addr {} {
global _mem ${this}_memval
+ if {$bad_expr} {
+ return
+ }
+
gdbtk_busy
set addr $current_addr
-
set row 0
if {$numbytes == 0} {
set asc ""
}
- # Last chance to verify addr
- if {![catch {gdb_eval $addr}]} {
- set retVal [catch {gdb_get_mem $addr $format \
- $size $nb $bytes_per_row $asc} vals]
-
- if {$retVal || [llength $vals] == 0} {
- # FIXME gdb_get_mem does not always return an error when addr is invalid.
- BadExpr "Couldn't get memory at address: \"$addr\""
- gdbtk_idle
- debug "gdb_get_mem returned return code: $retVal and value: \"$vals\""
- return
+ #debug "get_mem $addr $format $size $nb $bytes_per_row $asc"
+ set retVal [catch {gdb_get_mem $addr $format \
+ $size $nb $bytes_per_row $asc} vals]
+ #debug "retVal=$retVal vals=$vals"
+ if {$retVal || [llength $vals] == 0} {
+ # FIXME gdb_get_mem does not always return an error when addr is invalid.
+ BadExpr "Couldn't get memory at address: \"$addr\""
+ gdbtk_idle
+ dbug W "gdb_get_mem returned return code: $retVal and value: \"$vals\""
+ return
+ }
+
+ set mlen 0
+ for {set n 0} {$n < $nb} {incr n $bytes_per_row} {
+ set x $addr
+ if {[string length $x] > $mlen} {
+ set mlen [string length $x]
}
-
- set mlen 0
- for {set n 0} {$n < $nb} {incr n $bytes_per_row} {
- set x [format "0x%x" $addr]
- if {[string length $x] > $mlen} {
- set mlen [string length $x]
- }
- set ${this}_memval($row,-1) $x
- for { set col 0 } { $col < $num } { incr col } {
- set x [lindex $vals $nextval]
- if {[string length $x] > $maxlen} {set maxlen [string length $x]}
- set ${this}_memval($row,$col) $x
- incr nextval
- }
- if {$ascii} {
- set x [lindex $vals $nextval]
- if {[string length $x] > $maxalen} {set maxalen [string length $x]}
- set ${this}_memval($row,$col) $x
- incr nextval
- }
- incr addr $bytes_per_row
- incr row
+ set ${this}_memval($row,-1) $x
+ for { set col 0 } { $col < $num } { incr col } {
+ set x [lindex $vals $nextval]
+ if {[string length $x] > $maxlen} {set maxlen [string length $x]}
+ set ${this}_memval($row,$col) $x
+ incr nextval
}
- # set default column width to the max in the data columns
- $itk_interior.t configure -colwidth [expr {$maxlen + 1}]
- # set border column width
- $itk_interior.t width -1 [expr {$mlen + 1}]
if {$ascii} {
- # set ascii column width
- $itk_interior.t width $Numcols [expr {$maxalen + 1}]
+ set x [lindex $vals $nextval]
+ if {[string length $x] > $maxalen} {set maxalen [string length $x]}
+ set ${this}_memval($row,$col) $x
+ incr nextval
}
+ set addr [gdb_incr_addr $addr $bytes_per_row]
+ incr row
+ }
+ # set default column width to the max in the data columns
+ $itk_interior.t configure -colwidth [expr {$maxlen + 1}]
+ # set border column width
+ $itk_interior.t width -1 [expr {$mlen + 1}]
+ if {$ascii} {
+ # set ascii column width
+ $itk_interior.t width $Numcols [expr {$maxalen + 1}]
}
gdbtk_idle
set current_addr $addr
$itk_interior.f.cntl delete 0 end
$itk_interior.f.cntl insert end $addr
+ update_address
}
# ------------------------------------------------------------------