libguile/gdbint.c

   1 /* GDB interface for Guile
   2  * Copyright (C) 1996,1997,1999,2000,2001, 2002 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2.1 of the License, or (at your option) any later version.
   8  *
   9  * This library 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 GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include "libguile/_scm.h"
  24
  25 #include <stdio.h>
  26 #include <string.h>
  27 #ifdef HAVE_UNISTD_H
  28 #include <unistd.h>
  29 #endif
  30
  31 #include "libguile/strports.h"
  32 #include "libguile/read.h"
  33 #include "libguile/eval.h"
  34 #include "libguile/chars.h"
  35 #include "libguile/modules.h"
  36 #include "libguile/ports.h"
  37 #include "libguile/fluids.h"
  38 #include "libguile/strings.h"
  39 #include "libguile/init.h"
  40
  41 #include "libguile/gdbint.h"
  42 \f
  43 /* {Support for debugging with gdb}
  44  *
  45  * TODO:
  46  *
  47  * 1. Redirect outputs
  48  * 2. Catch errors
  49  * 3. Prevent print from causing segmentation fault when given broken pairs
  50  */
  51
  52 #define GDB_TYPE SCM
  53
  54 #include "libguile/gdb_interface.h"
  55
  56 \f
  57
  58 /* Be carefull when this macro is true.
  59    scm_gc_running_p is set during gc.
  60  */
  61 #define SCM_GC_P (scm_gc_running_p)
  62
  63 /* Macros that encapsulate blocks of code which can be called by the
  64  * debugger.
  65  */
  66 #define SCM_BEGIN_FOREIGN_BLOCK \
  67 do { \
  68   old_gc = scm_block_gc; scm_block_gc = 1; \
  69   scm_print_carefully_p = 1; \
  70 } while (0)
  71
  72
  73 #define SCM_END_FOREIGN_BLOCK \
  74 do { \
  75   scm_print_carefully_p = 0; \
  76   scm_block_gc = old_gc; \
  77 } while (0)
  78
  79
  80 #define RESET_STRING { gdb_output_length = 0; }
  81
  82 #define SEND_STRING(str) \
  83 do { \
  84   gdb_output = (char *) (str); \
  85   gdb_output_length = strlen ((const char *) (str)); \
  86 } while (0)
  87
  88
  89 /* {Gdb interface}
  90  */
  91
  92 unsigned short gdb_options = GDB_HAVE_BINDINGS;
  93
  94 char *gdb_language = "lisp/c";
  95
  96 SCM gdb_result;
  97
  98 char *gdb_output;
  99
 100 int gdb_output_length;
 101
 102 int scm_print_carefully_p;
 103
 104 static SCM gdb_input_port;
 105 static int port_mark_p, stream_mark_p, string_mark_p;
 106
 107 static SCM tok_buf;
 108 static int tok_buf_mark_p;
 109
 110 static SCM gdb_output_port;
 111 static int old_gc;
 112
 113
 114 static void
 115 unmark_port (SCM port)
 116 {
 117   SCM stream, string;
 118   port_mark_p = SCM_GC_MARK_P (port);
 119   SCM_CLEAR_GC_MARK (port);
 120   stream = SCM_PACK (SCM_STREAM (port));
 121   stream_mark_p = SCM_GC_MARK_P (stream);
 122   SCM_CLEAR_GC_MARK (stream);
 123   string = SCM_CDR (stream);
 124   string_mark_p = SCM_GC_MARK_P (string);
 125   SCM_CLEAR_GC_MARK (string);
 126 }
 127
 128
 129 static void
 130 remark_port (SCM port)
 131 {
 132   SCM stream = SCM_PACK (SCM_STREAM (port));
 133   SCM string = SCM_CDR (stream);
 134   if (string_mark_p)
 135     SCM_SET_GC_MARK (string);
 136   if (stream_mark_p)
 137     SCM_SET_GC_MARK (stream);
 138   if (port_mark_p)
 139     SCM_SET_GC_MARK (port);
 140 }
 141
 142
 143 int
 144 gdb_maybe_valid_type_p (SCM value)
 145 {
 146   return SCM_IMP (value) || scm_in_heap_p (value);
 147 }
 148
 149
 150 int
 151 gdb_read (char *str)
 152 {
 153   SCM ans;
 154   int status = 0;
 155   RESET_STRING;
 156   /* Need to be restrictive about what to read? */
 157   if (SCM_GC_P)
 158     {
 159       char *p;
 160       for (p = str; *p != '\0'; ++p)
 161         switch (*p)
 162           {
 163           case '(':
 164           case '\'':
 165           case '"':
 166             SEND_STRING ("Can't read this kind of expressions during gc");
 167             return -1;
 168           case '#':
 169             if (*++p == '\0')
 170               goto premature;
 171             if (*p == '\\')
 172               {
 173                 if (*++p != '\0')
 174                   continue;
 175               premature:
 176                 SEND_STRING ("Premature end of lisp expression");
 177                 return -1;
 178               }
 179           default:
 180             continue;
 181           }
 182     }
 183   SCM_BEGIN_FOREIGN_BLOCK;
 184   unmark_port (gdb_input_port);
 185   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 186   scm_puts (str, gdb_input_port);
 187   scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
 188   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 189   /* Read one object */
 190   tok_buf_mark_p = SCM_GC_MARK_P (tok_buf);
 191   SCM_CLEAR_GC_MARK (tok_buf);
 192   ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
 193   if (SCM_GC_P)
 194     {
 195       if (SCM_NIMP (ans))
 196         {
 197           SEND_STRING ("Non-immediate created during gc.  Memory may be trashed.");
 198           status = -1;
 199           goto exit;
 200         }
 201     }
 202   gdb_result = ans;
 203   /* Protect answer from future GC */
 204   if (SCM_NIMP (ans))
 205     scm_permanent_object (ans);
 206 exit:
 207   if (tok_buf_mark_p)
 208     SCM_SET_GC_MARK (tok_buf);
 209   remark_port (gdb_input_port);
 210   SCM_END_FOREIGN_BLOCK;
 211   return status;
 212 }
 213
 214
 215 int
 216 gdb_eval (SCM exp)
 217 {
 218   RESET_STRING;
 219   if (SCM_IMP (exp))
 220     {
 221       gdb_result = exp;
 222       return 0;
 223     }
 224   if (SCM_GC_P)
 225     {
 226       SEND_STRING ("Can't evaluate lisp expressions during gc");
 227       return -1;
 228     }
 229   SCM_BEGIN_FOREIGN_BLOCK;
 230   {
 231     SCM env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
 232     gdb_result = scm_permanent_object (scm_ceval (exp, env));
 233   }
 234   SCM_END_FOREIGN_BLOCK;
 235   return 0;
 236 }
 237
 238
 239 int
 240 gdb_print (SCM obj)
 241 {
 242   if (!scm_initialized_p)
 243     SEND_STRING ("*** Guile not initialized ***");
 244   else
 245     {
 246       RESET_STRING;
 247       SCM_BEGIN_FOREIGN_BLOCK;
 248       /* Reset stream */
 249       scm_seek (gdb_output_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 250       scm_write (obj, gdb_output_port);
 251       scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
 252       {
 253         scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
 254
 255         scm_flush (gdb_output_port);
 256         *(pt->write_buf + pt->read_buf_size) = 0;
 257         SEND_STRING (pt->read_buf);
 258       }
 259       SCM_END_FOREIGN_BLOCK;
 260     }
 261   return 0;
 262 }
 263
 264
 265 int
 266 gdb_binding (SCM name, SCM value)
 267 {
 268   RESET_STRING;
 269   if (SCM_GC_P)
 270     {
 271       SEND_STRING ("Can't create new bindings during gc");
 272       return -1;
 273     }
 274   SCM_BEGIN_FOREIGN_BLOCK;
 275   {
 276     SCM var = scm_sym2var (name, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_T);
 277     SCM_VARIABLE_SET (var, value);
 278   }
 279   SCM_END_FOREIGN_BLOCK;
 280   return 0;
 281 }
 282
 283 void
 284 scm_init_gdbint ()
 285 {
 286   static char *s = "scm_init_gdb_interface";
 287   SCM port;
 288
 289   scm_print_carefully_p = 0;
 290
 291   port = scm_mkstrport (SCM_INUM0,
 292                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 293                         SCM_OPN | SCM_WRTNG,
 294                         s);
 295   gdb_output_port = scm_permanent_object (port);
 296
 297   port = scm_mkstrport (SCM_INUM0,
 298                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 299                         SCM_OPN | SCM_RDNG | SCM_WRTNG,
 300                         s);
 301   gdb_input_port = scm_permanent_object (port);
 302
 303   tok_buf = scm_permanent_object (scm_allocate_string (30));
 304 }
 305
 306 /*
 307   Local Variables:
 308   c-file-style: "gnu"
 309   End:
 310 */