gdb/gdbtk.c

   1 /* Startup code for gdbtk.
   2    Copyright 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
   3
   4    Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
   5
   6 This file is part of GDB.
   7
   8 This program is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2 of the License, or
  11 (at your option) any later version.
  12
  13 This program is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with this program; if not, write to the Free Software
  20 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
  21
  22 #include "defs.h"
  23 #include "symtab.h"
  24 #include "inferior.h"
  25 #include "command.h"
  26 #include "bfd.h"
  27 #include "symfile.h"
  28 #include "objfiles.h"
  29 #include "target.h"
  30 #include "gdbcore.h"
  31 #include "tracepoint.h"
  32 #include "demangle.h"
  33
  34 #ifdef _WIN32
  35 #include <winuser.h>
  36 #endif
  37
  38 #include <sys/stat.h>
  39
  40 #include <tcl.h>
  41 #include <tk.h>
  42 #include <itcl.h>
  43 #include <tix.h>
  44 #include "guitcl.h"
  45 #include "gdbtk.h"
  46
  47 #ifdef IDE
  48 /* start-sanitize-ide */
  49 #include "event.h"
  50 #include "idetcl.h"
  51 #include "ilutk.h"
  52 /* end-sanitize-ide */
  53 #endif
  54
  55 #ifdef ANSI_PROTOTYPES
  56 #include <stdarg.h>
  57 #else
  58 #include <varargs.h>
  59 #endif
  60 #include <signal.h>
  61 #include <fcntl.h>
  62 #include <unistd.h>
  63 #include <setjmp.h>
  64 #include "top.h"
  65 #include <sys/ioctl.h>
  66 #include "gdb_string.h"
  67 #include "dis-asm.h"
  68 #include <stdio.h>
  69 #include "gdbcmd.h"
  70
  71 #include "annotate.h"
  72 #include <sys/time.h>
  73
  74 #ifdef __CYGWIN__
  75 #include <sys/cygwin.h> /* for cygwin32_attach_handle_to_fd */
  76 #endif
  77
  78 /* For Cygwin, we use a timer to periodically check for Windows
  79    messages.  FIXME: It would be better to not poll, but to instead
  80    rewrite the target_wait routines to serve as input sources.
  81    Unfortunately, that will be a lot of work.  */
  82 static sigset_t nullsigmask;
  83 static struct sigaction act1, act2;
  84 static struct itimerval it_on, it_off;
  85
  86 extern int Tktable_Init PARAMS ((Tcl_Interp *interp));
  87
  88 static void gdbtk_init PARAMS ((char *));
  89 void gdbtk_interactive PARAMS ((void));
  90 static void cleanup_init PARAMS ((int));
  91 static void tk_command PARAMS ((char *, int));
  92
  93 void gdbtk_add_hooks PARAMS ((void));
  94 int gdbtk_test PARAMS ((char *));
  95
  96 /*
  97  * gdbtk_fputs is defined in the gdbtk_hooks.c, but we need it here
  98  * because we delay adding this hook till all the setup is done.  That
  99  * way errors will go to stdout.
 100  */
 101
 102 extern void   gdbtk_fputs PARAMS ((const char *, GDB_FILE *));
 103
 104 /* Handle for TCL interpreter */
 105 Tcl_Interp *gdbtk_interp = NULL;
 106
 107 static int gdbtk_timer_going = 0;
 108
 109 /* linked variable used to tell tcl what the current thread is */
 110 int gdb_context = 0;
 111
 112 /* This variable is true when the inferior is running.  See note in
 113  * gdbtk.h for details.
 114  */
 115 int running_now;
 116
 117 /* This variable holds the name of a Tcl file which should be sourced by the
 118    interpreter when it goes idle at startup. Used with the testsuite. */
 119 static char *gdbtk_source_filename = NULL;
 120 \f
 121 #ifndef _WIN32
 122
 123 /* Supply malloc calls for tcl/tk.  We do not want to do this on
 124    Windows, because Tcl_Alloc is probably in a DLL which will not call
 125    the mmalloc routines.  */
 126
 127 char *
 128 Tcl_Alloc (size)
 129      unsigned int size;
 130 {
 131   return xmalloc (size);
 132 }
 133
 134 char *
 135 Tcl_Realloc (ptr, size)
 136      char *ptr;
 137      unsigned int size;
 138 {
 139   return xrealloc (ptr, size);
 140 }
 141
 142 void
 143 Tcl_Free(ptr)
 144      char *ptr;
 145 {
 146   free (ptr);
 147 }
 148
 149 #endif /* ! _WIN32 */
 150
 151 #ifdef _WIN32
 152
 153 /* On Windows, if we hold a file open, other programs can't write to
 154  * it.  In particular, we don't want to hold the executable open,
 155  * because it will mean that people have to get out of the debugging
 156  * session in order to remake their program.  So we close it, although
 157  * this will cost us if and when we need to reopen it.
 158  */
 159
 160 void
 161 close_bfds ()
 162 {
 163   struct objfile *o;
 164
 165   ALL_OBJFILES (o)
 166     {
 167       if (o->obfd != NULL)
 168         bfd_cache_close (o->obfd);
 169     }
 170
 171   if (exec_bfd != NULL)
 172     bfd_cache_close (exec_bfd);
 173 }
 174
 175 #endif /* _WIN32 */
 176
 177 \f
 178 /* TclDebug (const char *fmt, ...) works just like printf() but
 179  * sends the output to the GDB TK debug window.
 180  * Not for normal use; just a convenient tool for debugging
 181  */
 182
 183 void
 184 #ifdef ANSI_PROTOTYPES
 185 TclDebug (const char *fmt, ...)
 186 #else
 187 TclDebug (va_alist)
 188      va_dcl
 189 #endif
 190 {
 191   va_list args;
 192   char buf[512], *v[2], *merge;
 193
 194 #ifdef ANSI_PROTOTYPES
 195   va_start (args, fmt);
 196 #else
 197   char *fmt;
 198   va_start (args);
 199   fmt = va_arg (args, char *);
 200 #endif
 201
 202   v[0] = "debug";
 203   v[1] = buf;
 204
 205   vsprintf (buf, fmt, args);
 206   va_end (args);
 207
 208   merge = Tcl_Merge (2, v);
 209   Tcl_Eval (gdbtk_interp, merge);
 210   Tcl_Free (merge);
 211 }
 212
 213 \f
 214 /*
 215  * The rest of this file contains the start-up, and event handling code for gdbtk.
 216  */
 217
 218 /*
 219  * This cleanup function is added to the cleanup list that surrounds the Tk
 220  * main in gdbtk_init.  It deletes the Tcl interpreter.
 221  */
 222
 223 static void
 224 cleanup_init (ignored)
 225      int ignored;
 226 {
 227   if (gdbtk_interp != NULL)
 228     Tcl_DeleteInterp (gdbtk_interp);
 229   gdbtk_interp = NULL;
 230 }
 231
 232 /* Come here during long calculations to check for GUI events.  Usually invoked
 233    via the QUIT macro.  */
 234
 235 void
 236 gdbtk_interactive ()
 237 {
 238   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
 239 }
 240
 241
 242 void
 243 gdbtk_start_timer ()
 244 {
 245   static int first = 1;
 246   /*TclDebug ("Starting timer....");*/
 247   if (first)
 248     {
 249       /* first time called, set up all the structs */
 250       first = 0;
 251       sigemptyset (&nullsigmask);
 252
 253       act1.sa_handler = x_event;
 254       act1.sa_mask = nullsigmask;
 255       act1.sa_flags = 0;
 256
 257       act2.sa_handler = SIG_IGN;
 258       act2.sa_mask = nullsigmask;
 259       act2.sa_flags = 0;
 260
 261       it_on.it_interval.tv_sec = 0;
 262       it_on.it_interval.tv_usec = 250000; /* .25 sec */
 263       it_on.it_value.tv_sec = 0;
 264       it_on.it_value.tv_usec = 250000;
 265
 266       it_off.it_interval.tv_sec = 0;
 267       it_off.it_interval.tv_usec = 0;
 268       it_off.it_value.tv_sec = 0;
 269       it_off.it_value.tv_usec = 0;
 270     }
 271
 272   if (!gdbtk_timer_going)
 273     {
 274       sigaction (SIGALRM, &act1, NULL);
 275       setitimer (ITIMER_REAL, &it_on, NULL);
 276       gdbtk_timer_going = 1;
 277     }
 278 }
 279
 280 void
 281 gdbtk_stop_timer ()
 282 {
 283   if (gdbtk_timer_going)
 284     {
 285       gdbtk_timer_going = 0;
 286       /*TclDebug ("Stopping timer.");*/
 287       setitimer (ITIMER_REAL, &it_off, NULL);
 288       sigaction (SIGALRM, &act2, NULL);
 289     }
 290 }
 291
 292 /* gdbtk_init installs this function as a final cleanup.  */
 293
 294 static void
 295 gdbtk_cleanup (dummy)
 296      PTR dummy;
 297 {
 298   Tcl_Eval (gdbtk_interp, "gdbtk_cleanup");
 299 #ifdef IDE
 300   {
 301     struct ide_event_handle *h = (struct ide_event_handle *) dummy;
 302     ide_interface_deregister_all (h);
 303   }
 304 #endif
 305   Tcl_Finalize ();
 306 }
 307
 308 /* Initialize gdbtk.  This involves creating a Tcl interpreter,
 309  * defining all the Tcl commands that the GUI will use, pointing
 310  * all the gdb "hooks" to the correct functions,
 311  * and setting the Tcl auto loading environment so that we can find all
 312  * the Tcl based library files.
 313  */
 314
 315 static void
 316 gdbtk_init ( argv0 )
 317      char *argv0;
 318 {
 319   struct cleanup *old_chain;
 320   char *lib, *gdbtk_lib, *gdbtk_lib_tmp, *gdbtk_file;
 321   int found_main;
 322   Tcl_Obj *auto_path_elem, *auto_path_name;
 323
 324 #ifdef IDE
 325   /* start-sanitize-ide */
 326   struct ide_event_handle *h;
 327   const char *errmsg;
 328   char *libexecdir;
 329   /* end-sanitize-ide */
 330 #endif
 331
 332   /* If there is no DISPLAY environment variable, Tk_Init below will fail,
 333      causing gdb to abort.  If instead we simply return here, gdb will
 334      gracefully degrade to using the command line interface. */
 335
 336 #ifndef _WIN32
 337   if (getenv ("DISPLAY") == NULL)
 338     return;
 339 #endif
 340
 341   old_chain = make_cleanup ((make_cleanup_func) cleanup_init, 0);
 342
 343   /* First init tcl and tk. */
 344   Tcl_FindExecutable (argv0);
 345   gdbtk_interp = Tcl_CreateInterp ();
 346
 347 #ifdef TCL_MEM_DEBUG
 348   Tcl_InitMemory (gdbtk_interp);
 349 #endif
 350
 351   if (!gdbtk_interp)
 352     error ("Tcl_CreateInterp failed");
 353
 354   if (Tcl_Init(gdbtk_interp) != TCL_OK)
 355     error ("Tcl_Init failed: %s", gdbtk_interp->result);
 356
 357 #ifndef IDE
 358   /* For the IDE we register the cleanup later, after we've
 359      initialized events.  */
 360   make_final_cleanup (gdbtk_cleanup,  NULL);
 361 #endif
 362
 363   /* Initialize the Paths variable.  */
 364   if (ide_initialize_paths (gdbtk_interp, "gdbtcl") != TCL_OK)
 365     error ("ide_initialize_paths failed: %s", gdbtk_interp->result);
 366
 367 #ifdef IDE
 368   /* start-sanitize-ide */
 369   /* Find the directory where we expect to find idemanager.  We ignore
 370      errors since it doesn't really matter if this fails.  */
 371   libexecdir = Tcl_GetVar2 (gdbtk_interp, "Paths", "libexecdir", TCL_GLOBAL_ONLY);
 372
 373   IluTk_Init ();
 374
 375   h = ide_event_init_from_environment (&errmsg, libexecdir);
 376   make_final_cleanup (gdbtk_cleanup, h);
 377   if (h == NULL)
 378     {
 379       Tcl_AppendResult (gdbtk_interp, "can't initialize event system: ", errmsg,
 380                         (char *) NULL);
 381       fprintf(stderr, "WARNING: ide_event_init_client failed: %s\n", gdbtk_interp->result);
 382
 383       Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "0", 0);
 384     }
 385   else
 386     {
 387       if (ide_create_tclevent_command (gdbtk_interp, h) != TCL_OK)
 388         error ("ide_create_tclevent_command failed: %s", gdbtk_interp->result);
 389
 390       if (ide_create_edit_command (gdbtk_interp, h) != TCL_OK)
 391         error ("ide_create_edit_command failed: %s", gdbtk_interp->result);
 392
 393       if (ide_create_property_command (gdbtk_interp, h) != TCL_OK)
 394         error ("ide_create_property_command failed: %s", gdbtk_interp->result);
 395
 396       if (ide_create_build_command (gdbtk_interp, h) != TCL_OK)
 397         error ("ide_create_build_command failed: %s", gdbtk_interp->result);
 398
 399       if (ide_create_window_register_command (gdbtk_interp, h, "gdb-restore")
 400           != TCL_OK)
 401         error ("ide_create_window_register_command failed: %s",
 402                gdbtk_interp->result);
 403
 404       if (ide_create_window_command (gdbtk_interp, h) != TCL_OK)
 405         error ("ide_create_window_command failed: %s", gdbtk_interp->result);
 406
 407       if (ide_create_exit_command (gdbtk_interp, h) != TCL_OK)
 408         error ("ide_create_exit_command failed: %s", gdbtk_interp->result);
 409
 410       if (ide_create_help_command (gdbtk_interp) != TCL_OK)
 411         error ("ide_create_help_command failed: %s", gdbtk_interp->result);
 412
 413       /*
 414         if (ide_initialize (gdbtk_interp, "gdb") != TCL_OK)
 415         error ("ide_initialize failed: %s", gdbtk_interp->result);
 416       */
 417
 418       Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "1", 0);
 419     }
 420   /* end-sanitize-ide */
 421 #else
 422   Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "0", 0);
 423 #endif /* IDE */
 424
 425   /* We don't want to open the X connection until we've done all the
 426      IDE initialization.  Otherwise, goofy looking unfinished windows
 427      pop up when ILU drops into the TCL event loop.  */
 428
 429   if (Tk_Init(gdbtk_interp) != TCL_OK)
 430     error ("Tk_Init failed: %s", gdbtk_interp->result);
 431
 432   if (Itcl_Init(gdbtk_interp) == TCL_ERROR)
 433     error ("Itcl_Init failed: %s", gdbtk_interp->result);
 434   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 435                     (Tcl_PackageInitProc *) NULL);
 436
 437   if (Tix_Init(gdbtk_interp) != TCL_OK)
 438     error ("Tix_Init failed: %s", gdbtk_interp->result);
 439   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 440                     (Tcl_PackageInitProc *) NULL);
 441
 442   if (Tktable_Init(gdbtk_interp) != TCL_OK)
 443     error ("Tktable_Init failed: %s", gdbtk_interp->result);
 444
 445   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 446                     (Tcl_PackageInitProc *) NULL);
 447   /*
 448    * These are the commands to do some Windows Specific stuff...
 449    */
 450
 451 #ifdef __CYGWIN__
 452   if (ide_create_messagebox_command (gdbtk_interp) != TCL_OK)
 453     error ("messagebox command initialization failed");
 454   /* On Windows, create a sizebox widget command */
 455   if (ide_create_sizebox_command (gdbtk_interp) != TCL_OK)
 456     error ("sizebox creation failed");
 457   if (ide_create_winprint_command (gdbtk_interp) != TCL_OK)
 458     error ("windows print code initialization failed");
 459   /* start-sanitize-ide */
 460   /* An interface to ShellExecute.  */
 461   if (ide_create_shell_execute_command (gdbtk_interp) != TCL_OK)
 462     error ("shell execute command initialization failed");
 463   /* end-sanitize-ide */
 464   if (ide_create_win_grab_command (gdbtk_interp) != TCL_OK)
 465     error ("grab support command initialization failed");
 466   /* Path conversion functions.  */
 467   if (ide_create_cygwin_path_command (gdbtk_interp) != TCL_OK)
 468     error ("cygwin path command initialization failed");
 469 #endif
 470
 471   /*
 472    * This adds all the Gdbtk commands.
 473    */
 474
 475   if (Gdbtk_Init(gdbtk_interp) != TCL_OK)
 476     {
 477        error("Gdbtk_Init failed: %s", gdbtk_interp->result);
 478     }
 479
 480   Tcl_StaticPackage(gdbtk_interp, "Gdbtk", Gdbtk_Init, NULL);
 481
 482   /* This adds all the hooks that call up from the bowels of gdb
 483    *  back into Tcl-land...
 484    */
 485
 486   gdbtk_add_hooks();
 487
 488   /* Add a back door to Tk from the gdb console... */
 489
 490   add_com ("tk", class_obscure, tk_command,
 491            "Send a command directly into tk.");
 492
 493   /* find the gdb tcl library and source main.tcl */
 494
 495   gdbtk_lib = getenv ("GDBTK_LIBRARY");
 496   if (!gdbtk_lib)
 497     {
 498       if (access ("gdbtcl/main.tcl", R_OK) == 0)
 499         gdbtk_lib = "gdbtcl";
 500       else
 501         gdbtk_lib = GDBTK_LIBRARY;
 502     }
 503
 504   gdbtk_lib_tmp = xstrdup (gdbtk_lib);
 505
 506   found_main = 0;
 507   /* see if GDBTK_LIBRARY is a path list */
 508   lib = strtok (gdbtk_lib_tmp, GDBTK_PATH_SEP);
 509
 510   auto_path_name = Tcl_NewStringObj ("auto_path", -1);
 511
 512   do
 513     {
 514       auto_path_elem = Tcl_NewStringObj (lib, -1);
 515       if (Tcl_ObjSetVar2 (gdbtk_interp, auto_path_name, NULL, auto_path_elem,
 516                           TCL_GLOBAL_ONLY | TCL_APPEND_VALUE | TCL_LIST_ELEMENT ) == NULL)
 517         {
 518           fputs_unfiltered (Tcl_GetVar (gdbtk_interp, "errorInfo", 0), gdb_stderr);
 519           error ("");
 520         }
 521       if (!found_main)
 522         {
 523           gdbtk_file = concat (lib, "/main.tcl", (char *) NULL);
 524           if (access (gdbtk_file, R_OK) == 0)
 525             {
 526               found_main++;
 527               Tcl_SetVar (gdbtk_interp, "GDBTK_LIBRARY", lib, 0);
 528             }
 529         }
 530      }
 531   while ((lib = strtok (NULL, ":")) != NULL);
 532
 533   free (gdbtk_lib_tmp);
 534   Tcl_DecrRefCount(auto_path_name);
 535
 536   if (!found_main)
 537     {
 538       /* Try finding it with the auto path.  */
 539
 540       static const char script[] ="\
 541 proc gdbtk_find_main {} {\n\
 542   global auto_path GDBTK_LIBRARY\n\
 543   foreach dir $auto_path {\n\
 544     set f [file join $dir main.tcl]\n\
 545     if {[file exists $f]} then {\n\
 546       set GDBTK_LIBRARY $dir\n\
 547       return $f\n\
 548     }\n\
 549   }\n\
 550   return ""\n\
 551 }\n\
 552 gdbtk_find_main";
 553
 554       if (Tcl_GlobalEval (gdbtk_interp, (char *) script) != TCL_OK)
 555         {
 556           fputs_unfiltered (Tcl_GetVar (gdbtk_interp, "errorInfo", 0), gdb_stderr);
 557           error ("");
 558         }
 559
 560       if (gdbtk_interp->result[0] != '\0')
 561         {
 562           gdbtk_file = xstrdup (gdbtk_interp->result);
 563           found_main++;
 564         }
 565     }
 566
 567   if (!found_main)
 568     {
 569       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
 570       if (getenv("GDBTK_LIBRARY"))
 571         {
 572           fprintf_unfiltered (gdb_stderr, "Unable to find main.tcl in %s\n",
 573                               getenv("GDBTK_LIBRARY"));
 574           fprintf_unfiltered (gdb_stderr,
 575                               "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
 576         }
 577       else
 578         {
 579           fprintf_unfiltered (gdb_stderr,
 580                               "Unable to find main.tcl in %s\n", GDBTK_LIBRARY);
 581           fprintf_unfiltered (gdb_stderr,
 582                               "You might want to set GDBTK_LIBRARY\n");
 583         }
 584       error("");
 585     }
 586
 587 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
 588    prior to this point go to stdout/stderr.  */
 589
 590   fputs_unfiltered_hook = gdbtk_fputs;
 591
 592 /* start-sanitize-tclpro */
 593 #ifdef TCLPRO_DEBUGGER
 594   {
 595     Tcl_DString source_cmd;
 596
 597     Tcl_DStringInit (&source_cmd);
 598     Tcl_DStringAppend (&source_cmd,
 599                       "if {[info exists env(DEBUG_STUB)]} {source $env(DEBUG_STUB); " -1);
 600     Tcl_DStringAppend (&source_cmd, "debugger_init; debugger_eval {source {", -1);
 601     Tcl_DStringAppend (&source_cmd, gdbtk_file, -1);
 602     Tcl_DStringAppend (&source_cmd, "}}} else {source {", -1);
 603     Tcl_DStringAppend (&source_cmd, gdbtk_file, -1);
 604     Tcl_DStringAppend (&source_cmd, "}}", -1);
 605     if (Tcl_GlobalEval (gdbtk_interp, Tcl_DStringValue (&source_cmd)) != TCL_OK)
 606 #else
 607 /* end-sanitize-tclpro */
 608       if (Tcl_EvalFile (gdbtk_interp, gdbtk_file) != TCL_OK)
 609 /* start-sanitize-tclpro */
 610 #endif
 611 /* end-sanitize-tclpro */
 612         {
 613       char *msg;
 614
 615       /* Force errorInfo to be set up propertly.  */
 616       Tcl_AddErrorInfo (gdbtk_interp, "");
 617
 618       msg = Tcl_GetVar (gdbtk_interp, "errorInfo", TCL_GLOBAL_ONLY);
 619
 620       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
 621
 622 #ifdef _WIN32
 623       MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
 624 #else
 625       fputs_unfiltered (msg, gdb_stderr);
 626 #endif
 627
 628       error ("");
 629     }
 630 /* start-sanitize-tclpro */
 631 #ifdef TCLPRO_DEBUGGER
 632       Tcl_DStringFree(&source_cmd);
 633     }
 634 #endif
 635 /* end-sanitize-tclpro */
 636
 637 #ifdef IDE
 638   /* start-sanitize-ide */
 639   /* Don't do this until we have initialized.  Otherwise, we may get a
 640      run command before we are ready for one.  */
 641   if (ide_run_server_init (gdbtk_interp, h) != TCL_OK)
 642     error ("ide_run_server_init failed: %s", gdbtk_interp->result);
 643   /* end-sanitize-ide */
 644 #endif
 645
 646   free (gdbtk_file);
 647
 648   /* Now source in the filename provided by the --tclcommand option.
 649      This is mostly used for the gdbtk testsuite... */
 650
 651   if (gdbtk_source_filename != NULL)
 652     {
 653       char *s = "after idle source ";
 654       char *script = concat (s, gdbtk_source_filename, (char *) NULL);
 655       Tcl_Eval (gdbtk_interp, script);
 656       free (gdbtk_source_filename);
 657       free (script);
 658     }
 659
 660
 661   discard_cleanups (old_chain);
 662 }
 663
 664 /* gdbtk_test is used in main.c to validate the -tclcommand option to
 665    gdb, which sources in a file of tcl code after idle during the
 666    startup procedure. */
 667
 668 int
 669 gdbtk_test (filename)
 670      char *filename;
 671 {
 672   if (access (filename, R_OK) != 0)
 673     return 0;
 674   else
 675     gdbtk_source_filename = xstrdup (filename);
 676   return 1;
 677 }
 678
 679 /* Come here during initialize_all_files () */
 680
 681 void
 682 _initialize_gdbtk ()
 683 {
 684   if (use_windows)
 685     {
 686       /* Tell the rest of the world that Gdbtk is now set up. */
 687
 688       init_ui_hook = gdbtk_init;
 689 #ifdef __CYGWIN__
 690       (void) FreeConsole ();
 691 #endif
 692     }
 693 #ifdef __CYGWIN__
 694   else
 695     {
 696       DWORD ft = GetFileType (GetStdHandle (STD_INPUT_HANDLE));
 697
 698       switch (ft)
 699         {
 700           case FILE_TYPE_DISK:
 701           case FILE_TYPE_CHAR:
 702           case FILE_TYPE_PIPE:
 703             break;
 704           default:
 705             AllocConsole();
 706             cygwin32_attach_handle_to_fd ("/dev/conin", 0,
 707                                           GetStdHandle (STD_INPUT_HANDLE),
 708                                           1, GENERIC_READ);
 709             cygwin32_attach_handle_to_fd ("/dev/conout", 1,
 710                                           GetStdHandle (STD_OUTPUT_HANDLE),
 711                                           0, GENERIC_WRITE);
 712             cygwin32_attach_handle_to_fd ("/dev/conout", 2,
 713                                           GetStdHandle (STD_ERROR_HANDLE),
 714                                           0, GENERIC_WRITE);
 715             break;
 716         }
 717     }
 718 #endif
 719 }
 720
 721 static void
 722 tk_command (cmd, from_tty)
 723      char *cmd;
 724      int from_tty;
 725 {
 726   int retval;
 727   char *result;
 728   struct cleanup *old_chain;
 729
 730   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
 731   if (cmd == NULL)
 732     error_no_arg ("tcl command to interpret");
 733
 734   retval = Tcl_Eval (gdbtk_interp, cmd);
 735
 736   result = strdup (gdbtk_interp->result);
 737
 738   old_chain = make_cleanup (free, result);
 739
 740   if (retval != TCL_OK)
 741     error (result);
 742
 743   printf_unfiltered ("%s\n", result);
 744
 745   do_cleanups (old_chain);
 746 }
 747