[deliverable/binutils-gdb.git] / gdb / gdbtk.c

/* TK interface routines.
   Copyright 1994 Free Software Foundation, Inc.

This file is part of GDB.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License 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.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */

#include "defs.h"
#include "symtab.h"
#include "inferior.h"
#include "command.h"
#include "bfd.h"
#include "symfile.h"
#include "objfiles.h"
#include "target.h"
#include <tcl.h>
#include <tk.h>
#include <varargs.h>
#include <signal.h>
#include <fcntl.h>
#include <unistd.h>

/* Non-zero means that we're doing the gdbtk interface. */
int gdbtk = 0;

/* Non-zero means we are reloading breakpoints, etc from the
   Gdbtk kernel, and we should suppress various messages */
static int gdbtk_reloading = 0;

/* Handle for TCL interpreter */
static Tcl_Interp *interp = NULL;

/* Handle for TK main window */
static Tk_Window mainWindow = NULL;

static int x_fd;		/* X network socket */

static void
null_routine(arg)
     int arg;
{
}

\f
/* This routine redirects the output of fputs_unfiltered so that
   the user can see what's going on in his debugger window. */

static char holdbuf[200];
static char *holdbufp = holdbuf;
static int holdfree = sizeof (holdbuf);

static void
flush_holdbuf ()
{
  if (holdbufp == holdbuf)
    return;

  Tcl_VarEval (interp, "gdbtk_tcl_fputs ", "{", holdbuf, "}", NULL);
  holdbufp = holdbuf;
  holdfree = sizeof (holdbuf);
}

static void
gdbtk_flush (stream)
     FILE *stream;
{
  flush_holdbuf ();

  Tcl_VarEval (interp, "gdbtk_tcl_flush", NULL);
}

static void
gdbtk_fputs (ptr)
     const char *ptr;
{
  int len;

  len = strlen (ptr) + 1;

  if (len > holdfree)
    {
      flush_holdbuf ();

      if (len > sizeof (holdbuf))
	{
	  Tcl_VarEval (interp, "gdbtk_tcl_fputs ", "{", ptr, "}", NULL);
	  return;
	}
    }

  strncpy (holdbufp, ptr, len);
  holdbufp += len - 1;
  holdfree -= len - 1;
}

static int
gdbtk_query (args)
     va_list args;
{
  char *query;
  char buf[200];
  long val;

  query = va_arg (args, char *);

  vsprintf(buf, query, args);
  Tcl_VarEval (interp, "gdbtk_tcl_query ", "{", buf, "}", NULL);

  val = atol (interp->result);
  return val;
}
\f
#if 0
static char *
full_filename(symtab)
     struct symtab *symtab;
{
  int pathlen;
  char *filename;

  if (!symtab)
    return NULL;

  if (symtab->fullname)
    return savestring(symtab->fullname, strlen(symtab->fullname));

  if (symtab->filename[0] == '/')
    return savestring(symtab->filename, strlen(symtab->filename));

  if (symtab->dirname)
    pathlen = strlen(symtab->dirname);
  else
    pathlen = 0;
  if (symtab->filename)
    pathlen += strlen(symtab->filename);

  filename = xmalloc(pathlen+1);

  if (symtab->dirname)
    strcpy(filename, symtab->dirname);
  else
    *filename = '\000';
  if (symtab->filename)
    strcat(filename, symtab->filename);

  return filename;
}
#endif
\f
static void
breakpoint_notify(b, action)
     struct breakpoint *b;
     const char *action;
{
  struct symbol *sym;
  char bpnum[50], line[50], pc[50];
  struct symtab_and_line sal;
  char *filename;
  int v;

  if (b->type != bp_breakpoint)
    return;

  sal = find_pc_line (b->address, 0);

  filename = symtab_to_filename (sal.symtab);

  sprintf (bpnum, "%d", b->number);
  sprintf (line, "%d", sal.line);
  sprintf (pc, "0x%x", b->address);
 
  v = Tcl_VarEval (interp,
		   "gdbtk_tcl_breakpoint ",
		   action,
		   " ", bpnum,
		   " ", filename,
		   " ", line,
		   " ", pc,
		   NULL);

  if (v != TCL_OK)
    {
      gdbtk_fputs (interp->result);
      gdbtk_fputs ("\n");
    }
}

