gdb/scm-valprint.c

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