libguile/gdbint.c

   1 /* GDB interface for Guile
   2  * Copyright (C) 1996 Mikael Djurfeldt
   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, 675 Mass Ave, Cambridge, MA 02139, USA.
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.
  41  *
  42  * The author can be reached at djurfeldt@nada.kth.se
  43  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  44  */
  45
  46 #include <stdio.h>
  47 #include "_scm.h"
  48 #include "tag.h"
  49 #include "strports.h"
  50 #include "read.h"
  51 #include "eval.h"
  52 #include "chars.h"
  53
  54 #include "gdbint.h"
  55 \f
  56 /* {Support for debugging with gdb}
  57  *
  58  * TODO:
  59  *
  60  * 1. Redirect outputs
  61  * 2. Catch errors
  62  * 3. Prevent print from causing segmentation fault when given broken pairs
  63  */
  64
  65 #include <stdio.h>
  66 #include "_scm.h"
  67
  68 #define GDB_TYPE SCM
  69
  70 #include "gdb_interface.h"
  71
  72 \f
  73
  74 /* Be carefull when this macro is true.
  75    scm_gc_heap_lock is set during gc.
  76  */
  77 #define SCM_GC_P (scm_gc_heap_lock)
  78
  79 /* Macros that encapsulate blocks of code which can be called by the
  80  * debugger.
  81  */
  82 #define SCM_BEGIN_FOREIGN_BLOCK \
  83 { \
  84   old_ints = scm_ints_disabled; scm_ints_disabled = 1; \
  85   old_gc = scm_block_gc; scm_block_gc = 1; \
  86   scm_print_carefully_p = 1; \
  87 } \
  88
  89
  90 #define SCM_END_FOREIGN_BLOCK \
  91 { \
  92   scm_print_carefully_p = 0; \
  93   scm_block_gc = old_gc; \
  94   scm_ints_disabled = old_ints; \
  95 } \
  96
  97
  98 #define RESET_STRING { gdb_output_length = 0; }
  99
 100 #define SEND_STRING(str) \
 101 { \
 102   gdb_output = str; \
 103   gdb_output_length = strlen (str); \
 104 } \
 105
 106
 107 /* {Gdb interface}
 108  */
 109
 110 unsigned short gdb_options = GDB_HAVE_BINDINGS;
 111
 112 char *gdb_language = "lisp/c";
 113
 114 SCM gdb_result;
 115
 116 char *gdb_output;
 117
 118 int gdb_output_length;
 119
 120 int scm_print_carefully_p;
 121
 122 static SCM gdb_input_port;
 123 static int port_mark_p, stream_mark_p, string_mark_p;
 124
 125 static SCM tok_buf;
 126 static int tok_buf_mark_p;
 127
 128 static SCM gdb_output_port;
 129 static int old_ints, old_gc;
 130
 131
 132 static void unmark_port SCM_P ((SCM port));
 133
 134 static void
 135 unmark_port (port)
 136      SCM port;
 137 {
 138   SCM stream, string;
 139   port_mark_p = SCM_GC8MARKP (port);
 140   SCM_CLRGC8MARK (port);
 141   stream = SCM_STREAM (port);
 142   stream_mark_p = SCM_GCMARKP (stream);
 143   SCM_CLRGCMARK (stream);
 144   string = SCM_CDR (stream);
 145   string_mark_p = SCM_GC8MARKP (string);
 146   SCM_CLRGC8MARK (string);
 147 }
 148
 149
 150 static void remark_port SCM_P ((SCM port));
 151
 152 static void
 153 remark_port (port)
 154      SCM port;
 155 {
 156   SCM stream = SCM_STREAM (port);
 157   SCM string = SCM_CDR (stream);
 158   if (string_mark_p) SCM_SETGC8MARK (string);
 159   if (stream_mark_p) SCM_SETGCMARK (stream);
 160   if (port_mark_p) SCM_SETGC8MARK (port);
 161 }
 162
 163
 164 int
 165 gdb_maybe_valid_type_p (value)
 166      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 (str)
 176      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   /* Replace string in input port and reset stream */
 211   ans = SCM_CDR (SCM_STREAM (gdb_input_port));
 212   SCM_SETCHARS (ans, str);
 213   SCM_SETLENGTH (ans, strlen (str), scm_tc7_string);
 214   SCM_SETCAR (SCM_STREAM (gdb_input_port), SCM_INUM0);
 215   /* Read one object */
 216   tok_buf_mark_p = SCM_GC8MARKP (tok_buf);
 217   SCM_CLRGC8MARK (tok_buf);
 218   ans = scm_lreadr (&tok_buf, gdb_input_port, 0, SCM_BOOL_F, &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_SETGC8MARK (tok_buf);
 235   remark_port (gdb_input_port);
 236   SCM_END_FOREIGN_BLOCK;
 237   return status;
 238 }
 239
 240
 241 int
 242 gdb_eval (exp)
 243      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 (obj)
 268      SCM obj;
 269 {
 270   RESET_STRING;
 271   SCM_BEGIN_FOREIGN_BLOCK;
 272   /* Reset stream */
 273   SCM_SETCAR (SCM_STREAM (gdb_output_port), SCM_INUM0);
 274   scm_write (obj, gdb_output_port);
 275   scm_display (SCM_MAKICHR (0), gdb_output_port);
 276   SEND_STRING (SCM_CHARS (SCM_CDR (SCM_STREAM (gdb_output_port))));
 277   SCM_END_FOREIGN_BLOCK;
 278   return 0;
 279 }
 280
 281
 282 int
 283 gdb_binding (name, value)
 284      SCM name;
 285      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 (80), 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,
 321                         s);
 322   gdb_input_port = scm_permanent_object (port);
 323
 324   tok_buf = scm_permanent_object (scm_makstr (30L, 0));
 325 }