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 } 396