libguile/gdbint.c

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