static void
gdbtk_create_breakpoint(b)
     struct breakpoint *b;
{
  breakpoint_notify(b, "create");
}

static void
gdbtk_delete_breakpoint(b)
     struct breakpoint *b;
{
  breakpoint_notify(b, "delete");
}

static void
gdbtk_enable_breakpoint(b)
     struct breakpoint *b;
{
  breakpoint_notify(b, "enable");
}

static void
gdbtk_disable_breakpoint(b)
     struct breakpoint *b;
{
  breakpoint_notify(b, "disable");
}
\f
/* This implements the TCL command `gdb_loc', which returns a list consisting
   of the source and line number associated with the current pc. */

static int
gdb_loc (clientData, interp, argc, argv)
     ClientData clientData;
     Tcl_Interp *interp;
     int argc;
     char *argv[];
{
  char *filename;
  char buf[100];
  struct symtab_and_line sal;
  char *funcname;
  CORE_ADDR pc;

  if (argc == 1)
    {
      struct frame_info *frame;
      struct symbol *func;

      frame = get_frame_info (selected_frame);

      pc = frame ? frame->pc : stop_pc;

      sal = find_pc_line (pc, 0);
    }
  else if (argc == 2)
    {
      struct symtabs_and_lines sals;
      int nelts;

      sals = decode_line_spec (argv[1], 1);

      nelts = sals.nelts;
      sal = sals.sals[0];
      free (sals.sals);

      if (sals.nelts != 1)
	{
	  Tcl_SetResult (interp, "Ambiguous line spec", TCL_STATIC);
	  return TCL_ERROR;
	}

      pc = sal.pc;
    }
  else
    {
      Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
      return TCL_ERROR;
    }

  if (sal.symtab)
    Tcl_AppendElement (interp, sal.symtab->filename);
  else
    Tcl_AppendElement (interp, "");

  find_pc_partial_function (pc, &funcname, NULL, NULL);
  Tcl_AppendElement (interp, funcname);

  filename = symtab_to_filename (sal.symtab);
  Tcl_AppendElement (interp, filename);

  sprintf (buf, "%d", sal.line);
  Tcl_AppendElement (interp, buf); /* line number */

  sprintf (buf, "0x%x", pc);
  Tcl_AppendElement (interp, buf); /* PC */

  return TCL_OK;
}
\f
static int
gdb_cmd_stub (cmd)
     char *cmd;
{
  execute_command (cmd, 1);

  return 1;			/* Indicate success */
}

/* This implements the TCL command `gdb_cmd', which sends it's argument into
   the GDB command scanner.  */

static int
gdb_cmd (clientData, interp, argc, argv)
     ClientData clientData;
     Tcl_Interp *interp;
     int argc;
     char *argv[];
{
  int val;
  struct cleanup *old_chain;

  if (argc != 2)
    {
      Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
      return TCL_ERROR;
    }

  old_chain = make_cleanup (null_routine, 0);

  val = catch_errors (gdb_cmd_stub, argv[1], "", RETURN_MASK_ERROR);

  /* In case of an error, we may need to force the GUI into idle mode because
     gdbtk_call_command may have bombed out while in the command routine.  */

  if (val == 0)
    Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);

  bpstat_do_actions (&stop_bpstat);
  do_cleanups (old_chain);

  /* Drain all buffered command output */

  gdb_flush (gdb_stderr);
  gdb_flush (gdb_stdout);

  /* We could base the return value on val, but that would require most users
     to use catch.  Since GDB errors are already being handled elsewhere, I
     see no reason to pass them up to the caller. */

  return TCL_OK;
}

