contrib/gdb-7/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, 2007, 2008, 2009,
   4    2010 Free Software 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 3 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, see <http://www.gnu.org/licenses/>.  */
  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 #include "c-lang.h"
  32 #include "infcall.h"
  33 #include "objfiles.h"
  34
  35 static void scm_ipruk (char *, struct type *, LONGEST, struct ui_file *);
  36 static void scm_scmval_print (struct type *, LONGEST, struct ui_file *,
  37                               int, const struct value_print_options *);
  38 static void scm_scmlist_print (struct type *, LONGEST, struct ui_file *,
  39                                int, const struct value_print_options *);
  40 static int scm_inferior_print (struct type *, LONGEST, struct ui_file *,
  41                                int, const struct value_print_options *);
  42
  43 /* Prints the SCM value VALUE by invoking the inferior, if appropraite.
  44    Returns >= 0 on success;  return -1 if the inferior cannot/should not
  45    print VALUE. */
  46
  47 static int
  48 scm_inferior_print (struct type *type, LONGEST value, struct ui_file *stream,
  49                     int recurse, const struct value_print_options *options)
  50 {
  51   struct value *func, *arg, *result;
  52   struct symbol *gdb_output_sym, *gdb_output_len_sym;
  53   char *output;
  54   int ret, output_len;
  55
  56   func = find_function_in_inferior ("gdb_print", NULL);
  57   arg = value_from_longest (type, value);
  58
  59   result = call_function_by_hand (func, 1, &arg);
  60   ret = (int) value_as_long (result);
  61   if (ret == 0)
  62     {
  63       /* XXX: Should we cache these symbols?  */
  64       gdb_output_sym =
  65         lookup_symbol_global ("gdb_output", NULL, VAR_DOMAIN);
  66       gdb_output_len_sym =
  67         lookup_symbol_global ("gdb_output_length", NULL, VAR_DOMAIN);
  68
  69       if ((gdb_output_sym == NULL) || (gdb_output_len_sym == NULL))
  70         ret = -1;
  71       else
  72         {
  73           struct value *remote_buffer;
  74
  75           read_memory (SYMBOL_VALUE_ADDRESS (gdb_output_len_sym),
  76                        (char *) &output_len, sizeof (output_len));
  77
  78           output = (char *) alloca (output_len);
  79           remote_buffer = value_at (type,
  80                                     SYMBOL_VALUE_ADDRESS (gdb_output_sym));
  81           read_memory (value_as_address (remote_buffer),
  82                        output, output_len);
  83
  84           ui_file_write (stream, output, output_len);
  85         }
  86     }
  87
  88   return ret;
  89 }
  90
  91 /* {Names of immediate symbols}
  92  * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/
  93
  94 static char *scm_isymnames[] =
  95 {
  96   /* This table must agree with the declarations */
  97   "and",
  98   "begin",
  99   "case",
 100   "cond",
 101   "do",
 102   "if",
 103   "lambda",
 104   "let",
 105   "let*",
 106   "letrec",
 107   "or",
 108   "quote",
 109   "set!",
 110   "define",
 111 #if 0
 112   "literal-variable-ref",
 113   "literal-variable-set!",
 114 #endif
 115   "apply",
 116   "call-with-current-continuation",
 117
 118  /* user visible ISYMS */
 119  /* other keywords */
 120  /* Flags */
 121
 122   "#f",
 123   "#t",
 124   "#<undefined>",
 125   "#<eof>",
 126   "()",
 127   "#<unspecified>"
 128 };
 129
 130 static void
 131 scm_scmlist_print (struct type *type, LONGEST svalue,
 132                    struct ui_file *stream, int recurse,
 133                    const struct value_print_options *options)
 134 {
 135 #define SCM_SIZE (TYPE_LENGTH (type))
 136 #define SCM_BYTE_ORDER (gdbarch_byte_order (get_type_arch (type)))
 137   unsigned int more = options->print_max;
 138
 139   if (recurse > 6)
 140     {
 141       fputs_filtered ("...", stream);
 142       return;
 143     }
 144   scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options);
 145   svalue = SCM_CDR (svalue);
 146   for (; SCM_NIMP (svalue); svalue = SCM_CDR (svalue))
 147     {
 148       if (SCM_NECONSP (svalue))
 149         break;
 150       fputs_filtered (" ", stream);
 151       if (--more == 0)
 152         {
 153           fputs_filtered ("...", stream);
 154           return;
 155         }
 156       scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options);
 157     }
 158   if (SCM_NNULLP (svalue))
 159     {
 160       fputs_filtered (" . ", stream);
 161       scm_scmval_print (type, svalue, stream, recurse + 1, options);
 162     }
 163 #undef SCM_BYTE_ORDER
 164 #undef SCM_SIZE
 165 }
 166
 167 static void
 168 scm_ipruk (char *hdr, struct type *type, LONGEST ptr,
 169            struct ui_file *stream)
 170 {
 171 #define SCM_SIZE (TYPE_LENGTH (type))
 172 #define SCM_BYTE_ORDER (gdbarch_byte_order (get_type_arch (type)))
 173   fprintf_filtered (stream, "#<unknown-%s", hdr);
 174   if (SCM_CELLP (ptr))
 175     fprintf_filtered (stream, " (0x%lx . 0x%lx) @",
 176                       (long) SCM_CAR (ptr), (long) SCM_CDR (ptr));
 177   fprintf_filtered (stream, " 0x%s>", phex_nz (ptr, SCM_SIZE));
 178 #undef SCM_BYTE_ORDER
 179 #undef SCM_SIZE
 180 }
 181
 182 static void
 183 scm_scmval_print (struct type *type, LONGEST svalue,
 184                   struct ui_file *stream, int recurse,
 185                   const struct value_print_options *options)
 186 {
 187   struct gdbarch *gdbarch = get_type_arch (type);
 188
 189 #define SCM_SIZE (TYPE_LENGTH (type))
 190 #define SCM_BYTE_ORDER (gdbarch_byte_order (gdbarch))
 191 taloop:
 192   switch (7 & (int) svalue)
 193     {
 194     case 2:
 195     case 6:
 196       print_longest (stream,
 197                      options->format ? options->format : 'd',
 198                      1, svalue >> 2);
 199       break;
 200     case 4:
 201       if (SCM_ICHRP (svalue))
 202         {
 203           svalue = SCM_ICHR (svalue);
 204           scm_printchar (svalue, builtin_type (gdbarch)->builtin_char,
 205                          stream);
 206           break;
 207         }
 208       else if (SCM_IFLAGP (svalue)
 209                && (SCM_ISYMNUM (svalue)
 210                    < (sizeof scm_isymnames / sizeof (char *))))
 211         {
 212           fputs_filtered (SCM_ISYMCHARS (svalue), stream);
 213           break;
 214         }
 215       else if (SCM_ILOCP (svalue))
 216         {
 217           fprintf_filtered (stream, "#@%ld%c%ld",
 218                             (long) SCM_IFRAME (svalue),
 219                             SCM_ICDRP (svalue) ? '-' : '+',
 220                             (long) SCM_IDIST (svalue));
 221           break;
 222         }
 223       else
 224         goto idef;
 225       break;
 226     case 1:
 227       /* gloc */
 228       svalue = SCM_CAR (svalue - 1);
 229       goto taloop;
 230     default:
 231     idef:
 232       scm_ipruk ("immediate", type, svalue, stream);
 233       break;
 234     case 0:
 235
 236       switch (SCM_TYP7 (svalue))
 237         {
 238         case scm_tcs_cons_gloc:
 239           if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0)
 240             {
 241 #if 0
 242               SCM name;
 243 #endif
 244
 245               fputs_filtered ("#<latte ", stream);
 246 #if 1
 247               fputs_filtered ("???", stream);
 248 #else
 249               name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name];
 250               scm_lfwrite (CHARS (name),
 251                            (sizet) sizeof (char),
 252                              (sizet) LENGTH (name),
 253                            port);
 254 #endif
 255               fprintf_filtered (stream, " #X%s>", phex_nz (svalue, SCM_SIZE));
 256               break;
 257             }
 258         case scm_tcs_cons_imcar:
 259         case scm_tcs_cons_nimcar:
 260           fputs_filtered ("(", stream);
 261           scm_scmlist_print (type, svalue, stream, recurse + 1, options);
 262           fputs_filtered (")", stream);
 263           break;
 264         case scm_tcs_closures:
 265           fputs_filtered ("#<CLOSURE ", stream);
 266           scm_scmlist_print (type, SCM_CODE (svalue), stream,
 267                              recurse + 1, options);
 268           fputs_filtered (">", stream);
 269           break;
 270         case scm_tc7_string:
 271           {
 272             int len = SCM_LENGTH (svalue);
 273             CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue);
 274             int i;
 275             int done = 0;
 276             int buf_size;
 277             gdb_byte buffer[64];
 278             int truncate = options->print_max && len > (int) options->print_max;
 279             if (truncate)
 280               len = options->print_max;
 281             fputs_filtered ("\"", stream);
 282             for (; done < len; done += buf_size)
 283               {
 284                 buf_size = min (len - done, 64);
 285                 read_memory (addr + done, buffer, buf_size);
 286
 287                 for (i = 0; i < buf_size; ++i)
 288                   switch (buffer[i])
 289                     {
 290                     case '\"':
 291                     case '\\':
 292                       fputs_filtered ("\\", stream);
 293                     default:
 294                       fprintf_filtered (stream, "%c", buffer[i]);
 295                     }
 296               }
 297             fputs_filtered (truncate ? "...\"" : "\"", stream);
 298             break;
 299           }
 300           break;
 301         case scm_tcs_symbols:
 302           {
 303             int len = SCM_LENGTH (svalue);
 304
 305             char *str = alloca (len);
 306             read_memory (SCM_CDR (svalue), (gdb_byte *) str, len + 1);
 307             /* Should handle weird characters FIXME */
 308             str[len] = '\0';
 309             fputs_filtered (str, stream);
 310             break;
 311           }
 312         case scm_tc7_vector:
 313           {
 314             int len = SCM_LENGTH (svalue);
 315             int i;
 316             LONGEST elements = SCM_CDR (svalue);
 317             LONGEST val;
 318
 319             fputs_filtered ("#(", stream);
 320             for (i = 0; i < len; ++i)
 321               {
 322                 if (i > 0)
 323                   fputs_filtered (" ", stream);
 324                 val = scm_get_field (elements, i, SCM_SIZE, SCM_BYTE_ORDER);
 325                 scm_scmval_print (type, val, stream, recurse + 1, options);
 326               }
 327             fputs_filtered (")", stream);
 328           }
 329           break;
 330 #if 0
 331         case tc7_lvector:
 332           {
 333             SCM result;
 334             SCM hook;
 335
 336             hook = scm_get_lvector_hook (exp, LV_PRINT_FN);
 337             if (hook == BOOL_F)
 338               {
 339                 scm_puts ("#<locked-vector ", port);
 340                 scm_intprint (CDR (exp), 16, port);
 341                 scm_puts (">", port);
 342               }
 343             else
 344               {
 345                 result
 346                   = scm_apply (hook,
 347                                scm_listify (exp, port,
 348                                             (writing ? BOOL_T : BOOL_F),
 349                                             SCM_UNDEFINED),
 350                                EOL);
 351                 if (result == BOOL_F)
 352                   goto punk;
 353               }
 354             break;
 355           }
 356           break;
 357         case tc7_bvect:
 358         case tc7_ivect:
 359         case tc7_uvect:
 360         case tc7_fvect:
 361         case tc7_dvect:
 362         case tc7_cvect:
 363           scm_raprin1 (exp, port, writing);
 364           break;
 365 #endif
 366         case scm_tcs_subrs:
 367           {
 368             int index = SCM_CAR (svalue) >> 8;
 369 #if 1
 370             char str[20];
 371             sprintf (str, "#%d", index);
 372 #else
 373             char *str = index ? SCM_CHARS (scm_heap_org + index) : "";
 374 #define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
 375             char *str = CHARS (SNAME (exp));
 376 #endif
 377
 378             fprintf_filtered (stream, "#<primitive-procedure %s>",
 379                               str);
 380           }
 381           break;
 382 #if 0
 383 #ifdef CCLO
 384         case tc7_cclo:
 385           scm_puts ("#<compiled-closure ", port);
 386           scm_iprin1 (CCLO_SUBR (exp), port, writing);
 387           scm_putc ('>', port);
 388           break;
 389 #endif
 390         case tc7_contin:
 391           fprintf_filtered (stream, "#<continuation %d @ #X%lx >",
 392                             LENGTH (svalue),
 393                             (long) CHARS (svalue));
 394           break;
 395         case tc7_port:
 396           i = PTOBNUM (exp);
 397           if (i < scm_numptob
 398               && scm_ptobs[i].print
 399               && (scm_ptobs[i].print) (exp, port, writing))
 400             break;
 401           goto punk;
 402         case tc7_smob:
 403           i = SMOBNUM (exp);
 404           if (i < scm_numsmob && scm_smobs[i].print
 405               && (scm_smobs[i].print) (exp, port, writing))
 406             break;
 407           goto punk;
 408 #endif
 409         default:
 410 #if 0
 411         punk:
 412 #endif
 413           scm_ipruk ("type", type, svalue, stream);
 414         }
 415       break;
 416     }
 417 #undef SCM_BYTE_ORDER
 418 #undef SCM_SIZE
 419 }
 420
 421 int
 422 scm_val_print (struct type *type, const gdb_byte *valaddr,
 423                int embedded_offset, CORE_ADDR address,
 424                struct ui_file *stream, int recurse,
 425                const struct value *val,
 426                const struct value_print_options *options)
 427 {
 428   if (is_scmvalue_type (type)
 429       && value_bits_valid (val, TARGET_CHAR_BIT * embedded_offset,
 430                            TARGET_CHAR_BIT * TYPE_LENGTH (type)))
 431     {
 432       enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
 433       LONGEST svalue
 434         = extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order);
 435
 436       if (scm_inferior_print (type, svalue, stream, recurse, options) >= 0)
 437         {
 438         }
 439       else
 440         {
 441           scm_scmval_print (type, svalue, stream, recurse, options);
 442         }
 443
 444       gdb_flush (stream);
 445       return (0);
 446     }
 447   else
 448     {
 449       return c_val_print (type, valaddr, 0, address, stream, recurse,
 450                           val, options);
 451     }
 452 }
 453
 454 int
 455 scm_value_print (struct value *val, struct ui_file *stream,
 456                  const struct value_print_options *options)
 457 {
 458   struct value_print_options opts = *options;
 459
 460   opts.deref_ref = 1;
 461   return (common_val_print (val, stream, 0, &opts, current_language));
 462 }