119370Spst/* Scheme/Guile language support routines for GDB, the GNU debugger. 298944Sobrien Copyright 1995, 1996, 1998, 1999, 2000, 2001 398944Sobrien Free Software Foundation, Inc. 419370Spst 598944Sobrien This file is part of GDB. 619370Spst 798944Sobrien This program is free software; you can redistribute it and/or modify 898944Sobrien it under the terms of the GNU General Public License as published by 998944Sobrien the Free Software Foundation; either version 2 of the License, or 1098944Sobrien (at your option) any later version. 1119370Spst 1298944Sobrien This program is distributed in the hope that it will be useful, 1398944Sobrien but WITHOUT ANY WARRANTY; without even the implied warranty of 1498944Sobrien MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1598944Sobrien GNU General Public License for more details. 1619370Spst 1798944Sobrien You should have received a copy of the GNU General Public License 1898944Sobrien along with this program; if not, write to the Free Software 1998944Sobrien Foundation, Inc., 59 Temple Place - Suite 330, 2098944Sobrien Boston, MA 02111-1307, USA. */ 2119370Spst 2219370Spst#include "defs.h" 2319370Spst#include "symtab.h" 2419370Spst#include "gdbtypes.h" 2519370Spst#include "expression.h" 2619370Spst#include "parser-defs.h" 2719370Spst#include "language.h" 2819370Spst#include "value.h" 2919370Spst#include "scm-lang.h" 3019370Spst#include "valprint.h" 3146283Sdfr#include "gdbcore.h" 3219370Spst 3346283Sdfr/* FIXME: Should be in a header file that we import. */ 3498944Sobrienextern int c_val_print (struct type *, char *, int, CORE_ADDR, 3598944Sobrien struct ui_file *, int, int, int, 3698944Sobrien enum val_prettyprint); 3746283Sdfr 3898944Sobrienstatic void scm_ipruk (char *, LONGEST, struct ui_file *); 3998944Sobrienstatic void scm_scmlist_print (LONGEST, struct ui_file *, int, int, 4098944Sobrien int, enum val_prettyprint); 4198944Sobrienstatic int scm_inferior_print (LONGEST, struct ui_file *, int, int, 4298944Sobrien int, enum val_prettyprint); 4346283Sdfr 4419370Spst/* Prints the SCM value VALUE by invoking the inferior, if appropraite. 4519370Spst Returns >= 0 on succes; retunr -1 if the inferior cannot/should not 4619370Spst print VALUE. */ 4719370Spst 4846283Sdfrstatic int 4998944Sobrienscm_inferior_print (LONGEST value, struct ui_file *stream, int format, 5098944Sobrien int deref_ref, int recurse, enum val_prettyprint pretty) 5119370Spst{ 5219370Spst return -1; 5319370Spst} 5419370Spst 5519370Spst/* {Names of immediate symbols} 5619370Spst * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/ 5719370Spst 5819370Spststatic char *scm_isymnames[] = 5919370Spst{ 6019370Spst /* This table must agree with the declarations */ 6119370Spst "and", 6219370Spst "begin", 6319370Spst "case", 6419370Spst "cond", 6519370Spst "do", 6619370Spst "if", 6719370Spst "lambda", 6819370Spst "let", 6919370Spst "let*", 7019370Spst "letrec", 7119370Spst "or", 7219370Spst "quote", 7319370Spst "set!", 7419370Spst "define", 7519370Spst#if 0 7619370Spst "literal-variable-ref", 7719370Spst "literal-variable-set!", 7819370Spst#endif 7919370Spst "apply", 8019370Spst "call-with-current-continuation", 8119370Spst 8219370Spst /* user visible ISYMS */ 8319370Spst /* other keywords */ 8419370Spst /* Flags */ 8519370Spst 8619370Spst "#f", 8719370Spst "#t", 8819370Spst "#<undefined>", 8919370Spst "#<eof>", 9019370Spst "()", 9119370Spst "#<unspecified>" 9219370Spst}; 9319370Spst 9446283Sdfrstatic void 9598944Sobrienscm_scmlist_print (LONGEST svalue, struct ui_file *stream, int format, 9698944Sobrien int deref_ref, int recurse, enum val_prettyprint pretty) 9719370Spst{ 9819370Spst unsigned int more = print_max; 9919370Spst if (recurse > 6) 10019370Spst { 10119370Spst fputs_filtered ("...", stream); 10246283Sdfr return; 10319370Spst } 10419370Spst scm_scmval_print (SCM_CAR (svalue), stream, format, 10519370Spst deref_ref, recurse + 1, pretty); 10619370Spst svalue = SCM_CDR (svalue); 10719370Spst for (; SCM_NIMP (svalue); svalue = SCM_CDR (svalue)) 10819370Spst { 10919370Spst if (SCM_NECONSP (svalue)) 11019370Spst break; 11119370Spst fputs_filtered (" ", stream); 11219370Spst if (--more == 0) 11319370Spst { 11419370Spst fputs_filtered ("...", stream); 11519370Spst return; 11619370Spst } 11719370Spst scm_scmval_print (SCM_CAR (svalue), stream, format, 11819370Spst deref_ref, recurse + 1, pretty); 11919370Spst } 12019370Spst if (SCM_NNULLP (svalue)) 12119370Spst { 12219370Spst fputs_filtered (" . ", stream); 12319370Spst scm_scmval_print (svalue, stream, format, 12419370Spst deref_ref, recurse + 1, pretty); 12519370Spst } 12619370Spst} 12719370Spst 12819370Spststatic void 12998944Sobrienscm_ipruk (char *hdr, LONGEST ptr, struct ui_file *stream) 13019370Spst{ 13119370Spst fprintf_filtered (stream, "#<unknown-%s", hdr); 13219370Spst#define SCM_SIZE TYPE_LENGTH (builtin_type_scm) 13319370Spst if (SCM_CELLP (ptr)) 13419370Spst fprintf_filtered (stream, " (0x%lx . 0x%lx) @", 13519370Spst (long) SCM_CAR (ptr), (long) SCM_CDR (ptr)); 13698944Sobrien fprintf_filtered (stream, " 0x%s>", paddr_nz (ptr)); 13719370Spst} 13819370Spst 13946283Sdfrvoid 14098944Sobrienscm_scmval_print (LONGEST svalue, struct ui_file *stream, int format, 14198944Sobrien int deref_ref, int recurse, enum val_prettyprint pretty) 14219370Spst{ 14398944Sobrientaloop: 14446283Sdfr switch (7 & (int) svalue) 14519370Spst { 14619370Spst case 2: 14719370Spst case 6: 14819370Spst print_longest (stream, format ? format : 'd', 1, svalue >> 2); 14919370Spst break; 15019370Spst case 4: 15119370Spst if (SCM_ICHRP (svalue)) 15219370Spst { 15319370Spst svalue = SCM_ICHR (svalue); 15419370Spst scm_printchar (svalue, stream); 15519370Spst break; 15619370Spst } 15719370Spst else if (SCM_IFLAGP (svalue) 15819370Spst && (SCM_ISYMNUM (svalue) 15919370Spst < (sizeof scm_isymnames / sizeof (char *)))) 16019370Spst { 16119370Spst fputs_filtered (SCM_ISYMCHARS (svalue), stream); 16219370Spst break; 16319370Spst } 16419370Spst else if (SCM_ILOCP (svalue)) 16519370Spst { 16619370Spst fprintf_filtered (stream, "#@%ld%c%ld", 16719370Spst (long) SCM_IFRAME (svalue), 16819370Spst SCM_ICDRP (svalue) ? '-' : '+', 16919370Spst (long) SCM_IDIST (svalue)); 17019370Spst break; 17119370Spst } 17219370Spst else 17319370Spst goto idef; 17419370Spst break; 17519370Spst case 1: 17619370Spst /* gloc */ 17719370Spst svalue = SCM_CAR (svalue - 1); 17819370Spst goto taloop; 17919370Spst default: 18019370Spst idef: 18119370Spst scm_ipruk ("immediate", svalue, stream); 18219370Spst break; 18319370Spst case 0: 18419370Spst 18519370Spst switch (SCM_TYP7 (svalue)) 18619370Spst { 18719370Spst case scm_tcs_cons_gloc: 18819370Spst if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0) 18919370Spst { 19046283Sdfr#if 0 19119370Spst SCM name; 19246283Sdfr#endif 19319370Spst fputs_filtered ("#<latte ", stream); 19419370Spst#if 1 19519370Spst fputs_filtered ("???", stream); 19619370Spst#else 19798944Sobrien name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name]; 19819370Spst scm_lfwrite (CHARS (name), 19919370Spst (sizet) sizeof (char), 20098944Sobrien (sizet) LENGTH (name), 20119370Spst port); 20219370Spst#endif 20398944Sobrien fprintf_filtered (stream, " #X%s>", paddr_nz (svalue)); 20419370Spst break; 20519370Spst } 20619370Spst case scm_tcs_cons_imcar: 20719370Spst case scm_tcs_cons_nimcar: 20819370Spst fputs_filtered ("(", stream); 20919370Spst scm_scmlist_print (svalue, stream, format, 21019370Spst deref_ref, recurse + 1, pretty); 21119370Spst fputs_filtered (")", stream); 21219370Spst break; 21319370Spst case scm_tcs_closures: 21419370Spst fputs_filtered ("#<CLOSURE ", stream); 21519370Spst scm_scmlist_print (SCM_CODE (svalue), stream, format, 21619370Spst deref_ref, recurse + 1, pretty); 21719370Spst fputs_filtered (">", stream); 21819370Spst break; 21919370Spst case scm_tc7_string: 22019370Spst { 22119370Spst int len = SCM_LENGTH (svalue); 22219370Spst CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue); 22319370Spst int i; 22419370Spst int done = 0; 22519370Spst int buf_size; 22619370Spst char buffer[64]; 22719370Spst int truncate = print_max && len > (int) print_max; 22819370Spst if (truncate) 22919370Spst len = print_max; 23019370Spst fputs_filtered ("\"", stream); 23119370Spst for (; done < len; done += buf_size) 23219370Spst { 23319370Spst buf_size = min (len - done, 64); 23419370Spst read_memory (addr + done, buffer, buf_size); 23598944Sobrien 23619370Spst for (i = 0; i < buf_size; ++i) 23719370Spst switch (buffer[i]) 23819370Spst { 23919370Spst case '\"': 24019370Spst case '\\': 24119370Spst fputs_filtered ("\\", stream); 24219370Spst default: 24319370Spst fprintf_filtered (stream, "%c", buffer[i]); 24419370Spst } 24519370Spst } 24619370Spst fputs_filtered (truncate ? "...\"" : "\"", stream); 24719370Spst break; 24819370Spst } 24919370Spst break; 25019370Spst case scm_tcs_symbols: 25119370Spst { 25219370Spst int len = SCM_LENGTH (svalue); 25319370Spst 25498944Sobrien char *str = (char *) alloca (len); 25519370Spst read_memory (SCM_CDR (svalue), str, len + 1); 25619370Spst /* Should handle weird characters FIXME */ 25719370Spst str[len] = '\0'; 25819370Spst fputs_filtered (str, stream); 25919370Spst break; 26019370Spst } 26119370Spst case scm_tc7_vector: 26219370Spst { 26319370Spst int len = SCM_LENGTH (svalue); 26419370Spst int i; 26598944Sobrien LONGEST elements = SCM_CDR (svalue); 26619370Spst fputs_filtered ("#(", stream); 26719370Spst for (i = 0; i < len; ++i) 26819370Spst { 26919370Spst if (i > 0) 27019370Spst fputs_filtered (" ", stream); 27119370Spst scm_scmval_print (scm_get_field (elements, i), stream, format, 27219370Spst deref_ref, recurse + 1, pretty); 27319370Spst } 27419370Spst fputs_filtered (")", stream); 27519370Spst } 27619370Spst break; 27719370Spst#if 0 27819370Spst case tc7_lvector: 27919370Spst { 28019370Spst SCM result; 28119370Spst SCM hook; 28219370Spst hook = scm_get_lvector_hook (exp, LV_PRINT_FN); 28319370Spst if (hook == BOOL_F) 28419370Spst { 28519370Spst scm_puts ("#<locked-vector ", port); 28698944Sobrien scm_intprint (CDR (exp), 16, port); 28719370Spst scm_puts (">", port); 28819370Spst } 28919370Spst else 29019370Spst { 29119370Spst result 29219370Spst = scm_apply (hook, 29398944Sobrien scm_listify (exp, port, (writing ? BOOL_T : BOOL_F), 29498944Sobrien SCM_UNDEFINED), 29519370Spst EOL); 29619370Spst if (result == BOOL_F) 29719370Spst goto punk; 29819370Spst } 29919370Spst break; 30019370Spst } 30119370Spst break; 30219370Spst case tc7_bvect: 30319370Spst case tc7_ivect: 30419370Spst case tc7_uvect: 30519370Spst case tc7_fvect: 30619370Spst case tc7_dvect: 30719370Spst case tc7_cvect: 30819370Spst scm_raprin1 (exp, port, writing); 30919370Spst break; 31019370Spst#endif 31119370Spst case scm_tcs_subrs: 31219370Spst { 31319370Spst int index = SCM_CAR (svalue) >> 8; 31419370Spst#if 1 31519370Spst char str[20]; 31619370Spst sprintf (str, "#%d", index); 31719370Spst#else 31898944Sobrien char *str = index ? SCM_CHARS (scm_heap_org + index) : ""; 31919370Spst#define SCM_CHARS(x) ((char *)(SCM_CDR(x))) 32019370Spst char *str = CHARS (SNAME (exp)); 32119370Spst#endif 32219370Spst fprintf_filtered (stream, "#<primitive-procedure %s>", 32319370Spst str); 32419370Spst } 32519370Spst break; 32619370Spst#if 0 32719370Spst#ifdef CCLO 32819370Spst case tc7_cclo: 32919370Spst scm_puts ("#<compiled-closure ", port); 33019370Spst scm_iprin1 (CCLO_SUBR (exp), port, writing); 33119370Spst scm_putc ('>', port); 33219370Spst break; 33319370Spst#endif 33419370Spst case tc7_contin: 33519370Spst fprintf_filtered (stream, "#<continuation %d @ #X%lx >", 33619370Spst LENGTH (svalue), 33719370Spst (long) CHARS (svalue)); 33819370Spst break; 33919370Spst case tc7_port: 34019370Spst i = PTOBNUM (exp); 34119370Spst if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing)) 34219370Spst break; 34319370Spst goto punk; 34419370Spst case tc7_smob: 34519370Spst i = SMOBNUM (exp); 34619370Spst if (i < scm_numsmob && scm_smobs[i].print 34719370Spst && (scm_smobs[i].print) (exp, port, writing)) 34819370Spst break; 34919370Spst goto punk; 35019370Spst#endif 35119370Spst default: 35246283Sdfr#if 0 35346283Sdfr punk: 35446283Sdfr#endif 35546283Sdfr scm_ipruk ("type", svalue, stream); 35619370Spst } 35719370Spst break; 35819370Spst } 35919370Spst} 36019370Spst 36119370Spstint 36298944Sobrienscm_val_print (struct type *type, char *valaddr, int embedded_offset, 36398944Sobrien CORE_ADDR address, struct ui_file *stream, int format, 36498944Sobrien int deref_ref, int recurse, enum val_prettyprint pretty) 36519370Spst{ 36619370Spst if (is_scmvalue_type (type)) 36719370Spst { 36819370Spst LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type)); 36919370Spst if (scm_inferior_print (svalue, stream, format, 37019370Spst deref_ref, recurse, pretty) >= 0) 37119370Spst { 37219370Spst } 37319370Spst else 37419370Spst { 37519370Spst scm_scmval_print (svalue, stream, format, 37698944Sobrien deref_ref, recurse, pretty); 37719370Spst } 37819370Spst 37919370Spst gdb_flush (stream); 38019370Spst return (0); 38119370Spst } 38219370Spst else 38319370Spst { 38446283Sdfr return c_val_print (type, valaddr, 0, address, stream, format, 38519370Spst deref_ref, recurse, pretty); 38619370Spst } 38719370Spst} 38819370Spst 38919370Spstint 39098944Sobrienscm_value_print (struct value *val, struct ui_file *stream, int format, 39198944Sobrien enum val_prettyprint pretty) 39219370Spst{ 393242936Semaste return (common_val_print (val, stream, format, 1, 0, pretty)); 39419370Spst} 395