static int
gdb_listfiles (clientData, interp, argc, argv)
     ClientData clientData;
     Tcl_Interp *interp;
     int argc;
     char *argv[];
{
  int val;
  struct objfile *objfile;
  struct partial_symtab *psymtab;

  ALL_PSYMTABS (objfile, psymtab)
    Tcl_AppendElement (interp, psymtab->filename);

  return TCL_OK;
}

static int
gdb_stop (clientData, interp, argc, argv)
     ClientData clientData;
     Tcl_Interp *interp;
     int argc;
     char *argv[];
{
  extern pid_t inferior_process_group;

  /* XXX - This is WRONG for remote targets.  Probably need a target vector
     entry to do this right.  */

  kill (-inferior_process_group, SIGINT);
}

\f
static void
tk_command (cmd, from_tty)
     char *cmd;
     int from_tty;
{
  Tcl_VarEval (interp, cmd, NULL);

  gdbtk_fputs (interp->result);
  gdbtk_fputs ("\n");
}

static void
cleanup_init (ignored)
     int ignored;
{
  if (mainWindow != NULL)
    Tk_DestroyWindow (mainWindow);
  mainWindow = NULL;

  if (interp != NULL)
    Tcl_DeleteInterp (interp);
  interp = NULL;
}

/* Come here during long calculations to check for GUI events.  Usually invoked
   via the QUIT macro.  */

static void
gdbtk_interactive ()
{
  /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
}

/* Come here when there is activity on the X file descriptor. */

static void
x_event (signo)
     int signo;
{
  /* Process pending events */

  while (Tk_DoOneEvent (TK_DONT_WAIT|TK_ALL_EVENTS) != 0);
}

static int
gdbtk_wait (pid, ourstatus)
     int pid;
     struct target_waitstatus *ourstatus;
{
  signal (SIGIO, x_event);

  pid = target_wait (pid, ourstatus);

  signal (SIGIO, SIG_IGN);

  return pid;
}

/* This is called from execute_command, and provides a wrapper around
   various command routines in a place where both protocol messages and
   user input both flow through.  Mostly this is used for indicating whether
   the target process is running or not.
*/

static void
gdbtk_call_command (cmdblk, arg, from_tty)
     struct cmd_list_element *cmdblk;
     char *arg;
     int from_tty;
{
  if (cmdblk->class == class_run)
    {
      Tcl_VarEval (interp, "gdbtk_tcl_busy", NULL);
      (*cmdblk->function.cfunc)(arg, from_tty);
      Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
    }
  else
    (*cmdblk->function.cfunc)(arg, from_tty);
}

static void
gdbtk_init ()
{
  struct cleanup *old_chain;
  char *gdbtk_filename;
  int i;

  old_chain = make_cleanup (cleanup_init, 0);

  /* First init tcl and tk. */

  interp = Tcl_CreateInterp ();

  if (!interp)
    error ("Tcl_CreateInterp failed");

  mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");

  if (!mainWindow)
    return;			/* DISPLAY probably not set */

  if (Tcl_Init(interp) != TCL_OK)
    error ("Tcl_Init failed: %s", interp->result);

  if (Tk_Init(interp) != TCL_OK)
    error ("Tk_Init failed: %s", interp->result);

  Tcl_CreateCommand (interp, "gdb_cmd", gdb_cmd, NULL, NULL);
  Tcl_CreateCommand (interp, "gdb_loc", gdb_loc, NULL, NULL);
  Tcl_CreateCommand (interp, "gdb_listfiles", gdb_listfiles, NULL, NULL);
  Tcl_CreateCommand (interp, "gdb_stop", gdb_stop, NULL, NULL);

  gdbtk_filename = getenv ("GDBTK_FILENAME");
  if (!gdbtk_filename)
    if (access ("gdbtk.tcl", R_OK) == 0)
      gdbtk_filename = "gdbtk.tcl";
    else
      gdbtk_filename = GDBTK_FILENAME;

  if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
    error ("Failure reading %s: %s", gdbtk_filename, interp->result);

  /* Get the file descriptor for the X server */

  x_fd = ConnectionNumber (Tk_Display (mainWindow));

  /* Setup for I/O interrupts */

  signal (SIGIO, SIG_IGN);

  i = fcntl (x_fd, F_GETFL, 0);
  fcntl (x_fd, F_SETFL, i|FASYNC);
  fcntl (x_fd, F_SETOWN, getpid()); 

  command_loop_hook = Tk_MainLoop;
  fputs_unfiltered_hook = gdbtk_fputs;
  print_frame_info_listing_hook = null_routine;
  query_hook = gdbtk_query;
  flush_hook = gdbtk_flush;
  create_breakpoint_hook = gdbtk_create_breakpoint;
  delete_breakpoint_hook = gdbtk_delete_breakpoint;
  enable_breakpoint_hook = gdbtk_enable_breakpoint;
  disable_breakpoint_hook = gdbtk_disable_breakpoint;
  interactive_hook = gdbtk_interactive;
  target_wait_hook = gdbtk_wait;
  call_command_hook = gdbtk_call_command;

  discard_cleanups (old_chain);

  add_com ("tk", class_obscure, tk_command,
	   "Send a command directly into tk.");
}

