[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)
    {
      pc = selected_frame ? selected_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[];
{
  target_stop ();
}

\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	{
1dfc8dfb	246	pc = selected_frame ? selected_frame->pc : stop_pc;
754e5da2 SG	247	sal = find_pc_line (pc, 0);
	248	}
	249	else if (argc == 2)
	250	{
754e5da2	251	struct symtabs_and_lines sals;
8532893d	252	int nelts;
754e5da2 SG	253
	254	sals = decode_line_spec (argv[1], 1);
	255
8532893d SG	256	nelts = sals.nelts;
	257	sal = sals.sals[0];
	258	free (sals.sals);
	259
754e5da2 SG	260	if (sals.nelts != 1)
	261	{
	262	Tcl_SetResult (interp, "Ambiguous line spec", TCL_STATIC);
754e5da2 SG	263	return TCL_ERROR;
	264	}
	265
8532893d	266	pc = sal.pc;
754e5da2 SG	267	}
	268	else
	269	{
	270	Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
	271	return TCL_ERROR;
	272	}
	273
754e5da2 SG	274	if (sal.symtab)
	275	Tcl_AppendElement (interp, sal.symtab->filename);
	276	else
	277	Tcl_AppendElement (interp, "");
8532893d SG	278
8532893d SG	279	find_pc_partial_function (pc, &funcname, NULL, NULL);
754e5da2	280	Tcl_AppendElement (interp, funcname);
8532893d	281
637b1661	282	filename = symtab_to_filename (sal.symtab);
754e5da2	283	Tcl_AppendElement (interp, filename);
8532893d SG	284
8532893d SG	285	sprintf (buf, "%d", sal.line);
754e5da2 SG	286	Tcl_AppendElement (interp, buf); /* line number */
754e5da2 SG	287
8532893d SG	288	sprintf (buf, "0x%x", pc);
	289	Tcl_AppendElement (interp, buf); /* PC */
	290
754e5da2 SG	291	return TCL_OK;
	292	}
	293	\f
	294	static int
	295	gdb_cmd_stub (cmd)
	296	char *cmd;
	297	{
	298	execute_command (cmd, 1);
	299
	300	return 1; /* Indicate success */
	301	}
	302
	303	/* This implements the TCL command `gdb_cmd', which sends it's argument into
	304	the GDB command scanner. */
	305
	306	static int
	307	gdb_cmd (clientData, interp, argc, argv)
	308	ClientData clientData;
	309	Tcl_Interp *interp;
	310	int argc;
	311	char *argv[];
	312	{
	313	int val;
	314	struct cleanup *old_chain;
	315
	316	if (argc != 2)
	317	{
	318	Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
	319	return TCL_ERROR;
	320	}
	321
	322	old_chain = make_cleanup (null_routine, 0);
	323
	324	val = catch_errors (gdb_cmd_stub, argv[1], "", RETURN_MASK_ERROR);
	325
479f0f18 SG	326	/* In case of an error, we may need to force the GUI into idle mode because
	327	gdbtk_call_command may have bombed out while in the command routine. */
	328
	329	if (val == 0)
	330	Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
	331
754e5da2 SG	332	bpstat_do_actions (&stop_bpstat);
	333	do_cleanups (old_chain);
	334
8532893d SG	335	/* Drain all buffered command output */
	336
	337	gdb_flush (gdb_stderr);
	338	gdb_flush (gdb_stdout);
	339
754e5da2 SG	340	/* We could base the return value on val, but that would require most users
	341	to use catch. Since GDB errors are already being handled elsewhere, I
	342	see no reason to pass them up to the caller. */
	343
	344	return TCL_OK;
	345	}
	346
	347	static int
	348	gdb_listfiles (clientData, interp, argc, argv)
	349	ClientData clientData;
	350	Tcl_Interp *interp;
	351	int argc;
	352	char *argv[];
	353	{
	354	int val;
	355	struct objfile *objfile;
	356	struct partial_symtab *psymtab;
	357
	358	ALL_PSYMTABS (objfile, psymtab)
	359	Tcl_AppendElement (interp, psymtab->filename);
	360
	361	return TCL_OK;
	362	}
479f0f18 SG	363
	364	static int
	365	gdb_stop (clientData, interp, argc, argv)
	366	ClientData clientData;
	367	Tcl_Interp *interp;
	368	int argc;
	369	char *argv[];
	370	{
6c27841f	371	target_stop ();
479f0f18 SG	372	}
479f0f18 SG	373
754e5da2 SG	374	\f
	375	static void
	376	tk_command (cmd, from_tty)
	377	char *cmd;
	378	int from_tty;
	379	{
	380	Tcl_VarEval (interp, cmd, NULL);
	381
	382	gdbtk_fputs (interp->result);
	383	gdbtk_fputs ("\n");
	384	}
	385
	386	static void
	387	cleanup_init (ignored)
	388	int ignored;
	389	{
	390	if (mainWindow != NULL)
	391	Tk_DestroyWindow (mainWindow);
	392	mainWindow = NULL;
	393
	394	if (interp != NULL)
	395	Tcl_DeleteInterp (interp);
	396	interp = NULL;
	397	}
	398
637b1661 SG	399	/* Come here during long calculations to check for GUI events. Usually invoked
	400	via the QUIT macro. */
	401
	402	static void
	403	gdbtk_interactive ()
	404	{
	405	/* Tk_DoOneEvent (TK_DONT_WAIT\|TK_IDLE_EVENTS); */
	406	}
	407
