150477Speter/* Scheme/Guile language support routines for GDB, the GNU debugger. 240269Srnordier 3213136Spjd Copyright 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004 Free Software 440326Srnordier Foundation, Inc. 5172940Sjhb 6253211Swblock This file is part of GDB. 7172940Sjhb 880751Sjhb This program is free software; you can redistribute it and/or modify 980751Sjhb it under the terms of the GNU General Public License as published by 1042480Srnordier the Free Software Foundation; either version 2 of the License, or 1142480Srnordier (at your option) any later version. 1240541Srnordier 1340541Srnordier This program is distributed in the hope that it will be useful, 14104673Sgreen but WITHOUT ANY WARRANTY; without even the implied warranty of 1540269Srnordier MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16172940Sjhb GNU General Public License for more details. 1740269Srnordier 18125537Sru You should have received a copy of the GNU General Public License 19172940Sjhb along with this program; if not, write to the Free Software 20172940Sjhb Foundation, Inc., 59 Temple Place - Suite 330, 21172940Sjhb Boston, MA 02111-1307, USA. */ 22104635Sphk 23213136Spjd#include "defs.h" 24225530Savg#include "symtab.h" 25213136Spjd#include "gdbtypes.h" 26172940Sjhb#include "expression.h" 27125932Sru#include "parser-defs.h" 28125932Sru#include "language.h" 29125932Sru#include "value.h" 3097860Sphk#include "c-lang.h" 31213136Spjd#include "scm-lang.h" 32173026Sjhb#include "scm-tags.h" 33172940Sjhb#include "source.h" 34213568Spho#include "gdb_string.h" 3540269Srnordier#include "gdbcore.h" 3640269Srnordier#include "infcall.h" 37169732Skan 38169732Skanextern void _initialize_scheme_language (void); 3940269Srnordierstatic struct value *evaluate_subexp_scm (struct type *, struct expression *, 40260291Sdim int *, enum noside); 4140269Srnordierstatic struct value *scm_lookup_name (char *); 42125537Srustatic int in_eval_c (void); 43125537Srustatic void scm_printstr (struct ui_file * stream, char *string, 4440269Srnordier unsigned int length, int width, 45172940Sjhb int force_ellipses); 46125537Sru 47172940Sjhbstruct type *builtin_type_scm; 48172940Sjhb 49172940Sjhbvoid 50109886Sphkscm_printchar (int c, struct ui_file *stream) 51172940Sjhb{ 52125537Sru fprintf_filtered (stream, "#\\%c", c); 53172940Sjhb} 54172940Sjhb 5540269Srnordierstatic void 56172940Sjhbscm_printstr (struct ui_file *stream, char *string, unsigned int length, 57260291Sdim int width, int force_ellipses) 5840269Srnordier{ 59219483Sjhb fprintf_filtered (stream, "\"%s\"", string); 60219483Sjhb} 6196424Speter 62172940Sjhbint 63172940Sjhbis_scmvalue_type (struct type *type) 6480751Sjhb{ 65213136Spjd if (TYPE_CODE (type) == TYPE_CODE_INT 66260291Sdim && TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0) 6740269Srnordier { 68172940Sjhb return 1; 6980751Sjhb } 70211677Simp return 0; 71172940Sjhb} 72125556Sru 73116864Speter/* Get the INDEX'th SCM value, assuming SVALUE is the address 74116864Speter of the 0'th one. */ 75116864Speter 76116864SpeterLONGEST 77125537Sruscm_get_field (LONGEST svalue, int index) 78232930Sdim{ 79232930Sdim char buffer[20]; 80232930Sdim read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm), 81232930Sdim buffer, TYPE_LENGTH (builtin_type_scm)); 82 return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm)); 83} 84 85/* Unpack a value of type TYPE in buffer VALADDR as an integer 86 (if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR), 87 or Boolean (CONTEXT == TYPE_CODE_BOOL). */ 88 89LONGEST 90scm_unpack (struct type *type, const char *valaddr, enum type_code context) 91{ 92 if (is_scmvalue_type (type)) 93 { 94 LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type)); 95 if (context == TYPE_CODE_BOOL) 96 { 97 if (svalue == SCM_BOOL_F) 98 return 0; 99 else 100 return 1; 101 } 102 switch (7 & (int) svalue) 103 { 104 case 2: 105 case 6: /* fixnum */ 106 return svalue >> 2; 107 case 4: /* other immediate value */ 108 if (SCM_ICHRP (svalue)) /* character */ 109 return SCM_ICHR (svalue); 110 else if (SCM_IFLAGP (svalue)) 111 { 112 switch ((int) svalue) 113 { 114#ifndef SICP 115 case SCM_EOL: 116#endif 117 case SCM_BOOL_F: 118 return 0; 119 case SCM_BOOL_T: 120 return 1; 121 } 122 } 123 error ("Value can't be converted to integer."); 124 default: 125 return svalue; 126 } 127 } 128 else 129 return unpack_long (type, valaddr); 130} 131 132/* True if we're correctly in Guile's eval.c (the evaluator and apply). */ 133 134static int 135in_eval_c (void) 136{ 137 struct symtab_and_line cursal = get_current_source_symtab_and_line (); 138 139 if (cursal.symtab && cursal.symtab->filename) 140 { 141 char *filename = cursal.symtab->filename; 142 int len = strlen (filename); 143 if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0) 144 return 1; 145 } 146 return 0; 147} 148 149/* Lookup a value for the variable named STR. 150 First lookup in Scheme context (using the scm_lookup_cstr inferior 151 function), then try lookup_symbol for compiled variables. */ 152 153static struct value * 154scm_lookup_name (char *str) 155{ 156 struct value *args[3]; 157 int len = strlen (str); 158 struct value *func; 159 struct value *val; 160 struct symbol *sym; 161 args[0] = value_allocate_space_in_inferior (len); 162 args[1] = value_from_longest (builtin_type_int, len); 163 write_memory (value_as_long (args[0]), str, len); 164 165 if (in_eval_c () 166 && (sym = lookup_symbol ("env", 167 expression_context_block, 168 VAR_DOMAIN, (int *) NULL, 169 (struct symtab **) NULL)) != NULL) 170 args[2] = value_of_variable (sym, expression_context_block); 171 else 172 /* FIXME in this case, we should try lookup_symbol first */ 173 args[2] = value_from_longest (builtin_type_scm, SCM_EOL); 174 175 func = find_function_in_inferior ("scm_lookup_cstr"); 176 val = call_function_by_hand (func, 3, args); 177 if (!value_logical_not (val)) 178 return value_ind (val); 179 180 sym = lookup_symbol (str, 181 expression_context_block, 182 VAR_DOMAIN, (int *) NULL, 183 (struct symtab **) NULL); 184 if (sym) 185 return value_of_variable (sym, NULL); 186 error ("No symbol \"%s\" in current context.", str); 187} 188 189struct value * 190scm_evaluate_string (char *str, int len) 191{ 192 struct value *func; 193 struct value *addr = value_allocate_space_in_inferior (len + 1); 194 LONGEST iaddr = value_as_long (addr); 195 write_memory (iaddr, str, len); 196 /* FIXME - should find and pass env */ 197 write_memory (iaddr + len, "", 1); 198 func = find_function_in_inferior ("scm_evstr"); 199 return call_function_by_hand (func, 1, &addr); 200} 201 202static struct value * 203evaluate_subexp_scm (struct type *expect_type, struct expression *exp, 204 int *pos, enum noside noside) 205{ 206 enum exp_opcode op = exp->elts[*pos].opcode; 207 int len, pc; 208 char *str; 209 switch (op) 210 { 211 case OP_NAME: 212 pc = (*pos)++; 213 len = longest_to_int (exp->elts[pc + 1].longconst); 214 (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1); 215 if (noside == EVAL_SKIP) 216 goto nosideret; 217 str = &exp->elts[pc + 2].string; 218 return scm_lookup_name (str); 219 case OP_EXPRSTRING: 220 pc = (*pos)++; 221 len = longest_to_int (exp->elts[pc + 1].longconst); 222 (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1); 223 if (noside == EVAL_SKIP) 224 goto nosideret; 225 str = &exp->elts[pc + 2].string; 226 return scm_evaluate_string (str, len); 227 default:; 228 } 229 return evaluate_subexp_standard (expect_type, exp, pos, noside); 230nosideret: 231 return value_from_longest (builtin_type_long, (LONGEST) 1); 232} 233 234const struct exp_descriptor exp_descriptor_scm = 235{ 236 print_subexp_standard, 237 operator_length_standard, 238 op_name_standard, 239 dump_subexp_body_standard, 240 evaluate_subexp_scm 241}; 242 243const struct language_defn scm_language_defn = 244{ 245 "scheme", /* Language name */ 246 language_scm, 247 NULL, 248 range_check_off, 249 type_check_off, 250 case_sensitive_off, 251 array_row_major, 252 &exp_descriptor_scm, 253 scm_parse, 254 c_error, 255 null_post_parser, 256 scm_printchar, /* Print a character constant */ 257 scm_printstr, /* Function to print string constant */ 258 NULL, /* Function to print a single character */ 259 NULL, /* Create fundamental type in this language */ 260 c_print_type, /* Print a type using appropriate syntax */ 261 scm_val_print, /* Print a value using appropriate syntax */ 262 scm_value_print, /* Print a top-level value */ 263 NULL, /* Language specific skip_trampoline */ 264 value_of_this, /* value_of_this */ 265 basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */ 266 basic_lookup_transparent_type,/* lookup_transparent_type */ 267 NULL, /* Language specific symbol demangler */ 268 NULL, /* Language specific class_name_from_physname */ 269 NULL, /* expression operators for printing */ 270 1, /* c-style arrays */ 271 0, /* String lower bound */ 272 NULL, 273 default_word_break_characters, 274 c_language_arch_info, 275 LANG_MAGIC 276}; 277 278void 279_initialize_scheme_language (void) 280{ 281 add_language (&scm_language_defn); 282 builtin_type_scm = init_type (TYPE_CODE_INT, 283 TARGET_LONG_BIT / TARGET_CHAR_BIT, 284 0, "SCM", (struct objfile *) NULL); 285} 286