/* Come here during initialze_all_files () */

void
_initialize_gdbtk ()
{
  if (use_windows)
    {
      /* Tell the rest of the world that Gdbtk is now set up. */

      init_ui_hook = gdbtk_init;
    }
}
Commit	Line	Data
754e5da2 SG	1	/* TK interface routines.
	2	Copyright 1994 Free Software Foundation, Inc.
	3
	4	This file is part of GDB.
	5
	6	This program is free software; you can redistribute it and/or modify
	7	it under the terms of the GNU General Public License as published by
	8	the Free Software Foundation; either version 2 of the License, or
	9	(at your option) any later version.
	10
	11	This program is distributed in the hope that it will be useful,
	12	but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	GNU General Public License for more details.
	15
	16	You should have received a copy of the GNU General Public License
	17	along with this program; if not, write to the Free Software
	18	Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
	19
	20	#include "defs.h"
	21	#include "symtab.h"
	22	#include "inferior.h"
	23	#include "command.h"
	24	#include "bfd.h"
	25	#include "symfile.h"
	26	#include "objfiles.h"
	27	#include "target.h"
754e5da2 SG	28	#include <tcl.h>
754e5da2 SG	29	#include <tk.h>
cd2df226 SG	30	#include <varargs.h>
	31	#include <signal.h>
	32	#include <fcntl.h>
8532893d	33	#include <unistd.h>
754e5da2 SG	34
	35	/* Non-zero means that we're doing the gdbtk interface. */
	36	int gdbtk = 0;
	37
	38	/* Non-zero means we are reloading breakpoints, etc from the
	39	Gdbtk kernel, and we should suppress various messages */
	40	static int gdbtk_reloading = 0;
	41
	42	/* Handle for TCL interpreter */
	43	static Tcl_Interp *interp = NULL;
	44
	45	/* Handle for TK main window */
	46	static Tk_Window mainWindow = NULL;
	47
479f0f18 SG	48	static int x_fd; /* X network socket */
479f0f18 SG	49
754e5da2 SG	50	static void
	51	null_routine(arg)
	52	int arg;
	53	{
	54	}
	55
	56	\f
	57	/* This routine redirects the output of fputs_unfiltered so that
	58	the user can see what's going on in his debugger window. */
	59
8532893d SG	60	static char holdbuf[200];
	61	static char *holdbufp = holdbuf;
	62	static int holdfree = sizeof (holdbuf);
	63
754e5da2	64	static void
8532893d	65	flush_holdbuf ()
754e5da2	66	{
8532893d SG	67	if (holdbufp == holdbuf)
	68	return;
	69
	70	Tcl_VarEval (interp, "gdbtk_tcl_fputs ", "{", holdbuf, "}", NULL);
	71	holdbufp = holdbuf;
	72	holdfree = sizeof (holdbuf);
754e5da2 SG	73	}
	74
	75	static void
	76	gdbtk_flush (stream)
	77	FILE *stream;
	78	{
8532893d SG	79	flush_holdbuf ();
8532893d SG	80
754e5da2 SG	81	Tcl_VarEval (interp, "gdbtk_tcl_flush", NULL);
	82	}
	83
