Commit | Line | Data |
---|---|---|
4907ff5a MD |
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 | } |