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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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   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 } while (0)
  77
  78
  79 #define RESET_STRING { gdb_output_length = 0; }
  80
  81 #define SEND_STRING(str) \
  82 do { \
  83   gdb_output = (char *) (str); \
  84   gdb_output_length = strlen ((const char *) (str)); \
  85 } while (0)
  86
  87
  88 /* {Gdb interface}
  89  */
  90
  91 unsigned short gdb_options = GDB_HAVE_BINDINGS;
  92
  93 char *gdb_language = "lisp/c";
  94
  95 SCM gdb_result;
  96
  97 char *gdb_output;
  98
  99 int gdb_output_length;
 100
 101 int scm_print_carefully_p;
 102
 103 static SCM gdb_input_port;
 104 static int port_mark_p, stream_mark_p, string_mark_p;
 105
 106 static SCM tok_buf;
 107 static int tok_buf_mark_p;
 108
 109 static SCM gdb_output_port;
 110
 111
 112 static void
 113 unmark_port (SCM port)
 114 {
 115   SCM stream, string;
 116   port_mark_p = SCM_GC_MARK_P (port);
 117   SCM_CLEAR_GC_MARK (port);
 118   stream = SCM_PACK (SCM_STREAM (port));
 119   stream_mark_p = SCM_GC_MARK_P (stream);
 120   SCM_CLEAR_GC_MARK (stream);
 121   string = SCM_CDR (stream);
 122   string_mark_p = SCM_GC_MARK_P (string);
 123   SCM_CLEAR_GC_MARK (string);
 124 }
 125
 126
 127 static void
 128 remark_port (SCM port)
 129 {
 130   SCM stream = SCM_PACK (SCM_STREAM (port));
 131   SCM string = SCM_CDR (stream);
 132   if (string_mark_p)
 133     SCM_SET_GC_MARK (string);
 134   if (stream_mark_p)
 135     SCM_SET_GC_MARK (stream);
 136   if (port_mark_p)
 137     SCM_SET_GC_MARK (port);
 138 }
 139
 140
 141 int
 142 gdb_maybe_valid_type_p (SCM value)
 143 {
 144   return SCM_IMP (value) || scm_in_heap_p (value);
 145 }
 146
 147
 148 int
 149 gdb_read (char *str)
 150 {
 151   SCM ans;
 152   int status = 0;
 153   RESET_STRING;
 154   /* Need to be restrictive about what to read? */
 155   if (SCM_GC_P)
 156     {
 157       char *p;
 158       for (p = str; *p != '\0'; ++p)
 159         switch (*p)
 160           {
 161           case '(':
 162           case '\'':
 163           case '"':
 164             SEND_STRING ("Can't read this kind of expressions during gc");
 165             return -1;
 166           case '#':
 167             if (*++p == '\0')
 168               goto premature;
 169             if (*p == '\\')
 170               {
 171                 if (*++p != '\0')
 172                   continue;
 173               premature:
 174                 SEND_STRING ("Premature end of lisp expression");
 175                 return -1;
 176               }
 177           default:
 178             continue;
 179           }
 180     }
 181   SCM_BEGIN_FOREIGN_BLOCK;
 182   unmark_port (gdb_input_port);
 183   scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
 184   scm_puts (str, gdb_input_port);
 185   scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
 186   scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
 187   /* Read one object */
 188   tok_buf_mark_p = SCM_GC_MARK_P (tok_buf);
 189   SCM_CLEAR_GC_MARK (tok_buf);
 190   ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
 191   if (SCM_GC_P)
 192     {
 193       if (SCM_NIMP (ans))
 194         {
 195           SEND_STRING ("Non-immediate created during gc.  Memory may be trashed.");
 196           status = -1;
 197           goto exit;
 198         }
 199     }
 200   gdb_result = ans;
 201   /* Protect answer from future GC */
 202   if (SCM_NIMP (ans))
 203     scm_permanent_object (ans);
 204 exit:
 205   if (tok_buf_mark_p)
 206     SCM_SET_GC_MARK (tok_buf);
 207   remark_port (gdb_input_port);
 208   SCM_END_FOREIGN_BLOCK;
 209   return status;
 210 }
 211
 212
 213 int
 214 gdb_eval (SCM exp)
 215 {
 216   RESET_STRING;
 217   if (SCM_GC_P)
 218     {
 219       SEND_STRING ("Can't evaluate lisp expressions during gc");
 220       return -1;
 221     }
 222   SCM_BEGIN_FOREIGN_BLOCK;
 223   {
 224     SCM env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
 225     gdb_result = scm_permanent_object (scm_i_eval_x (exp, env));
 226   }
 227   SCM_END_FOREIGN_BLOCK;
 228   return 0;
 229 }
 230
 231
 232 int
 233 gdb_print (SCM obj)
 234 {
 235   if (!scm_initialized_p)
 236     SEND_STRING ("*** Guile not initialized ***");
 237   else
 238     {
 239       RESET_STRING;
 240       SCM_BEGIN_FOREIGN_BLOCK;
 241       /* Reset stream */
 242       scm_seek (gdb_output_port, SCM_INUM0, scm_from_int (SEEK_SET));
 243       scm_write (obj, gdb_output_port);
 244       scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
 245       {
 246         scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
 247
 248         scm_flush (gdb_output_port);
 249         *(pt->write_buf + pt->read_buf_size) = 0;
 250         SEND_STRING (pt->read_buf);
 251       }
 252       SCM_END_FOREIGN_BLOCK;
 253     }
 254   return 0;
 255 }
 256
 257
 258 int
 259 gdb_binding (SCM name, SCM value)
 260 {
 261   RESET_STRING;
 262   if (SCM_GC_P)
 263     {
 264       SEND_STRING ("Can't create new bindings during gc");
 265       return -1;
 266     }
 267   SCM_BEGIN_FOREIGN_BLOCK;
 268   {
 269     SCM var = scm_sym2var (name, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_T);
 270     SCM_VARIABLE_SET (var, value);
 271   }
 272   SCM_END_FOREIGN_BLOCK;
 273   return 0;
 274 }
 275
 276 void
 277 scm_init_gdbint ()
 278 {
 279   static char *s = "scm_init_gdb_interface";
 280   SCM port;
 281
 282   scm_print_carefully_p = 0;
 283
 284   port = scm_mkstrport (SCM_INUM0,
 285                         scm_c_make_string (0, SCM_UNDEFINED),
 286                         SCM_OPN | SCM_WRTNG,
 287                         s);
 288   gdb_output_port = scm_permanent_object (port);
 289
 290   port = scm_mkstrport (SCM_INUM0,
 291                         scm_c_make_string (0, SCM_UNDEFINED),
 292                         SCM_OPN | SCM_RDNG | SCM_WRTNG,
 293                         s);
 294   gdb_input_port = scm_permanent_object (port);
 295
 296   tok_buf = scm_permanent_object (scm_c_make_string (30, SCM_UNDEFINED));
 297 }
 298
 299 /*
 300   Local Variables:
 301   c-file-style: "gnu"
 302   End:
 303 */