8532893d SG	84	static void
	85	gdbtk_fputs (ptr)
	86	const char *ptr;
	87	{
	88	int len;
	89
	90	len = strlen (ptr) + 1;
	91
	92	if (len > holdfree)
	93	{
	94	flush_holdbuf ();
	95
	96	if (len > sizeof (holdbuf))
	97	{
	98	Tcl_VarEval (interp, "gdbtk_tcl_fputs ", "{", ptr, "}", NULL);
	99	return;
	100	}
	101	}
	102
	103	strncpy (holdbufp, ptr, len);
	104	holdbufp += len - 1;
	105	holdfree -= len - 1;
	106	}
	107
754e5da2 SG	108	static int
	109	gdbtk_query (args)
	110	va_list args;
	111	{
	112	char *query;
	113	char buf[200];
	114	long val;
	115
	116	query = va_arg (args, char *);
	117
	118	vsprintf(buf, query, args);
	119	Tcl_VarEval (interp, "gdbtk_tcl_query ", "{", buf, "}", NULL);
	120
	121	val = atol (interp->result);
	122	return val;
	123	}
	124	\f
637b1661	125	#if 0
754e5da2 SG	126	static char *
	127	full_filename(symtab)
	128	struct symtab *symtab;
	129	{
	130	int pathlen;
	131	char *filename;
	132
	133	if (!symtab)
	134	return NULL;
	135
	136	if (symtab->fullname)
	137	return savestring(symtab->fullname, strlen(symtab->fullname));
	138
	139	if (symtab->filename[0] == '/')
	140	return savestring(symtab->filename, strlen(symtab->filename));
	141
	142	if (symtab->dirname)
	143	pathlen = strlen(symtab->dirname);
	144	else
	145	pathlen = 0;
	146	if (symtab->filename)
	147	pathlen += strlen(symtab->filename);
	148
	149	filename = xmalloc(pathlen+1);
	150
	151	if (symtab->dirname)
	152	strcpy(filename, symtab->dirname);
	153	else
	154	*filename = '\000';
	155	if (symtab->filename)
	156	strcat(filename, symtab->filename);
	157
	158	return filename;
	159	}
