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