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 /* start-sanitize-ide */
  48 #ifdef IDE
  49 #include "event.h"
  50 #include "idetcl.h"
  51 #include "ilutk.h"
  52 #endif
  53 /* end-sanitize-ide */
  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 __CYGWIN32__
  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  /*
  87   * These two variables control the interaction with an external editor.
  88   * If enable_external_editor is set at startup, BEFORE Gdbtk_Init is run
  89   * then the Tcl variable of the same name will be set, and a command will
  90   * called external_editor_command will be invoked to call out to the
  91   * external editor.  We give a dummy version here to warn if it is not set.
  92   */
  93 int enable_external_editor = 0;
  94 char * external_editor_command = "tk_dialog .warn-external \\\n\
  95 \"No command is specified.\nUse --tclcommand <tcl/file> or --external-editor <cmd> to specify a new command\" 0 Ok";
  96
  97 extern int Tktable_Init PARAMS ((Tcl_Interp *interp));
  98
  99 static void gdbtk_init PARAMS ((char *));
 100 void gdbtk_interactive PARAMS ((void));
 101 static void cleanup_init PARAMS ((int));
 102 static void tk_command PARAMS ((char *, int));
 103
 104 void gdbtk_add_hooks PARAMS ((void));
 105 int gdbtk_test PARAMS ((char *));
 106
 107 /*
 108  * gdbtk_fputs is defined in the gdbtk_hooks.c, but we need it here
 109  * because we delay adding this hook till all the setup is done.  That
 110  * way errors will go to stdout.
 111  */
 112
 113 extern void   gdbtk_fputs PARAMS ((const char *, GDB_FILE *));
 114
 115 /* Handle for TCL interpreter */
 116 Tcl_Interp *gdbtk_interp = NULL;
 117
 118 static int gdbtk_timer_going = 0;
 119
 120 /* linked variable used to tell tcl what the current thread is */
 121 int gdb_context = 0;
 122
 123 /* This variable is true when the inferior is running.  See note in
 124  * gdbtk.h for details.
 125  */
 126 int running_now;
 127
 128 /* This variable holds the name of a Tcl file which should be sourced by the
 129    interpreter when it goes idle at startup. Used with the testsuite. */
 130 static char *gdbtk_source_filename = NULL;
 131 \f
 132 #ifndef _WIN32
 133
 134 /* Supply malloc calls for tcl/tk.  We do not want to do this on
 135    Windows, because Tcl_Alloc is probably in a DLL which will not call
 136    the mmalloc routines.
 137    We also don't need to do it for Tcl/Tk8.1, since we locally changed the
 138    allocator to use malloc & free. */
 139
 140 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
 141 char *
 142 TclpAlloc (size)
 143      unsigned int size;
 144 {
 145   return xmalloc (size);
 146 }
 147
 148 char *
 149 TclpRealloc (ptr, size)
 150      char *ptr;
 151      unsigned int size;
 152 {
 153   return xrealloc (ptr, size);
 154 }
 155
 156 void
 157 TclpFree(ptr)
 158      char *ptr;
 159 {
 160   free (ptr);
 161 }
 162 #endif /* TCL_VERSION == 8.0 */
 163
 164 #endif /* ! _WIN32 */
 165
 166 #ifdef _WIN32
 167
 168 /* On Windows, if we hold a file open, other programs can't write to
 169  * it.  In particular, we don't want to hold the executable open,
 170  * because it will mean that people have to get out of the debugging
 171  * session in order to remake their program.  So we close it, although
 172  * this will cost us if and when we need to reopen it.
 173  */
 174
 175 void
 176 close_bfds ()
 177 {
 178   struct objfile *o;
 179
 180   ALL_OBJFILES (o)
 181     {
 182       if (o->obfd != NULL)
 183         bfd_cache_close (o->obfd);
 184     }
 185
 186   if (exec_bfd != NULL)
 187     bfd_cache_close (exec_bfd);
 188 }
 189
 190 #endif /* _WIN32 */
 191
 192 \f
 193 /* TclDebug (const char *fmt, ...) works just like printf() but
 194  * sends the output to the GDB TK debug window.
 195  * Not for normal use; just a convenient tool for debugging
 196  */
 197
 198 void
 199 TclDebug (char level, const char *fmt, ...)
 200 {
 201   va_list args;
 202   char buf[512], *v[3], *merge, *priority;
 203
 204   switch (level)
 205     {
 206     case 'W':
 207       priority = "W";
 208       break;
 209     case 'E':
 210       priority = "E";
 211       break;
 212     case 'X':
 213       priority = "X";
 214       break;
 215     default:
 216       priority = "I";
 217     }
 218
 219   va_start (args, fmt);
 220
 221   v[0] = "dbug";
 222   v[1] = priority;
 223   v[2] = buf;
 224
 225   vsprintf (buf, fmt, args);
 226   va_end (args);
 227
 228   merge = Tcl_Merge (3, v);
 229   if (Tcl_Eval (gdbtk_interp, merge) != TCL_OK)
 230     Tcl_BackgroundError(gdbtk_interp);
 231   Tcl_Free (merge);
 232 }
 233
 234 \f
 235 /*
 236  * The rest of this file contains the start-up, and event handling code for gdbtk.
 237  */
 238
 239 /*
 240  * This cleanup function is added to the cleanup list that surrounds the Tk
 241  * main in gdbtk_init.  It deletes the Tcl interpreter.
 242  */
 243
 244 static void
 245 cleanup_init (ignored)
 246      int ignored;
 247 {
 248   if (gdbtk_interp != NULL)
 249     Tcl_DeleteInterp (gdbtk_interp);
 250   gdbtk_interp = NULL;
 251 }
 252
 253 /* Come here during long calculations to check for GUI events.  Usually invoked
 254    via the QUIT macro.  */
 255
 256 void
 257 gdbtk_interactive ()
 258 {
 259   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
 260 }
 261
 262
 263 void
 264 gdbtk_start_timer ()
 265 {
 266   static int first = 1;
 267   /*TclDebug ("Starting timer....");*/
 268   if (first)
 269     {
 270       /* first time called, set up all the structs */
 271       first = 0;
 272       sigemptyset (&nullsigmask);
 273
 274       act1.sa_handler = x_event;
 275       act1.sa_mask = nullsigmask;
 276       act1.sa_flags = 0;
 277
 278       act2.sa_handler = SIG_IGN;
 279       act2.sa_mask = nullsigmask;
 280       act2.sa_flags = 0;
 281
 282       it_on.it_interval.tv_sec = 0;
 283       it_on.it_interval.tv_usec = 250000; /* .25 sec */
 284       it_on.it_value.tv_sec = 0;
 285       it_on.it_value.tv_usec = 250000;
 286
 287       it_off.it_interval.tv_sec = 0;
 288       it_off.it_interval.tv_usec = 0;
 289       it_off.it_value.tv_sec = 0;
 290       it_off.it_value.tv_usec = 0;
 291     }
 292
 293   if (!gdbtk_timer_going)
 294     {
 295       sigaction (SIGALRM, &act1, NULL);
 296       setitimer (ITIMER_REAL, &it_on, NULL);
 297       gdbtk_timer_going = 1;
 298     }
 299 }
 300
 301 void
 302 gdbtk_stop_timer ()
 303 {
 304   if (gdbtk_timer_going)
 305     {
 306       gdbtk_timer_going = 0;
 307       /*TclDebug ("Stopping timer.");*/
 308       setitimer (ITIMER_REAL, &it_off, NULL);
 309       sigaction (SIGALRM, &act2, NULL);
 310     }
 311 }
 312
 313 /* gdbtk_init installs this function as a final cleanup.  */
 314
 315 static void
 316 gdbtk_cleanup (dummy)
 317      PTR dummy;
 318 {
 319   Tcl_Eval (gdbtk_interp, "gdbtk_cleanup");
 320 #ifdef IDE
 321   {
 322     struct ide_event_handle *h = (struct ide_event_handle *) dummy;
 323     ide_interface_deregister_all (h);
 324   }
 325 #endif
 326   Tcl_Finalize ();
 327 }
 328
 329 /* Initialize gdbtk.  This involves creating a Tcl interpreter,
 330  * defining all the Tcl commands that the GUI will use, pointing
 331  * all the gdb "hooks" to the correct functions,
 332  * and setting the Tcl auto loading environment so that we can find all
 333  * the Tcl based library files.
 334  */
 335
 336 static void
 337 gdbtk_init ( argv0 )
 338      char *argv0;
 339 {
 340   struct cleanup *old_chain;
 341   int found_main;
 342   char s[5];
 343   Tcl_Obj *auto_path_elem, *auto_path_name;
 344
 345   /* start-sanitize-ide */
 346 #ifdef IDE
 347   struct ide_event_handle *h;
 348   const char *errmsg;
 349   char *libexecdir;
 350 #endif
 351   /* end-sanitize-ide */
 352
 353   /* If there is no DISPLAY environment variable, Tk_Init below will fail,
 354      causing gdb to abort.  If instead we simply return here, gdb will
 355      gracefully degrade to using the command line interface. */
 356
 357 #ifndef _WIN32
 358   if (getenv ("DISPLAY") == NULL)
 359     return;
 360 #endif
 361
 362   old_chain = make_cleanup ((make_cleanup_func) cleanup_init, 0);
 363
 364   /* First init tcl and tk. */
 365   Tcl_FindExecutable (argv0);
 366   gdbtk_interp = Tcl_CreateInterp ();
 367
 368 #ifdef TCL_MEM_DEBUG
 369   Tcl_InitMemory (gdbtk_interp);
 370 #endif
 371
 372   if (!gdbtk_interp)
 373     error ("Tcl_CreateInterp failed");
 374
 375   if (Tcl_Init(gdbtk_interp) != TCL_OK)
 376     error ("Tcl_Init failed: %s", gdbtk_interp->result);
 377
 378   /* Set up some globals used by gdb to pass info to gdbtk
 379      for start up options and the like */
 380   sprintf (s, "%d", inhibit_gdbinit);
 381   Tcl_SetVar2 (gdbtk_interp, "GDBStartup", "inhibit_prefs", s, TCL_GLOBAL_ONLY);
 382
 383   /* start-sanitize-ide */
 384 #ifndef IDE
 385   /* end-sanitize-ide */
 386   /* For the IDE we register the cleanup later, after we've
 387      initialized events.  */
 388   make_final_cleanup (gdbtk_cleanup,  NULL);
 389   /* start-sanitize-ide */
 390 #endif /* IDE */
 391   /* end-sanitize-ide */
 392
 393   /* Initialize the Paths variable.  */
 394   if (ide_initialize_paths (gdbtk_interp, "") != TCL_OK)
 395     error ("ide_initialize_paths failed: %s", gdbtk_interp->result);
 396
 397   /* start-sanitize-ide */
 398 #ifdef IDE
 399   /* Find the directory where we expect to find idemanager.  We ignore
 400      errors since it doesn't really matter if this fails.  */
 401   libexecdir = Tcl_GetVar2 (gdbtk_interp, "Paths", "libexecdir", TCL_GLOBAL_ONLY);
 402
 403   IluTk_Init ();
 404
 405   h = ide_event_init_from_environment (&errmsg, libexecdir);
 406   make_final_cleanup (gdbtk_cleanup, h);
 407   if (h == NULL)
 408     {
 409       Tcl_AppendResult (gdbtk_interp, "can't initialize event system: ", errmsg,
 410                         (char *) NULL);
 411       fprintf(stderr, "WARNING: ide_event_init_client failed: %s\n", gdbtk_interp->result);
 412
 413       Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "0", 0);
 414     }
 415   else
 416     {
 417       if (ide_create_tclevent_command (gdbtk_interp, h) != TCL_OK)
 418         error ("ide_create_tclevent_command failed: %s", gdbtk_interp->result);
 419
 420       if (ide_create_edit_command (gdbtk_interp, h) != TCL_OK)
 421         error ("ide_create_edit_command failed: %s", gdbtk_interp->result);
 422
 423       if (ide_create_property_command (gdbtk_interp, h) != TCL_OK)
 424         error ("ide_create_property_command failed: %s", gdbtk_interp->result);
 425
 426       if (ide_create_build_command (gdbtk_interp, h) != TCL_OK)
 427         error ("ide_create_build_command failed: %s", gdbtk_interp->result);
 428
 429       if (ide_create_window_register_command (gdbtk_interp, h, "gdb-restore")
 430           != TCL_OK)
 431         error ("ide_create_window_register_command failed: %s",
 432                gdbtk_interp->result);
 433
 434       if (ide_create_window_command (gdbtk_interp, h) != TCL_OK)
 435         error ("ide_create_window_command failed: %s", gdbtk_interp->result);
 436
 437       if (ide_create_exit_command (gdbtk_interp, h) != TCL_OK)
 438         error ("ide_create_exit_command failed: %s", gdbtk_interp->result);
 439
 440       if (ide_create_help_command (gdbtk_interp) != TCL_OK)
 441         error ("ide_create_help_command failed: %s", gdbtk_interp->result);
 442
 443       /*
 444         if (ide_initialize (gdbtk_interp, "gdb") != TCL_OK)
 445         error ("ide_initialize failed: %s", gdbtk_interp->result);
 446       */
 447
 448       Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "1", 0);
 449     }
 450 #else
 451   /* end-sanitize-ide */
 452   Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "0", 0);
 453   /* start-sanitize-ide */
 454 #endif /* IDE */
 455   /* end-sanitize-ide */
 456
 457   /* We don't want to open the X connection until we've done all the
 458      IDE initialization.  Otherwise, goofy looking unfinished windows
 459      pop up when ILU drops into the TCL event loop.  */
 460
 461   if (Tk_Init(gdbtk_interp) != TCL_OK)
 462     error ("Tk_Init failed: %s", gdbtk_interp->result);
 463
 464   if (Itcl_Init(gdbtk_interp) == TCL_ERROR)
 465     error ("Itcl_Init failed: %s", gdbtk_interp->result);
 466   Tcl_StaticPackage(gdbtk_interp, "Itcl", Itcl_Init,
 467                     (Tcl_PackageInitProc *) NULL);
 468
 469   if (Itk_Init(gdbtk_interp) == TCL_ERROR)
 470     error ("Itk_Init failed: %s", gdbtk_interp->result);
 471   Tcl_StaticPackage(gdbtk_interp, "Itk", Itk_Init,
 472                     (Tcl_PackageInitProc *) NULL);
 473
 474   if (Tix_Init(gdbtk_interp) != TCL_OK)
 475     error ("Tix_Init failed: %s", gdbtk_interp->result);
 476   Tcl_StaticPackage(gdbtk_interp, "Tix", Tix_Init,
 477                     (Tcl_PackageInitProc *) NULL);
 478
 479   if (Tktable_Init(gdbtk_interp) != TCL_OK)
 480     error ("Tktable_Init failed: %s", gdbtk_interp->result);
 481
 482   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 483                     (Tcl_PackageInitProc *) NULL);
 484   /*
 485    * These are the commands to do some Windows Specific stuff...
 486    */
 487
 488 #ifdef __CYGWIN32__
 489   if (ide_create_messagebox_command (gdbtk_interp) != TCL_OK)
 490     error ("messagebox command initialization failed");
 491   /* On Windows, create a sizebox widget command */
 492   if (ide_create_sizebox_command (gdbtk_interp) != TCL_OK)
 493     error ("sizebox creation failed");
 494   if (ide_create_winprint_command (gdbtk_interp) != TCL_OK)
 495     error ("windows print code initialization failed");
 496   /* start-sanitize-ide */
 497   /* An interface to ShellExecute.  */
 498   if (ide_create_shell_execute_command (gdbtk_interp) != TCL_OK)
 499     error ("shell execute command initialization failed");
 500   /* end-sanitize-ide */
 501   if (ide_create_win_grab_command (gdbtk_interp) != TCL_OK)
 502     error ("grab support command initialization failed");
 503   /* Path conversion functions.  */
 504   if (ide_create_cygwin_path_command (gdbtk_interp) != TCL_OK)
 505     error ("cygwin path command initialization failed");
 506 #else
 507   /* for now, this testing function is Unix only */
 508   if (cyg_create_warp_pointer_command (gdbtk_interp) != TCL_OK)
 509     error ("warp_pointer command initialization failed");
 510 #endif
 511
 512   /*
 513    * This adds all the Gdbtk commands.
 514    */
 515
 516   if (Gdbtk_Init(gdbtk_interp) != TCL_OK)
 517     {
 518        error("Gdbtk_Init failed: %s", gdbtk_interp->result);
 519     }
 520
 521   Tcl_StaticPackage(gdbtk_interp, "Gdbtk", Gdbtk_Init, NULL);
 522
 523   /* This adds all the hooks that call up from the bowels of gdb
 524    *  back into Tcl-land...
 525    */
 526
 527   gdbtk_add_hooks();
 528
 529   /* Add a back door to Tk from the gdb console... */
 530
 531   add_com ("tk", class_obscure, tk_command,
 532            "Send a command directly into tk.");
 533
 534   /*
 535    * Set the variables for external editor:
 536    */
 537
 538   Tcl_SetVar (gdbtk_interp, "enable_external_editor", enable_external_editor ? "1" : "0", 0);
 539   Tcl_SetVar (gdbtk_interp, "external_editor_command", external_editor_command, 0);
 540
 541   /* find the gdb tcl library and source main.tcl */
 542
 543   {
 544 #ifdef NO_TCLPRO_DEBUGGER
 545     static char script[] ="\
 546 proc gdbtk_find_main {} {\n\
 547     global Paths GDBTK_LIBRARY\n\
 548     rename gdbtk_find_main {}\n\
 549     tcl_findLibrary gdb 1.0 {} main.tcl GDBTK_LIBRARY GDBTK_LIBRARY gdbtcl2 gdbtcl {}\n\
 550     set Paths(appdir) $GDBTK_LIBRARY\n\
 551 }\n\
 552 gdbtk_find_main";
 553 #else
 554     static char script[] ="\
 555 proc gdbtk_find_main {} {\n\
 556     global Paths GDBTK_LIBRARY env\n\
 557     rename gdbtk_find_main {}\n\
 558     if {[info exists env(DEBUG_STUB)]} {\n\
 559         source $env(DEBUG_STUB)\n\
 560         debugger_init\n\
 561         set debug_startup 1\n\
 562     } else {\n\
 563         set debug_startup 0\n\
 564     }\n\
 565     tcl_findLibrary gdb 1.0 {} main.tcl GDBTK_LIBRARY GDBTK_LIBRARY gdbtcl2 gdbtcl {} $debug_startup\n\
 566     set Paths(appdir) $GDBTK_LIBRARY\n\
 567 }\n\
 568 gdbtk_find_main";
 569 #endif /* NO_TCLPRO_DEBUGGER */
 570
 571     /* fputs_unfiltered_hook = NULL; */ /* Force errors to stdout/stderr */
 572
 573     /*
 574      * Set the variables for external editor, do this before eval'ing main.tcl
 575      * since the value is used there...
 576      */
 577
 578     Tcl_SetVar (gdbtk_interp, "enable_external_editor",
 579                 enable_external_editor ? "1" : "0", 0);
 580     Tcl_SetVar (gdbtk_interp, "external_editor_command",
 581                 external_editor_command, 0);
 582
 583   fputs_unfiltered_hook = gdbtk_fputs;
 584
 585   if (Tcl_GlobalEval (gdbtk_interp, (char *) script) != TCL_OK)
 586       {
 587         char *msg;
 588
 589         /* Force errorInfo to be set up propertly.  */
 590         Tcl_AddErrorInfo (gdbtk_interp, "");
 591
 592         msg = Tcl_GetVar (gdbtk_interp, "errorInfo", TCL_GLOBAL_ONLY);
 593
 594         fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
 595
 596 #ifdef _WIN32
 597         MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
 598 #else
 599         fputs_unfiltered (msg, gdb_stderr);
 600 #endif
 601
 602         error ("");
 603
 604       }
 605   }
 606
 607
 608   /* start-sanitize-ide */
 609 #ifdef IDE
 610   /* Don't do this until we have initialized.  Otherwise, we may get a
 611      run command before we are ready for one.  */
 612   if (ide_run_server_init (gdbtk_interp, h) != TCL_OK)
 613     error ("ide_run_server_init failed: %s", gdbtk_interp->result);
 614 #endif
 615   /* end-sanitize-ide */
 616
 617   /* Now source in the filename provided by the --tclcommand option.
 618      This is mostly used for the gdbtk testsuite... */
 619
 620   if (gdbtk_source_filename != NULL)
 621     {
 622       char *s = "after idle source ";
 623       char *script = concat (s, gdbtk_source_filename, (char *) NULL);
 624       Tcl_Eval (gdbtk_interp, script);
 625       free (gdbtk_source_filename);
 626       free (script);
 627     }
 628
 629
 630   discard_cleanups (old_chain);
 631 }
 632
 633 /* gdbtk_test is used in main.c to validate the -tclcommand option to
 634    gdb, which sources in a file of tcl code after idle during the
 635    startup procedure. */
 636
 637 int
 638 gdbtk_test (filename)
 639      char *filename;
 640 {
 641   if (access (filename, R_OK) != 0)
 642     return 0;
 643   else
 644     gdbtk_source_filename = xstrdup (filename);
 645   return 1;
 646 }
 647
 648 /* Come here during initialize_all_files () */
 649
 650 void
 651 _initialize_gdbtk ()
 652 {
 653   if (use_windows)
 654     {
 655       /* Tell the rest of the world that Gdbtk is now set up. */
 656
 657       init_ui_hook = gdbtk_init;
 658 #ifdef __CYGWIN32__
 659       (void) FreeConsole ();
 660 #endif
 661     }
 662 #ifdef __CYGWIN32__
 663   else
 664     {
 665       DWORD ft = GetFileType (GetStdHandle (STD_INPUT_HANDLE));
 666
 667       switch (ft)
 668         {
 669           case FILE_TYPE_DISK:
 670           case FILE_TYPE_CHAR:
 671           case FILE_TYPE_PIPE:
 672             break;
 673           default:
 674             AllocConsole();
 675             cygwin32_attach_handle_to_fd ("/dev/conin", 0,
 676                                           GetStdHandle (STD_INPUT_HANDLE),
 677                                           1, GENERIC_READ);
 678             cygwin32_attach_handle_to_fd ("/dev/conout", 1,
 679                                           GetStdHandle (STD_OUTPUT_HANDLE),
 680                                           0, GENERIC_WRITE);
 681             cygwin32_attach_handle_to_fd ("/dev/conout", 2,
 682                                           GetStdHandle (STD_ERROR_HANDLE),
 683                                           0, GENERIC_WRITE);
 684             break;
 685         }
 686     }
 687 #endif
 688 }
 689
 690 static void
 691 tk_command (cmd, from_tty)
 692      char *cmd;
 693      int from_tty;
 694 {
 695   int retval;
 696   char *result;
 697   struct cleanup *old_chain;
 698
 699   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
 700   if (cmd == NULL)
 701     error_no_arg ("tcl command to interpret");
 702
 703   retval = Tcl_Eval (gdbtk_interp, cmd);
 704
 705   result = strdup (gdbtk_interp->result);
 706
 707   old_chain = make_cleanup (free, result);
 708
 709   if (retval != TCL_OK)
 710     error (result);
 711
 712   printf_unfiltered ("%s\n", result);
 713
 714   do_cleanups (old_chain);
 715 }
 716 \f
 717 /* Local variables: */
 718 /* change-log-default-name: "ChangeLog-gdbtk" */
 719 /* End: */
 720