libguile/gdbint.c

   1 /* GDB interface for Guile
   2  * Copyright (C) 1996, 1997, 1999 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/root.h"
  65 #include "libguile/strings.h"
  66
  67 #include "libguile/gdbint.h"
  68 \f
  69 /* {Support for debugging with gdb}
  70  *
  71  * TODO:
  72  *
  73  * 1. Redirect outputs
  74  * 2. Catch errors
  75  * 3. Prevent print from causing segmentation fault when given broken pairs
  76  */
  77
  78 #define GDB_TYPE SCM
  79
  80 #include "libguile/gdb_interface.h"
  81
  82 \f
  83
  84 /* Be carefull when this macro is true.
  85    scm_gc_heap_lock is set during gc.
  86  */
  87 #define SCM_GC_P (scm_gc_heap_lock)
  88
  89 /* Macros that encapsulate blocks of code which can be called by the
  90  * debugger.
  91  */
  92 #define SCM_BEGIN_FOREIGN_BLOCK \
  93 do { \
  94   old_ints = scm_ints_disabled; scm_ints_disabled = 1; \
  95   old_gc = scm_block_gc; scm_block_gc = 1; \
  96   scm_print_carefully_p = 1; \
  97 } while (0)
  98
  99
 100 #define SCM_END_FOREIGN_BLOCK \
 101 do { \
 102   scm_print_carefully_p = 0; \
 103   scm_block_gc = old_gc; \
 104   scm_ints_disabled = old_ints; \
 105 } while (0)
 106
 107
 108 #define RESET_STRING { gdb_output_length = 0; }
 109
 110 #define SEND_STRING(str) \
 111 do { \
 112   gdb_output = str; \
 113   gdb_output_length = strlen (str); \
 114 } while (0)
 115
 116
 117 /* {Gdb interface}
 118  */
 119
 120 unsigned short gdb_options = GDB_HAVE_BINDINGS;
 121
 122 char *gdb_language = "lisp/c";
 123
 124 SCM gdb_result;
 125
 126 char *gdb_output;
 127
 128 int gdb_output_length;
 129
 130 int scm_print_carefully_p;
 131
 132 static SCM gdb_input_port;
 133 static int port_mark_p, stream_mark_p, string_mark_p;
 134
 135 static SCM tok_buf;
 136 static int tok_buf_mark_p;
 137
 138 static SCM gdb_output_port;
 139 static int old_ints, old_gc;
 140
 141
 142 static void
 143 unmark_port (SCM port)
 144 {
 145   SCM stream, string;
 146   port_mark_p = SCM_GC8MARKP (port);
 147   SCM_CLRGC8MARK (port);
 148   stream = SCM_PACK (SCM_STREAM (port));
 149   stream_mark_p = SCM_GCMARKP (stream);
 150   SCM_CLRGCMARK (stream);
 151   string = SCM_CDR (stream);
 152   string_mark_p = SCM_GC8MARKP (string);
 153   SCM_CLRGC8MARK (string);
 154 }
 155
 156
 157 static void
 158 remark_port (SCM port)
 159 {
 160   SCM stream = SCM_PACK (SCM_STREAM (port));
 161   SCM string = SCM_CDR (stream);
 162   if (string_mark_p) SCM_SETGC8MARK (string);
 163   if (stream_mark_p) SCM_SETGCMARK (stream);
 164   if (port_mark_p) SCM_SETGC8MARK (port);
 165 }
 166
 167
 168 int
 169 gdb_maybe_valid_type_p (SCM value)
 170 {
 171   if (SCM_IMP (value) || scm_cellp (value))
 172     return (! SCM_EQ_P (scm_tag (value), SCM_MAKINUM (-1)));
 173   return 0;
 174 }
 175
 176
 177 int
 178 gdb_read (char *str)
 179 {
 180   SCM ans;
 181   int status = 0;
 182   RESET_STRING;
 183   /* Need to be restrictive about what to read? */
 184   if (SCM_GC_P)
 185     {
 186       char *p;
 187       for (p = str; *p != '\0'; ++p)
 188         switch (*p)
 189           {
 190           case '(':
 191           case '\'':
 192           case '"':
 193             SEND_STRING ("Can't read this kind of expressions during gc");
 194             return -1;
 195           case '#':
 196             if (*++p == '\0')
 197               goto premature;
 198             if (*p == '\\')
 199               {
 200                 if (*++p != '\0')
 201                   continue;
 202               premature:
 203                 SEND_STRING ("Premature end of lisp expression");
 204                 return -1;
 205               }
 206           default:
 207             continue;
 208           }
 209     }
 210   SCM_BEGIN_FOREIGN_BLOCK;
 211   unmark_port (gdb_input_port);
 212   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 213   scm_puts (str, gdb_input_port);
 214   scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
 215   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 216   /* Read one object */
 217   tok_buf_mark_p = SCM_GC8MARKP (tok_buf);
 218   SCM_CLRGC8MARK (tok_buf);
 219   ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
 220   if (SCM_GC_P)
 221     {
 222       if (SCM_NIMP (ans))
 223         {
 224           SEND_STRING ("Non-immediate created during gc.  Memory may be trashed.");
 225           status = -1;
 226           goto exit;
 227         }
 228     }
 229   gdb_result = ans;
 230   /* Protect answer from future GC */
 231   if (SCM_NIMP (ans))
 232     scm_permanent_object (ans);
 233 exit:
 234   if (tok_buf_mark_p)
 235     SCM_SETGC8MARK (tok_buf);
 236   remark_port (gdb_input_port);
 237   SCM_END_FOREIGN_BLOCK;
 238   return status;
 239 }
 240
 241
 242 int
 243 gdb_eval (SCM exp)
 244 {
 245   RESET_STRING;
 246   if (SCM_IMP (exp))
 247     {
 248       gdb_result = exp;
 249       return 0;
 250     }
 251   if (SCM_GC_P)
 252     {
 253       SEND_STRING ("Can't evaluate lisp expressions during gc");
 254       return -1;
 255     }
 256   SCM_BEGIN_FOREIGN_BLOCK;
 257   {
 258     SCM env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
 259     gdb_result = scm_permanent_object (scm_ceval (exp, env));
 260   }
 261   SCM_END_FOREIGN_BLOCK;
 262   return 0;
 263 }
 264
 265
 266 int
 267 gdb_print (SCM obj)
 268 {
 269   RESET_STRING;
 270   SCM_BEGIN_FOREIGN_BLOCK;
 271   /* Reset stream */
 272   scm_seek (gdb_output_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 273   scm_write (obj, gdb_output_port);
 274   scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
 275   {
 276     scm_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
 277
 278     scm_flush (gdb_output_port);
 279     *(pt->write_buf + pt->read_buf_size) = 0;
 280     SEND_STRING (pt->read_buf);
 281   }
 282   SCM_END_FOREIGN_BLOCK;
 283   return 0;
 284 }
 285
 286
 287 int
 288 gdb_binding (SCM name, SCM value)
 289 {
 290   RESET_STRING;
 291   if (SCM_GC_P)
 292     {
 293       SEND_STRING ("Can't create new bindings during gc");
 294       return -1;
 295     }
 296   SCM_BEGIN_FOREIGN_BLOCK;
 297   {
 298     SCM vcell = scm_sym2vcell (name,
 299                                SCM_CDR (scm_top_level_lookup_closure_var),
 300                                SCM_BOOL_T);
 301     SCM_SETCDR (vcell, value);
 302   }
 303   SCM_END_FOREIGN_BLOCK;
 304   return 0;
 305 }
 306
 307 void
 308 scm_init_gdbint ()
 309 {
 310   static char *s = "scm_init_gdb_interface";
 311   SCM port;
 312
 313   scm_print_carefully_p = 0;
 314
 315   port = scm_mkstrport (SCM_INUM0,
 316                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 317                         SCM_OPN | SCM_WRTNG,
 318                         s);
 319   gdb_output_port = scm_permanent_object (port);
 320
 321   port = scm_mkstrport (SCM_INUM0,
 322                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 323                         SCM_OPN | SCM_RDNG | SCM_WRTNG,
 324                         s);
 325   gdb_input_port = scm_permanent_object (port);
 326
 327   tok_buf = scm_permanent_object (scm_makstr (30L, 0));
 328 }
 329
 330 /*
 331   Local Variables:
 332   c-file-style: "gnu"
 333   End:
 334 */