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