libguile/gdbint.c

   1 /* GDB interface for Guile
   2  * Copyright (C) 1996,1997,1999,2000,2001 Free Software Foundation, Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2, or (at your option)
   7  * any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this software; see the file COPYING.  If not, write to
  16  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  17  * Boston, MA 02111-1307 USA
  18  *
  19  * As a special exception, the Free Software Foundation gives permission
  20  * for additional uses of the text contained in its release of GUILE.
  21  *
  22  * The exception is that, if you link the GUILE library with other files
  23  * to produce an executable, this does not by itself cause the
  24  * resulting executable to be covered by the GNU General Public License.
  25  * Your use of that executable is in no way restricted on account of
  26  * linking the GUILE library code into it.
  27  *
  28  * This exception does not however invalidate any other reasons why
  29  * the executable file might be covered by the GNU General Public License.
  30  *
  31  * This exception applies only to the code released by the
  32  * Free Software Foundation under the name GUILE.  If you copy
  33  * code from other Free Software Foundation releases into a copy of
  34  * GUILE, as the General Public License permits, the exception does
  35  * not apply to the code that you add in this way.  To avoid misleading
  36  * anyone as to the status of such modified files, you must delete
  37  * this exception notice from them.
  38  *
  39  * If you write modifications of your own for GUILE, it is your choice
  40  * whether to permit this exception to apply to your modifications.
  41  * If you do not wish that, delete this exception notice.
  42  *
  43  * The author can be reached at djurfeldt@nada.kth.se
  44  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
  45
  46 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  47    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  48
  49
  50 #include "libguile/_scm.h"
  51
  52 #include <stdio.h>
  53 #include <string.h>
  54 #ifdef HAVE_UNISTD_H
  55 #include <unistd.h>
  56 #endif
  57
  58 #include "libguile/tag.h"
  59 #include "libguile/strports.h"
  60 #include "libguile/read.h"
  61 #include "libguile/eval.h"
  62 #include "libguile/chars.h"
  63 #include "libguile/modules.h"
  64 #include "libguile/ports.h"
  65 #include "libguile/fluids.h"
  66 #include "libguile/strings.h"
  67 #include "libguile/init.h"
  68
  69 #include "libguile/gdbint.h"
  70 \f
  71 /* {Support for debugging with gdb}
  72  *
  73  * TODO:
  74  *
  75  * 1. Redirect outputs
  76  * 2. Catch errors
  77  * 3. Prevent print from causing segmentation fault when given broken pairs
  78  */
  79
  80 #define GDB_TYPE SCM
  81
  82 #include "libguile/gdb_interface.h"
  83
  84 \f
  85
  86 /* Be carefull when this macro is true.
  87    scm_gc_running_p is set during gc.
  88  */
  89 #define SCM_GC_P (scm_gc_running_p)
  90
  91 /* Macros that encapsulate blocks of code which can be called by the
  92  * debugger.
  93  */
  94 #define SCM_BEGIN_FOREIGN_BLOCK \
  95 do { \
  96   old_ints = scm_ints_disabled; scm_ints_disabled = 1; \
  97   old_gc = scm_block_gc; scm_block_gc = 1; \
  98   scm_print_carefully_p = 1; \
  99 } while (0)
 100
 101
 102 #define SCM_END_FOREIGN_BLOCK \
 103 do { \
 104   scm_print_carefully_p = 0; \
 105   scm_block_gc = old_gc; \
 106   scm_ints_disabled = old_ints; \
 107 } while (0)
 108
 109
 110 #define RESET_STRING { gdb_output_length = 0; }
 111
 112 #define SEND_STRING(str) \
 113 do { \
 114   gdb_output = (char *) (str); \
 115   gdb_output_length = strlen ((const char *) (str)); \
 116 } while (0)
 117
 118
 119 /* {Gdb interface}
 120  */
 121
 122 unsigned short gdb_options = GDB_HAVE_BINDINGS;
 123
 124 char *gdb_language = "lisp/c";
 125
 126 SCM gdb_result;
 127
 128 char *gdb_output;
 129
 130 int gdb_output_length;
 131
 132 int scm_print_carefully_p;
 133
 134 static SCM gdb_input_port;
 135 static int port_mark_p, stream_mark_p, string_mark_p;
 136
 137 static SCM tok_buf;
 138 static int tok_buf_mark_p;
 139
 140 static SCM gdb_output_port;
 141 static int old_ints, old_gc;
 142
 143
 144 static void
 145 unmark_port (SCM port)
 146 {
 147   SCM stream, string;
 148   port_mark_p = SCM_GCMARKP (port);
 149   SCM_CLRGCMARK (port);
 150   stream = SCM_PACK (SCM_STREAM (port));
 151   stream_mark_p = SCM_GCMARKP (stream);
 152   SCM_CLRGCMARK (stream);
 153   string = SCM_CDR (stream);
 154   string_mark_p = SCM_GCMARKP (string);
 155   SCM_CLRGCMARK (string);
 156 }
 157
 158
 159 static void
 160 remark_port (SCM port)
 161 {
 162   SCM stream = SCM_PACK (SCM_STREAM (port));
 163   SCM string = SCM_CDR (stream);
 164   if (string_mark_p) SCM_SETGCMARK (string);
 165   if (stream_mark_p) SCM_SETGCMARK (stream);
 166   if (port_mark_p) SCM_SETGCMARK (port);
 167 }
 168
 169
 170 int
 171 gdb_maybe_valid_type_p (SCM value)
 172 {
 173   return SCM_IMP (value) || scm_cellp (value);
 174 }
 175
 176
 177 int
 178 gdb_read (char *str)
 179 {
 180   SCM ans;
 181   int status = 0;
 182   RESET_STRING;
 183   /* Need to be restrictive about what to read? */
 184   if (SCM_GC_P)
 185     {
 186       char *p;
 187       for (p = str; *p != '\0'; ++p)
 188         switch (*p)
 189           {
 190           case '(':
 191           case '\'':
 192           case '"':
 193             SEND_STRING ("Can't read this kind of expressions during gc");
 194             return -1;
 195           case '#':
 196             if (*++p == '\0')
 197               goto premature;
 198             if (*p == '\\')
 199               {
 200                 if (*++p != '\0')
 201                   continue;
 202               premature:
 203                 SEND_STRING ("Premature end of lisp expression");
 204                 return -1;
 205               }
 206           default:
 207             continue;
 208           }
 209     }
 210   SCM_BEGIN_FOREIGN_BLOCK;
 211   unmark_port (gdb_input_port);
 212   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 213   scm_puts (str, gdb_input_port);
 214   scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
 215   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 216   /* Read one object */
 217   tok_buf_mark_p = SCM_GCMARKP (tok_buf);
 218   SCM_CLRGCMARK (tok_buf);
 219   ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
 220   if (SCM_GC_P)
 221     {
 222       if (SCM_NIMP (ans))
 223         {
 224           SEND_STRING ("Non-immediate created during gc.  Memory may be trashed.");
 225           status = -1;
 226           goto exit;
 227         }
 228     }
 229   gdb_result = ans;
 230   /* Protect answer from future GC */
 231   if (SCM_NIMP (ans))
 232     scm_permanent_object (ans);
 233 exit:
 234   if (tok_buf_mark_p)
 235     SCM_SETGCMARK (tok_buf);
 236   remark_port (gdb_input_port);
 237   SCM_END_FOREIGN_BLOCK;
 238   return status;
 239 }
 240
 241
 242 int
 243 gdb_eval (SCM exp)
 244 {
 245   RESET_STRING;
 246   if (SCM_IMP (exp))
 247     {
 248       gdb_result = exp;
 249       return 0;
 250     }
 251   if (SCM_GC_P)
 252     {
 253       SEND_STRING ("Can't evaluate lisp expressions during gc");
 254       return -1;
 255     }
 256   SCM_BEGIN_FOREIGN_BLOCK;
 257   {
 258     SCM env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
 259     gdb_result = scm_permanent_object (scm_ceval (exp, env));
 260   }
 261   SCM_END_FOREIGN_BLOCK;
 262   return 0;
 263 }
 264
 265
 266 int
 267 gdb_print (SCM obj)
 268 {
 269   if (!scm_initialized_p)
 270     SEND_STRING ("*** Guile not initialized ***");
 271   else
 272     {
 273       RESET_STRING;
 274       SCM_BEGIN_FOREIGN_BLOCK;
 275       /* Reset stream */
 276       scm_seek (gdb_output_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 277       scm_write (obj, gdb_output_port);
 278       scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
 279       {
 280         scm_port_t *pt = SCM_PTAB_ENTRY (gdb_output_port);
 281
 282         scm_flush (gdb_output_port);
 283         *(pt->write_buf + pt->read_buf_size) = 0;
 284         SEND_STRING (pt->read_buf);
 285       }
 286       SCM_END_FOREIGN_BLOCK;
 287     }
 288   return 0;
 289 }
 290
 291
 292 int
 293 gdb_binding (SCM name, SCM value)
 294 {
 295   RESET_STRING;
 296   if (SCM_GC_P)
 297     {
 298       SEND_STRING ("Can't create new bindings during gc");
 299       return -1;
 300     }
 301   SCM_BEGIN_FOREIGN_BLOCK;
 302   {
 303     SCM var = scm_sym2var (name, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_T);
 304     SCM_VARIABLE_SET (var, value);
 305   }
 306   SCM_END_FOREIGN_BLOCK;
 307   return 0;
 308 }
 309
 310 void
 311 scm_init_gdbint ()
 312 {
 313   static char *s = "scm_init_gdb_interface";
 314   SCM port;
 315
 316   scm_print_carefully_p = 0;
 317
 318   port = scm_mkstrport (SCM_INUM0,
 319                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 320                         SCM_OPN | SCM_WRTNG,
 321                         s);
 322   gdb_output_port = scm_permanent_object (port);
 323
 324   port = scm_mkstrport (SCM_INUM0,
 325                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 326                         SCM_OPN | SCM_RDNG | SCM_WRTNG,
 327                         s);
 328   gdb_input_port = scm_permanent_object (port);
 329
 330   tok_buf = scm_permanent_object (scm_allocate_string (30));
 331 }
 332
 333 /*
 334   Local Variables:
 335   c-file-style: "gnu"
 336   End:
 337 */