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 *, 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 & 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, address, stream, format, deref_ref, recurse, 379 pretty) 380 struct type *type; 381 char *valaddr; 382 CORE_ADDR address; 383 GDB_FILE *stream; 384 int format; 385 int deref_ref; 386 int recurse; 387 enum val_prettyprint pretty; 388 { 389 if (is_scmvalue_type (type)) 390 { 391 LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type)); 392 if (scm_inferior_print (svalue, stream, format, 393 deref_ref, recurse, pretty) >= 0) 394 { 395 } 396 else 397 { 398 scm_scmval_print (svalue, stream, format, 399 deref_ref, recurse, pretty); 400 } 401 402 gdb_flush (stream); 403 return (0); 404 } 405 else 406 { 407 return c_val_print (type, valaddr, address, stream, format, 408 deref_ref, recurse, pretty); 409 } 410 } 411 412 int 413 scm_value_print (val, stream, format, pretty) 414 value_ptr val; 415 GDB_FILE *stream; 416 int format; 417 enum val_prettyprint pretty; 418 { 419 return (val_print (VALUE_TYPE (val), VALUE_CONTENTS (val), 420 VALUE_ADDRESS (val), stream, format, 1, 0, pretty)); 421 } 422