637b1661	160	#endif
754e5da2 SG	161	\f
	162	static void
	163	breakpoint_notify(b, action)
	164	struct breakpoint *b;
	165	const char *action;
	166	{
	167	struct symbol *sym;
8532893d	168	char bpnum[50], line[50], pc[50];
754e5da2 SG	169	struct symtab_and_line sal;
	170	char *filename;
	171	int v;
	172
	173	if (b->type != bp_breakpoint)
	174	return;
	175
	176	sal = find_pc_line (b->address, 0);
	177
637b1661	178	filename = symtab_to_filename (sal.symtab);
754e5da2 SG	179
	180	sprintf (bpnum, "%d", b->number);
	181	sprintf (line, "%d", sal.line);
8532893d	182	sprintf (pc, "0x%x", b->address);
754e5da2 SG	183
	184	v = Tcl_VarEval (interp,
	185	"gdbtk_tcl_breakpoint ",
	186	action,
	187	" ", bpnum,
	188	" ", filename,
	189	" ", line,
8532893d	190	" ", pc,
754e5da2 SG	191	NULL);
	192
	193	if (v != TCL_OK)
	194	{
	195	gdbtk_fputs (interp->result);
	196	gdbtk_fputs ("\n");
	197	}
754e5da2 SG	198	}
	199
	200	static void
	201	gdbtk_create_breakpoint(b)
	202	struct breakpoint *b;
	203	{
	204	breakpoint_notify(b, "create");
	205	}
	206
	207	static void
	208	gdbtk_delete_breakpoint(b)
	209	struct breakpoint *b;
	210	{
	211	breakpoint_notify(b, "delete");
	212	}
	213
	214	static void
	215	gdbtk_enable_breakpoint(b)
	216	struct breakpoint *b;
	217	{
	218	breakpoint_notify(b, "enable");
	219	}
	220
	221	static void
	222	gdbtk_disable_breakpoint(b)
	223	struct breakpoint *b;
	224	{
	225	breakpoint_notify(b, "disable");
	226	}
	227	\f
	228	/* This implements the TCL command `gdb_loc', which returns a list consisting
	229	of the source and line number associated with the current pc. */
	230
	231	static int
	232	gdb_loc (clientData, interp, argc, argv)
	233	ClientData clientData;
	234	Tcl_Interp *interp;
	235	int argc;
	236	char *argv[];
	237	{
	238	char *filename;
	239	char buf[100];
	240	struct symtab_and_line sal;
	241	char *funcname;
8532893d	242	CORE_ADDR pc;
754e5da2 SG	243
	244	if (argc == 1)
	245	{
	246	struct frame_info *frame;
	247	struct symbol *func;
754e5da2 SG	248
754e5da2 SG	249	frame = get_frame_info (selected_frame);
8532893d	250
754e5da2	251	pc = frame ? frame->pc : stop_pc;
8532893d	252
754e5da2 SG	253	sal = find_pc_line (pc, 0);
	254	}
	255	else if (argc == 2)
	256	{
754e5da2	257	struct symtabs_and_lines sals;
8532893d	258	int nelts;
754e5da2 SG	259
	260	sals = decode_line_spec (argv[1], 1);
	261
8532893d SG	262	nelts = sals.nelts;
	263	sal = sals.sals[0];
	264	free (sals.sals);
	265
754e5da2 SG	266	if (sals.nelts != 1)
	267	{
	268	Tcl_SetResult (interp, "Ambiguous line spec", TCL_STATIC);
754e5da2 SG	269	return TCL_ERROR;
	270	}
	271
8532893d	272	pc = sal.pc;
754e5da2 SG	273	}
	274	else
	275	{
	276	Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
	277	return TCL_ERROR;
	278	}
	279
754e5da2 SG	280	if (sal.symtab)
	281	Tcl_AppendElement (interp, sal.symtab->filename);
	282	else
	283	Tcl_AppendElement (interp, "");
8532893d SG	284
8532893d SG	285	find_pc_partial_function (pc, &funcname, NULL, NULL);
754e5da2	286	Tcl_AppendElement (interp, funcname);
8532893d	287
637b1661	288	filename = symtab_to_filename (sal.symtab);
754e5da2	289	Tcl_AppendElement (interp, filename);
8532893d SG	290
8532893d SG	291	sprintf (buf, "%d", sal.line);
754e5da2 SG	292	Tcl_AppendElement (interp, buf); /* line number */
754e5da2 SG	293
8532893d SG	294	sprintf (buf, "0x%x", pc);
	295	Tcl_AppendElement (interp, buf); /* PC */
	296
754e5da2 SG	297	return TCL_OK;
	298	}
	299	\f
	300	static int
	301	gdb_cmd_stub (cmd)
	302	char *cmd;
	303	{
	304	execute_command (cmd, 1);
	305
	306	return 1; /* Indicate success */
	307	}
	308
	309	/* This implements the TCL command `gdb_cmd', which sends it's argument into
	310	the GDB command scanner. */
	311
	312	static int
	313	gdb_cmd (clientData, interp, argc, argv)
	314	ClientData clientData;
	315	Tcl_Interp *interp;
	316	int argc;
	317	char *argv[];
	318	{
	319	int val;
	320	struct cleanup *old_chain;
	321
	322	if (argc != 2)
	323	{
	324	Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
	325	return TCL_ERROR;
	326	}
	327
	328	old_chain = make_cleanup (null_routine, 0);
	329
	330	val = catch_errors (gdb_cmd_stub, argv[1], "", RETURN_MASK_ERROR);
	331
479f0f18 SG	332	/* In case of an error, we may need to force the GUI into idle mode because
	333	gdbtk_call_command may have bombed out while in the command routine. */
	334
	335	if (val == 0)
	336	Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
	337
754e5da2 SG	338	bpstat_do_actions (&stop_bpstat);
	339	do_cleanups (old_chain);
	340
8532893d SG	341	/* Drain all buffered command output */
	342
	343	gdb_flush (gdb_stderr);
	344	gdb_flush (gdb_stdout);
	345
754e5da2 SG	346	/* We could base the return value on val, but that would require most users
	347	to use catch. Since GDB errors are already being handled elsewhere, I
	348	see no reason to pass them up to the caller. */
	349
	350	return TCL_OK;
	351	}
	352
	353	static int
	354	gdb_listfiles (clientData, interp, argc, argv)
	355	ClientData clientData;
	356	Tcl_Interp *interp;
	357	int argc;
	358	char *argv[];
	359	{
	360	int val;
	361	struct objfile *objfile;
	362	struct partial_symtab *psymtab;
	363
	364	ALL_PSYMTABS (objfile, psymtab)
	365	Tcl_AppendElement (interp, psymtab->filename);
	366
	367	return TCL_OK;
	368	}
