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   return SCM_IMP (value) || scm_cellp (value);
 172 }
 173
 174
 175 int
 176 gdb_read (char *str)
 177 {
 178   SCM ans;
 179   int status = 0;
 180   RESET_STRING;
 181   /* Need to be restrictive about what to read? */
 182   if (SCM_GC_P)
 183     {
 184       char *p;
 185       for (p = str; *p != '\0'; ++p)
 186         switch (*p)
 187           {
 188           case '(':
 189           case '\'':
 190           case '"':
 191             SEND_STRING ("Can't read this kind of expressions during gc");
 192             return -1;
 193           case '#':
 194             if (*++p == '\0')
 195               goto premature;
 196             if (*p == '\\')
 197               {
 198                 if (*++p != '\0')
 199                   continue;
 200               premature:
 201                 SEND_STRING ("Premature end of lisp expression");
 202                 return -1;
 203               }
 204           default:
 205             continue;
 206           }
 207     }
 208   SCM_BEGIN_FOREIGN_BLOCK;
 209   unmark_port (gdb_input_port);
 210   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 211   scm_puts (str, gdb_input_port);
 212   scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
 213   scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 214   /* Read one object */
 215   tok_buf_mark_p = SCM_GC8MARKP (tok_buf);
 216   SCM_CLRGC8MARK (tok_buf);
 217   ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
 218   if (SCM_GC_P)
 219     {
 220       if (SCM_NIMP (ans))
 221         {
 222           SEND_STRING ("Non-immediate created during gc.  Memory may be trashed.");
 223           status = -1;
 224           goto exit;
 225         }
 226     }
 227   gdb_result = ans;
 228   /* Protect answer from future GC */
 229   if (SCM_NIMP (ans))
 230     scm_permanent_object (ans);
 231 exit:
 232   if (tok_buf_mark_p)
 233     SCM_SETGC8MARK (tok_buf);
 234   remark_port (gdb_input_port);
 235   SCM_END_FOREIGN_BLOCK;
 236   return status;
 237 }
 238
 239
 240 int
 241 gdb_eval (SCM exp)
 242 {
 243   RESET_STRING;
 244   if (SCM_IMP (exp))
 245     {
 246       gdb_result = exp;
 247       return 0;
 248     }
 249   if (SCM_GC_P)
 250     {
 251       SEND_STRING ("Can't evaluate lisp expressions during gc");
 252       return -1;
 253     }
 254   SCM_BEGIN_FOREIGN_BLOCK;
 255   {
 256     SCM env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
 257     gdb_result = scm_permanent_object (scm_ceval (exp, env));
 258   }
 259   SCM_END_FOREIGN_BLOCK;
 260   return 0;
 261 }
 262
 263
 264 int
 265 gdb_print (SCM obj)
 266 {
 267   RESET_STRING;
 268   SCM_BEGIN_FOREIGN_BLOCK;
 269   /* Reset stream */
 270   scm_seek (gdb_output_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
 271   scm_write (obj, gdb_output_port);
 272   scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
 273   {
 274     scm_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
 275
 276     scm_flush (gdb_output_port);
 277     *(pt->write_buf + pt->read_buf_size) = 0;
 278     SEND_STRING (pt->read_buf);
 279   }
 280   SCM_END_FOREIGN_BLOCK;
 281   return 0;
 282 }
 283
 284
 285 int
 286 gdb_binding (SCM name, SCM value)
 287 {
 288   RESET_STRING;
 289   if (SCM_GC_P)
 290     {
 291       SEND_STRING ("Can't create new bindings during gc");
 292       return -1;
 293     }
 294   SCM_BEGIN_FOREIGN_BLOCK;
 295   {
 296     SCM vcell = scm_sym2vcell (name,
 297                                SCM_CDR (scm_top_level_lookup_closure_var),
 298                                SCM_BOOL_T);
 299     SCM_SETCDR (vcell, value);
 300   }
 301   SCM_END_FOREIGN_BLOCK;
 302   return 0;
 303 }
 304
 305 void
 306 scm_init_gdbint ()
 307 {
 308   static char *s = "scm_init_gdb_interface";
 309   SCM port;
 310
 311   scm_print_carefully_p = 0;
 312
 313   port = scm_mkstrport (SCM_INUM0,
 314                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 315                         SCM_OPN | SCM_WRTNG,
 316                         s);
 317   gdb_output_port = scm_permanent_object (port);
 318
 319   port = scm_mkstrport (SCM_INUM0,
 320                         scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
 321                         SCM_OPN | SCM_RDNG | SCM_WRTNG,
 322                         s);
 323   gdb_input_port = scm_permanent_object (port);
 324
 325   tok_buf = scm_permanent_object (scm_makstr (30L, 0));
 326 }
 327
 328 /*
 329   Local Variables:
 330   c-file-style: "gnu"
 331   End:
 332 */