libguile/gdbint.c

   1 /* GDB interface for Guile
   2  * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011,2012,
   3  *   2014 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 #include <unistd.h>
  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   scm_print_carefully_p = 1; \
  69 } while (0)
  70
  71
  72 #define SCM_END_FOREIGN_BLOCK \
  73 do { \
  74   scm_print_carefully_p = 0; \
  75 } while (0)
  76
  77
  78 #define RESET_STRING { gdb_output_length = 0; }
  79
  80 #define SEND_STRING(str) \
  81 do { \
  82   gdb_output = (char *) (str); \
  83   gdb_output_length = strlen ((const char *) (str)); \
  84 } while (0)
  85
  86
  87 /* {Gdb interface}
  88  */
  89
  90 unsigned short gdb_options = GDB_HAVE_BINDINGS;
  91
  92 char *gdb_language = "lisp/c";
  93
  94 SCM gdb_result;
  95
  96 char *gdb_output;
  97
  98 int gdb_output_length;
  99
 100 int scm_print_carefully_p;
 101
 102 static SCM gdb_input_port;
 103 static SCM gdb_output_port;
 104
 105
 106 int
 107 gdb_maybe_valid_type_p (SCM value)
 108 {
 109   return SCM_IMP (value); /*  || scm_in_heap_p (value); */ /* FIXME: What to
 110                                                               do? */
 111 }
 112
 113
 114 int
 115 gdb_read (char *str)
 116 {
 117 #if 0
 118   SCM ans;
 119   int status = 0;
 120   RESET_STRING;
 121   /* Need to be restrictive about what to read? */
 122   if (1)  /* (SCM_GC_P) */ /* FIXME */
 123     {
 124       char *p;
 125       for (p = str; *p != '\0'; ++p)
 126         switch (*p)
 127           {
 128           case '(':
 129           case '\'':
 130           case '"':
 131             SEND_STRING ("Can't read this kind of expressions during gc");
 132             return -1;
 133           case '#':
 134             if (*++p == '\0')
 135               goto premature;
 136             if (*p == '\\')
 137               {
 138                 if (*++p != '\0')
 139                   continue;
 140               premature:
 141                 SEND_STRING ("Premature end of lisp expression");
 142                 return -1;
 143               }
 144           default:
 145             continue;
 146           }
 147     }
 148   SCM_BEGIN_FOREIGN_BLOCK;
 149   unmark_port (gdb_input_port);
 150   scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
 151   scm_puts (str, gdb_input_port);
 152   scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
 153   scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
 154
 155   /* Read one object */
 156   ans = scm_read (gdb_input_port);
 157   if (SCM_GC_P)
 158     {
 159       if (SCM_NIMP (ans))
 160         {
 161           SEND_STRING ("Non-immediate created during gc.  Memory may be trashed.");
 162           status = -1;
 163           goto exit;
 164         }
 165     }
 166   gdb_result = ans;
 167   /* Protect answer from future GC (FIXME: still needed with BDW-GC?) */
 168   if (SCM_NIMP (ans))
 169     scm_permanent_object (ans);
 170 exit:
 171   remark_port (gdb_input_port);
 172   SCM_END_FOREIGN_BLOCK;
 173   return status;
 174 #else
 175   abort ();
 176 #endif
 177 }
 178
 179
 180 int
 181 gdb_eval (SCM exp)
 182 {
 183   RESET_STRING;
 184   if (SCM_GC_P)
 185     {
 186       SEND_STRING ("Can't evaluate lisp expressions during gc");
 187       return -1;
 188     }
 189   SCM_BEGIN_FOREIGN_BLOCK;
 190   {
 191     gdb_result = scm_permanent_object (scm_primitive_eval (exp));
 192   }
 193   SCM_END_FOREIGN_BLOCK;
 194   return 0;
 195 }
 196
 197
 198 int
 199 gdb_print (SCM obj)
 200 {
 201   if (!scm_initialized_p)
 202     SEND_STRING ("*** Guile not initialized ***");
 203   else
 204     {
 205       RESET_STRING;
 206       SCM_BEGIN_FOREIGN_BLOCK;
 207       /* Reset stream */
 208       scm_seek (gdb_output_port, SCM_INUM0, scm_from_int (SEEK_SET));
 209       scm_write (obj, gdb_output_port);
 210       scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
 211       {
 212         scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
 213
 214         scm_flush (gdb_output_port);
 215         *(pt->write_buf + pt->read_buf_size) = 0;
 216         SEND_STRING (pt->read_buf);
 217       }
 218       SCM_END_FOREIGN_BLOCK;
 219     }
 220   return 0;
 221 }
 222
 223
 224 int
 225 gdb_binding (SCM name, SCM value)
 226 {
 227   RESET_STRING;
 228   if (SCM_GC_P)
 229     {
 230       SEND_STRING ("Can't create new bindings during gc");
 231       return -1;
 232     }
 233   SCM_BEGIN_FOREIGN_BLOCK;
 234   {
 235     scm_define (name, value);
 236   }
 237   SCM_END_FOREIGN_BLOCK;
 238   return 0;
 239 }
 240
 241 void
 242 scm_init_gdbint ()
 243 {
 244   static char *s = "scm_init_gdb_interface";
 245   SCM port;
 246
 247   scm_print_carefully_p = 0;
 248
 249   port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
 250                         SCM_OPN | SCM_WRTNG,
 251                         s);
 252   gdb_output_port = scm_permanent_object (port);
 253
 254   port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
 255                         SCM_OPN | SCM_RDNG | SCM_WRTNG,
 256                         s);
 257   gdb_input_port = scm_permanent_object (port);
 258 }
 259
 260 /*
 261   Local Variables:
 262   c-file-style: "gnu"
 263   End:
 264 */