479f0f18 SG	369
	370	static int
	371	gdb_stop (clientData, interp, argc, argv)
	372	ClientData clientData;
	373	Tcl_Interp *interp;
	374	int argc;
	375	char *argv[];
	376	{
	377	extern pid_t inferior_process_group;
	378
	379	/* XXX - This is WRONG for remote targets. Probably need a target vector
	380	entry to do this right. */
	381
	382	kill (-inferior_process_group, SIGINT);
	383	}
	384
754e5da2 SG	385	\f
	386	static void
	387	tk_command (cmd, from_tty)
	388	char *cmd;
	389	int from_tty;
	390	{
	391	Tcl_VarEval (interp, cmd, NULL);
	392
	393	gdbtk_fputs (interp->result);
	394	gdbtk_fputs ("\n");
	395	}
	396
	397	static void
	398	cleanup_init (ignored)
	399	int ignored;
	400	{
	401	if (mainWindow != NULL)
	402	Tk_DestroyWindow (mainWindow);
	403	mainWindow = NULL;
	404
	405	if (interp != NULL)
	406	Tcl_DeleteInterp (interp);
	407	interp = NULL;
	408	}
	409
637b1661 SG	410	/* Come here during long calculations to check for GUI events. Usually invoked
	411	via the QUIT macro. */
	412
	413	static void
	414	gdbtk_interactive ()
	415	{
	416	/* Tk_DoOneEvent (TK_DONT_WAIT\|TK_IDLE_EVENTS); */
	417	}
	418
479f0f18 SG	419	/* Come here when there is activity on the X file descriptor. */
	420
	421	static void
	422	x_event (signo)
	423	int signo;
	424	{
	425	/* Process pending events */
	426
	427	while (Tk_DoOneEvent (TK_DONT_WAIT\|TK_ALL_EVENTS) != 0);
	428	}
	429
	430	static int
	431	gdbtk_wait (pid, ourstatus)
	432	int pid;
	433	struct target_waitstatus *ourstatus;
	434	{
	435	signal (SIGIO, x_event);
	436
	437	pid = target_wait (pid, ourstatus);
	438
	439	signal (SIGIO, SIG_IGN);
	440
	441	return pid;
	442	}
	443
	444	/* This is called from execute_command, and provides a wrapper around
	445	various command routines in a place where both protocol messages and
	446	user input both flow through. Mostly this is used for indicating whether
	447	the target process is running or not.
	448	*/
	449
	450	static void
	451	gdbtk_call_command (cmdblk, arg, from_tty)
	452	struct cmd_list_element *cmdblk;
	453	char *arg;
	454	int from_tty;
	455	{
	456	if (cmdblk->class == class_run)
	457	{
	458	Tcl_VarEval (interp, "gdbtk_tcl_busy", NULL);
	459	(*cmdblk->function.cfunc)(arg, from_tty);
	460	Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
	461	}
	462	else
	463	(*cmdblk->function.cfunc)(arg, from_tty);
	464	}
	465
