libguile/gdbint.c

   1 /* GDB interface for Guile
   2  * Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2, or (at your option)
   7  * any later version.
   8  *
   9  * This program 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
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this software; see the file COPYING.  If not, write to
  16  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  17  * Boston, MA 02111-1307 USA
  18  *
  19  * As a special exception, the Free Software Foundation gives permission
  20  * for additional uses of the text contained in its release of GUILE.
  21  *
  22  * The exception is that, if you link the GUILE library with other files
  23  * to produce an executable, this does not by itself cause the
  24  * resulting executable to be covered by the GNU General Public License.
  25  * Your use of that executable is in no way restricted on account of
  26  * linking the GUILE library code into it.
  27  *
  28  * This exception does not however invalidate any other reasons why
  29  * the executable file might be covered by the GNU General Public License.
  30  *
  31  * This exception applies only to the code released by the
  32  * Free Software Foundation under the name GUILE.  If you copy
  33  * code from other Free Software Foundation releases into a copy of
  34  * GUILE, as the General Public License permits, the exception does
  35  * not apply to the code that you add in this way.  To avoid misleading
  36  * anyone as to the status of such modified files, you must delete
  37  * this exception notice from them.
  38  *
  39  * If you write modifications of your own for GUILE, it is your choice
  40  * whether to permit this exception to apply to your modifications.
  41  * If you do not wish that, delete this exception notice.
  42  *
  43  * The author can be reached at djurfeldt@nada.kth.se
  44  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
  45
  46 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  47    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  48
  49
  50 #include "libguile/_scm.h"
  51
  52 #include <stdio.h>
  53 #ifdef HAVE_UNISTD_H
  54 #include <unistd.h>
  55 #endif
  56
  57 #include "libguile/tag.h"
  58 #include "libguile/strports.h"
  59 #include "libguile/read.h"
  60 #include "libguile/eval.h"
  61 #include "libguile/chars.h"
  62 #include "libguile/modules.h"
  63 #include "libguile/ports.h"
  64 #include "libguile/fluids.h"
  65 #include "libguile/strings.h"
  66 #include "libguile/init.h"
  67
  68 #include "libguile/gdbint.h"
  69 \f
  70 /* {Support for debugging with gdb}
  71  *
  72  * TODO:
  73  *
  74  * 1. Redirect outputs
  75  * 2. Catch errors
  76  * 3. Prevent print from causing segmentation fault when given broken pairs
  77  */
  78
  79 #define GDB_TYPE SCM
  80
  81 #include "libguile/gdb_interface.h"
  82
  83 \f
  84
  85 /* Be carefull when this macro is true.
  86    scm_gc_running_p is set during gc.
  87  */
  88 #define SCM_GC_P (scm_gc_running_p)
  89
  90 /* Macros that encapsulate blocks of code which can be called by the
  91  * debugger.
  92  */
  93 #define SCM_BEGIN_FOREIGN_BLOCK \
  94 do { \
  95   old_ints = scm_ints_disabled; scm_ints_disabled = 1; \
  96   old_gc = scm_block_gc; scm_block_gc = 1; \
  97   scm_print_carefully_p = 1; \
  98 } while (0)
  99
 100
 101 #define SCM_END_FOREIGN_BLOCK \
 102 do { \
 103   scm_print_carefully_p = 0; \
 104   scm_block_gc = old_gc; \
 105   scm_ints_disabled = old_ints; \
 106 } while (0)
 107
 108
 109 #define RESET_STRING { gdb_output_length = 0; }
 110
 111 #define SEND_STRING(str) \
 112 do { \
 113   gdb_output = (char *) (str); \
 114   gdb_output_length = strlen ((const char *) (str)); \
 115 } while (0)
 116
 117
 118 /* {Gdb interface}
 119  */
 120
 121 unsigned short gdb_options = GDB_HAVE_BINDINGS;
 122
 123 char *gdb_language = "lisp/c";
 124
 125 SCM gdb_result;
 126
 127 char *gdb_output;
 128
 129 int gdb_output_length;
 130
 131 int scm_print_carefully_p;
 132
 133 static SCM gdb_input_port;
 134 static int port_mark_p, stream_mark_p, string_mark_p;
 135
 136 static SCM tok_buf;
 137 static int tok_buf_mark_p;
 138
 139 static SCM gdb_output_port;
 140 static int old_ints, old_gc;
 141
 142
 143 static void
 144 unmark_port (SCM port)
 145 {
 146   SCM stream, string;
 147   port_mark_p = SCM_GCMARKP (port);
 148   SCM_CLRGCMARK (port);
 149   stream = SCM_PACK (SCM_STREAM (port));
 150   stream_mark_p = SCM_GCMARKP (stream);
 151   SCM_CLRGCMARK (stream);
 152   string = SCM_CDR (stream);
 153   string_mark_p = SCM_GCMARKP (string);
 154   SCM_CLRGCMARK (string);
 155 }
 156
 157
 158 static void
 159 remark_port (SCM port)
 160 {
 161   SCM stream = SCM_PACK (SCM_STREAM (port));
 162   SCM string = SCM_CDR (stream);
 163   if (string_mark_p) SCM_SETGCMARK (string);
 164   if (stream_mark_p) SCM_SETGCMARK (stream);
 165   if (port_mark_p) SCM_SETGCMARK (port);
 166 }
 167
 168
 169 int
 170 gdb_maybe_valid_type_p (SCM value)
 171 {
 172   return SCM_IMP (value) || scm_cellp (value);
 173 }
 174
 175
 176 int
 177 gdb_read (char *str)
 178 {
 179   SCM ans;
 180   int status = 0;
 181   RESET_STRING;
 182   /* Need to be restrictive about what to read? */
 183   if (SCM_GC_P)
 184     {
 185       char *p;
 186       for (p = str; *p != '\0'; ++p)
 187         switch (*p)
 188           {
 189           case '(':
 190           case '\'':
 191           case '"':
 192             SEND_STRING ("Can't read this kind of expressions during gc");
 193             return -1;
 194           case '#':
 195             if (*++p == '\0')
 196               goto premature;
 197             if (*p == '\\')
 198               {
 199                 if (*++p != '\0')
 200                   continue;
 201               premature:
 202                 SEND_STRING ("Premature end of lisp expression");
 203                 return -1;
 204               }
 205           default:
 206             continue;
 207           }
 208     }
 209   SCM_BEGIN_FOREIGN_BLOCK;
 210   unmark_port (gdb_input_port);
 211   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 212   scm_puts (str, gdb_input_port);
 213   scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
 214   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 215   /* Read one object */
 216   tok_buf_mark_p = SCM_GCMARKP (tok_buf);
 217   SCM_CLRGCMARK (tok_buf);
 218   ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
 219   if (SCM_GC_P)
 220     {
 221       if (SCM_NIMP (ans))
 222         {
 223           SEND_STRING ("Non-immediate created during gc.  Memory may be trashed.");
 224           status = -1;
 225           goto exit;
 226         }
 227     }
 228   gdb_result = ans;
 229   /* Protect answer from future GC */
 230   if (SCM_NIMP (ans))
 231     scm_permanent_object (ans);
 232 exit:
 233   if (tok_buf_mark_p)
 234     SCM_SETGCMARK (tok_buf);
 235   remark_port (gdb_input_port);
 236   SCM_END_FOREIGN_BLOCK;
 237   return status;
 238 }
 239
 240
 241 int
 242 gdb_eval (SCM exp)
 243 {
 244   RESET_STRING;
 245   if (SCM_IMP (exp))
 246     {
 247       gdb_result = exp;
 248       return 0;
 249     }
 250   if (SCM_GC_P)
 251     {
 252       SEND_STRING ("Can't evaluate lisp expressions during gc");
 253       return -1;
 254     }
 255   SCM_BEGIN_FOREIGN_BLOCK;
 256   {
 257     SCM env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
 258     gdb_result = scm_permanent_object (scm_ceval (exp, env));
 259   }
 260   SCM_END_FOREIGN_BLOCK;
 261   return 0;
 262 }
 263
 264
 265 int
 266 gdb_print (SCM obj)
 267 {
 268   if (!scm_initialized_p)
 269     SEND_STRING ("*** Guile not initialized ***");
 270   else
 271     {
 272       RESET_STRING;
 273       SCM_BEGIN_FOREIGN_BLOCK;
 274       /* Reset stream */
 275       scm_seek (gdb_output_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 276       scm_write (obj, gdb_output_port);
 277       scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
 278       {
 279         scm_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
 280
 281         scm_flush (gdb_output_port);
 282         *(pt->write_buf + pt->read_buf_size) = 0;
 283         SEND_STRING (pt->read_buf);
 284       }
 285       SCM_END_FOREIGN_BLOCK;
 286     }
 287   return 0;
 288 }
 289
 290
 291 int
 292 gdb_binding (SCM name, SCM value)
 293 {
 294   RESET_STRING;
 295   if (SCM_GC_P)
 296     {
 297       SEND_STRING ("Can't create new bindings during gc");
 298       return -1;
 299     }
 300   SCM_BEGIN_FOREIGN_BLOCK;
 301   {
 302     SCM vcell = scm_sym2vcell (name,
 303                                SCM_TOP_LEVEL_LOOKUP_CLOSURE,
 304                                SCM_BOOL_T);
 305     SCM_SETCDR (vcell, value);
 306   }
 307   SCM_END_FOREIGN_BLOCK;
 308   return 0;
 309 }
 310
 311 void
 312 scm_init_gdbint ()
 313 {
 314   static char *s = "scm_init_gdb_interface";
 315   SCM port;
 316
 317   scm_print_carefully_p = 0;
 318
 319   port = scm_mkstrport (SCM_INUM0,
 320                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 321                         SCM_OPN | SCM_WRTNG,
 322                         s);
 323   gdb_output_port = scm_permanent_object (port);
 324
 325   port = scm_mkstrport (SCM_INUM0,
 326                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 327                         SCM_OPN | SCM_RDNG | SCM_WRTNG,
 328                         s);
 329   gdb_input_port = scm_permanent_object (port);
 330
 331   tok_buf = scm_permanent_object (scm_makstr (30L, 0));
 332 }
 333
 334 /*
 335   Local Variables:
 336   c-file-style: "gnu"
 337   End:
 338 */