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