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