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