479f0f18 SG	408	/* Come here when there is activity on the X file descriptor. */
	409
	410	static void
	411	x_event (signo)
	412	int signo;
	413	{
	414	/* Process pending events */
	415
	416	while (Tk_DoOneEvent (TK_DONT_WAIT\|TK_ALL_EVENTS) != 0);
	417	}
	418
	419	static int
	420	gdbtk_wait (pid, ourstatus)
	421	int pid;
	422	struct target_waitstatus *ourstatus;
	423	{
	424	signal (SIGIO, x_event);
	425
	426	pid = target_wait (pid, ourstatus);
	427
	428	signal (SIGIO, SIG_IGN);
	429
	430	return pid;
	431	}
	432
	433	/* This is called from execute_command, and provides a wrapper around
	434	various command routines in a place where both protocol messages and
	435	user input both flow through. Mostly this is used for indicating whether
	436	the target process is running or not.
	437	*/
	438
	439	static void
	440	gdbtk_call_command (cmdblk, arg, from_tty)
	441	struct cmd_list_element *cmdblk;
	442	char *arg;
	443	int from_tty;
	444	{
	445	if (cmdblk->class == class_run)
	446	{
	447	Tcl_VarEval (interp, "gdbtk_tcl_busy", NULL);
	448	(*cmdblk->function.cfunc)(arg, from_tty);
	449	Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
	450	}
	451	else
	452	(*cmdblk->function.cfunc)(arg, from_tty);
	453	}
	454
754e5da2 SG	455	static void
	456	gdbtk_init ()
	457	{
	458	struct cleanup *old_chain;
	459	char *gdbtk_filename;
479f0f18	460	int i;
754e5da2 SG	461
	462	old_chain = make_cleanup (cleanup_init, 0);
	463
	464	/* First init tcl and tk. */
	465
	466	interp = Tcl_CreateInterp ();
	467
	468	if (!interp)
	469	error ("Tcl_CreateInterp failed");
	470
	471	mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");
	472
	473	if (!mainWindow)
	474	return; /* DISPLAY probably not set */
	475
	476	if (Tcl_Init(interp) != TCL_OK)
	477	error ("Tcl_Init failed: %s", interp->result);
	478
	479	if (Tk_Init(interp) != TCL_OK)
	480	error ("Tk_Init failed: %s", interp->result);
	481
	482	Tcl_CreateCommand (interp, "gdb_cmd", gdb_cmd, NULL, NULL);
	483	Tcl_CreateCommand (interp, "gdb_loc", gdb_loc, NULL, NULL);
	484	Tcl_CreateCommand (interp, "gdb_listfiles", gdb_listfiles, NULL, NULL);
479f0f18	485	Tcl_CreateCommand (interp, "gdb_stop", gdb_stop, NULL, NULL);
754e5da2 SG	486
754e5da2 SG	487	gdbtk_filename = getenv ("GDBTK_FILENAME");
8532893d SG	488	if (!gdbtk_filename)
	489	if (access ("gdbtk.tcl", R_OK) == 0)
	490	gdbtk_filename = "gdbtk.tcl";
	491	else
	492	gdbtk_filename = GDBTK_FILENAME;
	493
	494	if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
	495	error ("Failure reading %s: %s", gdbtk_filename, interp->result);
754e5da2	496
cd2df226	497	/* Get the file descriptor for the X server */
479f0f18	498
cd2df226	499	x_fd = ConnectionNumber (Tk_Display (mainWindow));
479f0f18 SG	500
	501	/* Setup for I/O interrupts */
	502
	503	signal (SIGIO, SIG_IGN);
	504
	505	i = fcntl (x_fd, F_GETFL, 0);
	506	fcntl (x_fd, F_SETFL, i\|FASYNC);
	507	fcntl (x_fd, F_SETOWN, getpid());
	508
754e5da2 SG	509	command_loop_hook = Tk_MainLoop;
	510	fputs_unfiltered_hook = gdbtk_fputs;
	511	print_frame_info_listing_hook = null_routine;
	512	query_hook = gdbtk_query;
	513	flush_hook = gdbtk_flush;
	514	create_breakpoint_hook = gdbtk_create_breakpoint;
	515	delete_breakpoint_hook = gdbtk_delete_breakpoint;
	516	enable_breakpoint_hook = gdbtk_enable_breakpoint;
	517	disable_breakpoint_hook = gdbtk_disable_breakpoint;
637b1661	518	interactive_hook = gdbtk_interactive;
479f0f18 SG	519	target_wait_hook = gdbtk_wait;
479f0f18 SG	520	call_command_hook = gdbtk_call_command;
754e5da2 SG	521
	522	discard_cleanups (old_chain);
	523
	524	add_com ("tk", class_obscure, tk_command,
	525	"Send a command directly into tk.");
	526	}
	527
	528	/* Come here during initialze_all_files () */
	529
	530	void
	531	_initialize_gdbtk ()
	532	{
c5197511 SG	533	if (use_windows)
	534	{
	535	/* Tell the rest of the world that Gdbtk is now set up. */
754e5da2	536
c5197511 SG	537	init_ui_hook = gdbtk_init;
c5197511 SG	538	}
754e5da2	539	}