[PATCH] introduce gdb_set_mem

[Keith Seitz <keiths at cygnus dot com>]

Hi,

I have committed the following patch, which removes two
occurances of "gdb_cmd". To set memory, you now use the tcl command,
gdb_set_mem.

Keith

ChangeLog:
2001-05-25  Keith Seitz  <keiths@cygnus.com>

	* generic/gdbtk-cmds.c (bin2hex): New function.
	(fromhex): New function.
	(gdb_set_mem): New function.
	(Gdbtk_Init): Add new command, "gdb_set_mem".
	* library/memwin.itb (edit): Use "gdb_set_mem" to set
	memory, not some gdb_cmd contrivance.
	When sending data to gdb_set_mem, make sure that it
	is properly zero-padded.

Patch:
Index: generic/gdbtk-cmds.c
===================================================================
RCS file: /cvs/src/src/gdb/gdbtk/generic/gdbtk-cmds.c,v
retrieving revision 1.35
diff -u -p -r1.35 gdbtk-cmds.c
--- gdbtk-cmds.c	2001/05/10 18:04:23	1.35
+++ gdbtk-cmds.c	2001/05/25 21:04:56
@@ -144,6 +144,7 @@ static int gdb_get_function_command (Cli
 static int gdb_get_line_command (ClientData, Tcl_Interp *, int,
 				 Tcl_Obj * CONST objv[]);
 static int gdb_get_mem (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
+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_listfiles (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
@@ -197,6 +198,8 @@ static int gdb_disassemble_driver (CORE_
 char *get_prompt (void);
 static int perror_with_name_wrapper (PTR args);
 static int wrapped_call (PTR opaque_args);
+static int hex2bin (const char *hex, char *bin, int count);
+static int fromhex (int a);


 /* Gdbtk_Init
@@ -227,6 +230,8 @@ Gdbtk_Init (interp)
 			gdb_entry_point, NULL);
   Tcl_CreateObjCommand (interp, "gdb_get_mem", gdbtk_call_wrapper, gdb_get_mem,
 			NULL);
+  Tcl_CreateObjCommand (interp, "gdb_set_mem", gdbtk_call_wrapper, gdb_set_mem,
+			NULL);
   Tcl_CreateObjCommand (interp, "gdb_stop", gdbtk_call_wrapper, gdb_stop, NULL);
   Tcl_CreateObjCommand (interp, "gdb_restore_fputs", gdbtk_call_wrapper, gdb_restore_fputs,
 			NULL);
@@ -2443,6 +2448,105 @@ gdb_entry_point (clientData, interp, obj
   else
     Tcl_SetStringObj (result_ptr->obj_ptr, "", -1);

+  return TCL_OK;
+}
+
+/* Covert hex to binary. Stolen from remote.c,
+   but added error handling */
+static int
+fromhex (int a)
+{
+  if (a >= '0' && a <= '9')
+    return a - '0';
+  else if (a >= 'a' && a <= 'f')
+    return a - 'a' + 10;
+  else if (a >= 'A' && a <= 'F')
+    return a - 'A' + 10;
+
+  return -1;
+}
+
+static int
+hex2bin (const char *hex, char *bin, int count)
+{
+  int i;
+  int m, n;
+
+  for (i = 0; i < count; i++)
+    {
+      if (hex[0] == 0 || hex[1] == 0)
+	{
+	  /* Hex string is short, or of uneven length.
+	     Return the count that has been converted so far. */
+	  return i;
+	}
+      m = fromhex (hex[0]);
+      n = fromhex (hex[1]);
+      if (m == -1 || n == -1)
+	return -1;
+      *bin++ = m * 16 + n;
+      hex += 2;
+    }
+
+  return i;
+}
+
+/* This implements the Tcl command 'gdb_set_mem', which
+ * sets some chunk of memory.
+ *
+ * Arguments:
+ *   gdb_set_mem addr hexstr len
+ *
+ *   addr:   address of data to set
+ *   hexstr: ascii string of data to set
+ *   len:    number of bytes of data to set
+ */
+static int
+gdb_set_mem (clientData, interp, objc, objv)
+     ClientData clientData;
+     Tcl_Interp *interp;
+     int objc;
+     Tcl_Obj *CONST objv[];
+{
+  CORE_ADDR addr;
+  char buf[128];
+  char *hexstr;
+  int len, size;
+
+  if (objc != 4)
+    {
+      Tcl_WrongNumArgs (interp, 1, objv, "addr hex_data len");
+      return TCL_ERROR;
+    }
+
+  /* Address to write */
+  addr = parse_and_eval_address (Tcl_GetStringFromObj (objv[1], NULL));
+
+  /* String value to write: it's in hex */
+  hexstr = Tcl_GetStringFromObj (objv[2], NULL);
+  if (hexstr == NULL)
+    return TCL_ERROR;
+
+  /* Length of buf */
+  if (Tcl_GetIntFromObj (interp, objv[3], &len) != TCL_OK)
+    return TCL_ERROR;
+
+  /* Convert hexstr to binary and write */
+  if (hexstr[0] == '0' && hexstr[1] == 'x')
+    hexstr += 2;
+  size = hex2bin (hexstr, buf, strlen (hexstr));
+  if (size < 0)
+    {
+      /* Error in input */
+      char *res;
+
+      xasprintf (&res, "Invalid hexadecimal input: \"0x%s\"", hexstr);
+      Tcl_SetObjResult (interp, Tcl_NewStringObj (res, -1));
+      free (res);
+      return TCL_ERROR;
+    }
+
+  target_write_memory (addr, buf, len);
   return TCL_OK;
 }

Index: library/memwin.itb
===================================================================
RCS file: /cvs/src/src/gdb/gdbtk/library/memwin.itb,v
retrieving revision 1.4
diff -u -p -r1.4 memwin.itb
--- memwin.itb	2001/05/22 19:10:06	1.4
+++ memwin.itb	2001/05/25 21:04:56
@@ -288,10 +288,9 @@ body MemWin::edit { cell } {
     # now process each char, one at a time
     foreach c [split $val ""] {
       if {$c != $ascii_char} {
-	if {$c == "'"} {set c "\\'"}
-	set err [catch {gdb_cmd "set *(char *)($addr) = '$c'"} res]
-	if {$err} {
-	  error_dialog [winfo toplevel $itk_interior] $res
+	scan $c %c char
+	if {[catch {gdb_set_mem $addr [format %02x $char] 1} res]} {
+	  error_dialog $res

 	  # reset value
 	  set ${this}_memval($row,$col) $saved_value
@@ -321,10 +320,14 @@ body MemWin::edit { cell } {
   # 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 memory
-  set err [catch {gdb_cmd "set *($type($size) *)($addr) = $val"} res]
-  if {$err} {
-    error_dialog [winfo toplevel $itk_interior] $res
+
+  # Pad the value with zeros, if necessary
+  set s [expr {$size * 2}]
+  set val [format "0x%0${s}x" $val]
+
+  # set memory
+  if {[catch {gdb_set_mem $addr $val $size} res]} {
+    error_dialog $res

     # reset value
     set ${this}_memval($row,$col) $saved_value