1 /* Scheme/Guile language support routines for GDB, the GNU debugger.
2 Copyright 1995, 1996, 1998, 1999, 2000, 2001
3 Free Software Foundation, Inc.
4
5 This file is part of GDB.
6
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 #include "defs.h"
23 #include "symtab.h"
24 #include "gdbtypes.h"
25 #include "expression.h"
26 #include "parser-defs.h"
27 #include "language.h"
28 #include "value.h"
29 #include "scm-lang.h"
30 #include "valprint.h"
31 #include "gdbcore.h"
32
33 /* FIXME: Should be in a header file that we import. */
34 extern int c_val_print (struct type *, char *, int, CORE_ADDR,
35 struct ui_file *, int, int, int,
36 enum val_prettyprint);
37
38 static void scm_ipruk (char *, LONGEST, struct ui_file *);
39 static void scm_scmlist_print (LONGEST, struct ui_file *, int, int,
40 int, enum val_prettyprint);
41 static int scm_inferior_print (LONGEST, struct ui_file *, int, int,
42 int, enum val_prettyprint);
43
44 /* Prints the SCM value VALUE by invoking the inferior, if appropraite.
45 Returns >= 0 on succes; retunr -1 if the inferior cannot/should not
46 print VALUE. */
47
48 static int
scm_inferior_print(LONGEST value,struct ui_file * stream,int format,int deref_ref,int recurse,enum val_prettyprint pretty)49 scm_inferior_print (LONGEST value, struct ui_file *stream, int format,
50 int deref_ref, int recurse, enum val_prettyprint pretty)
51 {
52 return -1;
53 }
54
55 /* {Names of immediate symbols}
56 * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/
57
58 static char *scm_isymnames[] =
59 {
60 /* This table must agree with the declarations */
61 "and",
62 "begin",
63 "case",
64 "cond",
65 "do",
66 "if",
67 "lambda",
68 "let",
69 "let*",
70 "letrec",
71 "or",
72 "quote",
73 "set!",
74 "define",
75 #if 0
76 "literal-variable-ref",
77 "literal-variable-set!",
78 #endif
79 "apply",
80 "call-with-current-continuation",
81
82 /* user visible ISYMS */
83 /* other keywords */
84 /* Flags */
85
86 "#f",
87 "#t",
88 "#<undefined>",
89 "#<eof>",
90 "()",
91 "#<unspecified>"
92 };
93
94 static void
scm_scmlist_print(LONGEST svalue,struct ui_file * stream,int format,int deref_ref,int recurse,enum val_prettyprint pretty)95 scm_scmlist_print (LONGEST svalue, struct ui_file *stream, int format,
96 int deref_ref, int recurse, enum val_prettyprint pretty)
97 {
98 unsigned int more = print_max;
99 if (recurse > 6)
100 {
101 fputs_filtered ("...", stream);
102 return;
103 }
104 scm_scmval_print (SCM_CAR (svalue), stream, format,
105 deref_ref, recurse + 1, pretty);
106 svalue = SCM_CDR (svalue);
107 for (; SCM_NIMP (svalue); svalue = SCM_CDR (svalue))
108 {
109 if (SCM_NECONSP (svalue))
110 break;
111 fputs_filtered (" ", stream);
112 if (--more == 0)
113 {
114 fputs_filtered ("...", stream);
115 return;
116 }
117 scm_scmval_print (SCM_CAR (svalue), stream, format,
118 deref_ref, recurse + 1, pretty);
119 }
120 if (SCM_NNULLP (svalue))
121 {
122 fputs_filtered (" . ", stream);
123 scm_scmval_print (svalue, stream, format,
124 deref_ref, recurse + 1, pretty);
125 }
126 }
127
128 static void
scm_ipruk(char * hdr,LONGEST ptr,struct ui_file * stream)129 scm_ipruk (char *hdr, LONGEST ptr, struct ui_file *stream)
130 {
131 fprintf_filtered (stream, "#<unknown-%s", hdr);
132 #define SCM_SIZE TYPE_LENGTH (builtin_type_scm)
133 if (SCM_CELLP (ptr))
134 fprintf_filtered (stream, " (0x%lx . 0x%lx) @",
135 (long) SCM_CAR (ptr), (long) SCM_CDR (ptr));
136 fprintf_filtered (stream, " 0x%s>", paddr_nz (ptr));
137 }
138
139 void
scm_scmval_print(LONGEST svalue,struct ui_file * stream,int format,int deref_ref,int recurse,enum val_prettyprint pretty)140 scm_scmval_print (LONGEST svalue, struct ui_file *stream, int format,
141 int deref_ref, int recurse, enum val_prettyprint pretty)
142 {
143 taloop:
144 switch (7 & (int) svalue)
145 {
146 case 2:
147 case 6:
148 print_longest (stream, format ? format : 'd', 1, svalue >> 2);
149 break;
150 case 4:
151 if (SCM_ICHRP (svalue))
152 {
153 svalue = SCM_ICHR (svalue);
154 scm_printchar (svalue, stream);
155 break;
156 }
157 else if (SCM_IFLAGP (svalue)
158 && (SCM_ISYMNUM (svalue)
159 < (sizeof scm_isymnames / sizeof (char *))))
160 {
161 fputs_filtered (SCM_ISYMCHARS (svalue), stream);
162 break;
163 }
164 else if (SCM_ILOCP (svalue))
165 {
166 fprintf_filtered (stream, "#@%ld%c%ld",
167 (long) SCM_IFRAME (svalue),
168 SCM_ICDRP (svalue) ? '-' : '+',
169 (long) SCM_IDIST (svalue));
170 break;
171 }
172 else
173 goto idef;
174 break;
175 case 1:
176 /* gloc */
177 svalue = SCM_CAR (svalue - 1);
178 goto taloop;
179 default:
180 idef:
181 scm_ipruk ("immediate", svalue, stream);
182 break;
183 case 0:
184
185 switch (SCM_TYP7 (svalue))
186 {
187 case scm_tcs_cons_gloc:
188 if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0)
189 {
190 #if 0
191 SCM name;
192 #endif
193 fputs_filtered ("#<latte ", stream);
194 #if 1
195 fputs_filtered ("???", stream);
196 #else
197 name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name];
198 scm_lfwrite (CHARS (name),
199 (sizet) sizeof (char),
200 (sizet) LENGTH (name),
201 port);
202 #endif
203 fprintf_filtered (stream, " #X%s>", paddr_nz (svalue));
204 break;
205 }
206 case scm_tcs_cons_imcar:
207 case scm_tcs_cons_nimcar:
208 fputs_filtered ("(", stream);
209 scm_scmlist_print (svalue, stream, format,
210 deref_ref, recurse + 1, pretty);
211 fputs_filtered (")", stream);
212 break;
213 case scm_tcs_closures:
214 fputs_filtered ("#<CLOSURE ", stream);
215 scm_scmlist_print (SCM_CODE (svalue), stream, format,
216 deref_ref, recurse + 1, pretty);
217 fputs_filtered (">", stream);
218 break;
219 case scm_tc7_string:
220 {
221 int len = SCM_LENGTH (svalue);
222 CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue);
223 int i;
224 int done = 0;
225 int buf_size;
226 char buffer[64];
227 int truncate = print_max && len > (int) print_max;
228 if (truncate)
229 len = print_max;
230 fputs_filtered ("\"", stream);
231 for (; done < len; done += buf_size)
232 {
233 buf_size = min (len - done, 64);
234 read_memory (addr + done, buffer, buf_size);
235
236 for (i = 0; i < buf_size; ++i)
237 switch (buffer[i])
238 {
239 case '\"':
240 case '\\':
241 fputs_filtered ("\\", stream);
242 default:
243 fprintf_filtered (stream, "%c", buffer[i]);
244 }
245 }
246 fputs_filtered (truncate ? "...\"" : "\"", stream);
247 break;
248 }
249 break;
250 case scm_tcs_symbols:
251 {
252 int len = SCM_LENGTH (svalue);
253
254 char *str = (char *) alloca (len);
255 read_memory (SCM_CDR (svalue), str, len + 1);
256 /* Should handle weird characters FIXME */
257 str[len] = '\0';
258 fputs_filtered (str, stream);
259 break;
260 }
261 case scm_tc7_vector:
262 {
263 int len = SCM_LENGTH (svalue);
264 int i;
265 LONGEST elements = SCM_CDR (svalue);
266 fputs_filtered ("#(", stream);
267 for (i = 0; i < len; ++i)
268 {
269 if (i > 0)
270 fputs_filtered (" ", stream);
271 scm_scmval_print (scm_get_field (elements, i), stream, format,
272 deref_ref, recurse + 1, pretty);
273 }
274 fputs_filtered (")", stream);
275 }
276 break;
277 #if 0
278 case tc7_lvector:
279 {
280 SCM result;
281 SCM hook;
282 hook = scm_get_lvector_hook (exp, LV_PRINT_FN);
283 if (hook == BOOL_F)
284 {
285 scm_puts ("#<locked-vector ", port);
286 scm_intprint (CDR (exp), 16, port);
287 scm_puts (">", port);
288 }
289 else
290 {
291 result
292 = scm_apply (hook,
293 scm_listify (exp, port, (writing ? BOOL_T : BOOL_F),
294 SCM_UNDEFINED),
295 EOL);
296 if (result == BOOL_F)
297 goto punk;
298 }
299 break;
300 }
301 break;
302 case tc7_bvect:
303 case tc7_ivect:
304 case tc7_uvect:
305 case tc7_fvect:
306 case tc7_dvect:
307 case tc7_cvect:
308 scm_raprin1 (exp, port, writing);
309 break;
310 #endif
311 case scm_tcs_subrs:
312 {
313 int index = SCM_CAR (svalue) >> 8;
314 #if 1
315 char str[20];
316 sprintf (str, "#%d", index);
317 #else
318 char *str = index ? SCM_CHARS (scm_heap_org + index) : "";
319 #define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
320 char *str = CHARS (SNAME (exp));
321 #endif
322 fprintf_filtered (stream, "#<primitive-procedure %s>",
323 str);
324 }
325 break;
326 #if 0
327 #ifdef CCLO
328 case tc7_cclo:
329 scm_puts ("#<compiled-closure ", port);
330 scm_iprin1 (CCLO_SUBR (exp), port, writing);
331 scm_putc ('>', port);
332 break;
333 #endif
334 case tc7_contin:
335 fprintf_filtered (stream, "#<continuation %d @ #X%lx >",
336 LENGTH (svalue),
337 (long) CHARS (svalue));
338 break;
339 case tc7_port:
340 i = PTOBNUM (exp);
341 if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing))
342 break;
343 goto punk;
344 case tc7_smob:
345 i = SMOBNUM (exp);
346 if (i < scm_numsmob && scm_smobs[i].print
347 && (scm_smobs[i].print) (exp, port, writing))
348 break;
349 goto punk;
350 #endif
351 default:
352 #if 0
353 punk:
354 #endif
355 scm_ipruk ("type", svalue, stream);
356 }
357 break;
358 }
359 }
360
361 int
scm_val_print(struct type * type,char * valaddr,int embedded_offset,CORE_ADDR address,struct ui_file * stream,int format,int deref_ref,int recurse,enum val_prettyprint pretty)362 scm_val_print (struct type *type, char *valaddr, int embedded_offset,
363 CORE_ADDR address, struct ui_file *stream, int format,
364 int deref_ref, int recurse, enum val_prettyprint pretty)
365 {
366 if (is_scmvalue_type (type))
367 {
368 LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
369 if (scm_inferior_print (svalue, stream, format,
370 deref_ref, recurse, pretty) >= 0)
371 {
372 }
373 else
374 {
375 scm_scmval_print (svalue, stream, format,
376 deref_ref, recurse, pretty);
377 }
378
379 gdb_flush (stream);
380 return (0);
381 }
382 else
383 {
384 return c_val_print (type, valaddr, 0, address, stream, format,
385 deref_ref, recurse, pretty);
386 }
387 }
388
389 int
scm_value_print(struct value * val,struct ui_file * stream,int format,enum val_prettyprint pretty)390 scm_value_print (struct value *val, struct ui_file *stream, int format,
391 enum val_prettyprint pretty)
392 {
393 return (val_print (VALUE_TYPE (val), VALUE_CONTENTS (val), 0,
394 VALUE_ADDRESS (val), stream, format, 1, 0, pretty));
395 }
396