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