summaryrefslogtreecommitdiff
path: root/libguile/gdbint.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/gdbint.c')
-rw-r--r--libguile/gdbint.c291
1 files changed, 291 insertions, 0 deletions
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
new file mode 100644
index 000000000..df8e2c40c
--- /dev/null
+++ b/libguile/gdbint.c
@@ -0,0 +1,291 @@
+/* GDB interface for Guile
+ * Copyright (C) 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+#include <stdio.h>
+#include "_scm.h"
+
+
+/* {Support for debugging with gdb}
+ *
+ * TODO:
+ *
+ * 1. Redirect outputs
+ * 2. Catch errors
+ * 3. Prevent print from causing segmentation fault when given broken pairs
+ */
+
+#include <stdio.h>
+#include "_scm.h"
+
+#define GDB_TYPE SCM
+
+#include "gdb_interface.h"
+
+
+
+/* Be carefull when this macro is true.
+ scm_gc_heap_lock is set during gc.
+ */
+#define SCM_GC_P (scm_gc_heap_lock)
+
+/* Macros that encapsulate blocks of code which can be called by the
+ * debugger.
+ */
+#define SCM_BEGIN_FOREIGN_BLOCK \
+{ \
+ old_ints = scm_ints_disabled; scm_ints_disabled = 1; \
+ old_gc = scm_block_gc; scm_block_gc = 1; \
+ scm_print_carefully_p = 1; \
+} \
+
+
+#define SCM_END_FOREIGN_BLOCK \
+{ \
+ scm_print_carefully_p = 0; \
+ scm_block_gc = old_gc; \
+ scm_ints_disabled = old_ints; \
+} \
+
+
+#define RESET_STRING { gdb_output_length = 0; }
+
+#define SEND_STRING(str) \
+{ \
+ gdb_output = str; \
+ gdb_output_length = strlen (str); \
+}
+
+/* {Gdb interface}
+ */
+
+unsigned short gdb_options = GDB_HAVE_BINDINGS;
+
+char *gdb_language = "lisp/c";
+
+SCM gdb_result;
+
+char *gdb_output;
+
+int gdb_output_length;
+
+int scm_print_carefully_p;
+
+static SCM gdb_input_port;
+static SCM gdb_output_port;
+static int old_ints, old_gc;
+
+#ifdef __STDC__
+int
+gdb_maybe_valid_type_p (SCM value)
+#else
+int
+gdb_maybe_valid_type_p (value)
+ SCM value;
+#endif
+{
+ if (SCM_IMP (value) || scm_cellp (value))
+ return scm_tag (value) != SCM_MAKINUM (-1);
+ return 0;
+}
+
+#ifdef __STDC__
+int
+gdb_read (char *str)
+#else
+int
+gdb_read (str)
+ char *str;
+#endif
+{
+ SCM ans;
+ int status = 0;
+ RESET_STRING;
+ /* Need to be restrictive about what to read? */
+ if (SCM_GC_P)
+ {
+ char *p;
+ for (p = str; *p != '\0'; ++p)
+ switch (*p)
+ {
+ case '(':
+ case '\'':
+ case '"':
+ SEND_STRING ("Can't read this kind of expressions during gc");
+ return -1;
+ case '#':
+ if (*++p == '\0')
+ goto premature;
+ if (*p == '\\')
+ {
+ if (*++p != '\0')
+ continue;
+ premature:
+ SEND_STRING ("Premature end of lisp expression");
+ return -1;
+ }
+ default:
+ continue;
+ }
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ /* Replace string in input port and reset stream */
+ ans = SCM_CDR (SCM_STREAM (gdb_input_port));
+ SCM_SETCHARS (ans, str);
+ SCM_SETLENGTH (ans, strlen (str), scm_tc7_string);
+ SCM_SETCAR (SCM_STREAM (gdb_input_port), SCM_INUM0);
+ /* Read one object */
+ ans = scm_read (gdb_input_port, SCM_UNDEFINED, SCM_UNDEFINED);
+ if (SCM_GC_P)
+ {
+ if (!SCM_IMP (ans))
+ {
+ SEND_STRING ("Non-immediate created during gc. Memory may be trashed.");
+ status = -1;
+ goto exit;
+ }
+ }
+ /* Protect answer from future GC */
+ gdb_result = scm_permanent_object (ans);;
+exit:
+ SCM_END_FOREIGN_BLOCK;
+ return status;
+}
+
+#ifdef __STDC__
+int
+gdb_eval (SCM exp)
+#else
+int
+gdb_eval (exp)
+ SCM exp;
+#endif
+{
+ RESET_STRING;
+ if (SCM_IMP (exp))
+ {
+ gdb_result = exp;
+ return 0;
+ }
+ if (SCM_GC_P)
+ {
+ SEND_STRING ("Can't evaluate lisp expressions during gc");
+ return -1;
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ {
+ SCM env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_thunk_var));
+ gdb_result = scm_permanent_object (scm_ceval (exp, env));
+ }
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+#ifdef __STDC__
+int
+gdb_print (SCM obj)
+#else
+int
+gdb_print (obj)
+ SCM obj;
+#endif
+{
+ RESET_STRING;
+ SCM_BEGIN_FOREIGN_BLOCK;
+ /* Reset stream */
+ SCM_SETCAR (SCM_STREAM (gdb_output_port), SCM_INUM0);
+ scm_write (obj, gdb_output_port);
+ scm_display (SCM_MAKICHR (0), gdb_output_port);
+ SEND_STRING (SCM_CHARS (SCM_CDR (SCM_STREAM (gdb_output_port))));
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+#ifdef __STDC__
+int
+gdb_binding (SCM name, SCM value)
+#else
+int
+gdb_binding (name, value)
+ SCM name;
+ SCM value;
+#endif
+{
+ RESET_STRING;
+ if (SCM_GC_P)
+ {
+ SEND_STRING ("Can't create new bindings during gc");
+ return -1;
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ {
+ SCM vcell = scm_sym2vcell (name,
+ SCM_CDR (scm_top_level_lookup_thunk_var),
+ SCM_BOOL_T);
+ SCM_SETCDR (vcell, value);
+ }
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+void
+scm_init_gdbint ()
+{
+ static char *s = "scm_init_gdb_interface";
+ SCM port;
+
+ scm_print_carefully_p = 0;
+
+ port = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_MAKINUM (80), SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ s);
+ gdb_output_port = scm_permanent_object (port);
+
+ port = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
+ SCM_OPN | SCM_RDNG,
+ s);
+ gdb_input_port = scm_permanent_object (port);
+}