754e5da2 SG	466	static void
	467	gdbtk_init ()
	468	{
	469	struct cleanup *old_chain;
	470	char *gdbtk_filename;
479f0f18	471	int i;
754e5da2 SG	472
	473	old_chain = make_cleanup (cleanup_init, 0);
	474
	475	/* First init tcl and tk. */
	476
	477	interp = Tcl_CreateInterp ();
	478
	479	if (!interp)
	480	error ("Tcl_CreateInterp failed");
	481
	482	mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");
	483
	484	if (!mainWindow)
	485	return; /* DISPLAY probably not set */
	486
	487	if (Tcl_Init(interp) != TCL_OK)
	488	error ("Tcl_Init failed: %s", interp->result);
	489
	490	if (Tk_Init(interp) != TCL_OK)
	491	error ("Tk_Init failed: %s", interp->result);
	492
	493	Tcl_CreateCommand (interp, "gdb_cmd", gdb_cmd, NULL, NULL);
	494	Tcl_CreateCommand (interp, "gdb_loc", gdb_loc, NULL, NULL);
	495	Tcl_CreateCommand (interp, "gdb_listfiles", gdb_listfiles, NULL, NULL);
479f0f18	496	Tcl_CreateCommand (interp, "gdb_stop", gdb_stop, NULL, NULL);
754e5da2 SG	497
754e5da2 SG	498	gdbtk_filename = getenv ("GDBTK_FILENAME");
8532893d SG	499	if (!gdbtk_filename)
	500	if (access ("gdbtk.tcl", R_OK) == 0)
	501	gdbtk_filename = "gdbtk.tcl";
	502	else
	503	gdbtk_filename = GDBTK_FILENAME;
	504
	505	if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
	506	error ("Failure reading %s: %s", gdbtk_filename, interp->result);
754e5da2	507
cd2df226	508	/* Get the file descriptor for the X server */
479f0f18	509
cd2df226	510	x_fd = ConnectionNumber (Tk_Display (mainWindow));
479f0f18 SG	511
	512	/* Setup for I/O interrupts */
	513
	514	signal (SIGIO, SIG_IGN);
	515
	516	i = fcntl (x_fd, F_GETFL, 0);
	517	fcntl (x_fd, F_SETFL, i\|FASYNC);
	518	fcntl (x_fd, F_SETOWN, getpid());
	519
754e5da2 SG	520	command_loop_hook = Tk_MainLoop;
	521	fputs_unfiltered_hook = gdbtk_fputs;
	522	print_frame_info_listing_hook = null_routine;
	523	query_hook = gdbtk_query;
	524	flush_hook = gdbtk_flush;
	525	create_breakpoint_hook = gdbtk_create_breakpoint;
	526	delete_breakpoint_hook = gdbtk_delete_breakpoint;
	527	enable_breakpoint_hook = gdbtk_enable_breakpoint;
	528	disable_breakpoint_hook = gdbtk_disable_breakpoint;
637b1661	529	interactive_hook = gdbtk_interactive;
479f0f18 SG	530	target_wait_hook = gdbtk_wait;
479f0f18 SG	531	call_command_hook = gdbtk_call_command;
754e5da2 SG	532
	533	discard_cleanups (old_chain);
	534
	535	add_com ("tk", class_obscure, tk_command,
	536	"Send a command directly into tk.");
	537	}
	538
	539	/* Come here during initialze_all_files () */
	540
	541	void
	542	_initialize_gdbtk ()
	543	{
c5197511 SG	544	if (use_windows)
	545	{
	546	/* Tell the rest of the world that Gdbtk is now set up. */
754e5da2	547
c5197511 SG	548	init_ui_hook = gdbtk_init;
c5197511 SG	549	}
754e5da2	550	}