2004-02-14 Elena Zannoni <ezannoni@redhat.com>
[platform/upstream/binutils.git] / gdb / scm-valprint.c
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
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
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
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
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
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
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 }