119370Spst/* Scheme/Guile language support routines for GDB, the GNU debugger. 219370Spst 3130803Smarcel Copyright 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004 Free Software 4130803Smarcel Foundation, Inc. 5130803Smarcel 698944Sobrien This file is part of GDB. 719370Spst 898944Sobrien This program is free software; you can redistribute it and/or modify 998944Sobrien it under the terms of the GNU General Public License as published by 1098944Sobrien the Free Software Foundation; either version 2 of the License, or 1198944Sobrien (at your option) any later version. 1219370Spst 1398944Sobrien This program is distributed in the hope that it will be useful, 1498944Sobrien but WITHOUT ANY WARRANTY; without even the implied warranty of 1598944Sobrien MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1698944Sobrien GNU General Public License for more details. 1719370Spst 1898944Sobrien You should have received a copy of the GNU General Public License 1998944Sobrien along with this program; if not, write to the Free Software 2098944Sobrien Foundation, Inc., 59 Temple Place - Suite 330, 2198944Sobrien Boston, MA 02111-1307, USA. */ 2219370Spst 2319370Spst#include "defs.h" 2419370Spst#include "symtab.h" 2519370Spst#include "gdbtypes.h" 2619370Spst#include "expression.h" 2719370Spst#include "parser-defs.h" 2819370Spst#include "language.h" 2919370Spst#include "value.h" 3019370Spst#include "c-lang.h" 3119370Spst#include "scm-lang.h" 3219370Spst#include "scm-tags.h" 33130803Smarcel#include "source.h" 3419370Spst#include "gdb_string.h" 3546283Sdfr#include "gdbcore.h" 36130803Smarcel#include "infcall.h" 3719370Spst 3898944Sobrienextern void _initialize_scheme_language (void); 3998944Sobrienstatic struct value *evaluate_subexp_scm (struct type *, struct expression *, 4098944Sobrien int *, enum noside); 4198944Sobrienstatic struct value *scm_lookup_name (char *); 4298944Sobrienstatic int in_eval_c (void); 4398944Sobrienstatic void scm_printstr (struct ui_file * stream, char *string, 4498944Sobrien unsigned int length, int width, 4598944Sobrien int force_ellipses); 4619370Spst 4798944Sobrienextern struct type **const (c_builtin_types[]); 4846283Sdfr 4919370Spststruct type *builtin_type_scm; 5019370Spst 5119370Spstvoid 5298944Sobrienscm_printchar (int c, struct ui_file *stream) 5319370Spst{ 5419370Spst fprintf_filtered (stream, "#\\%c", c); 5519370Spst} 5619370Spst 5719370Spststatic void 5898944Sobrienscm_printstr (struct ui_file *stream, char *string, unsigned int length, 5998944Sobrien int width, int force_ellipses) 6019370Spst{ 6119370Spst fprintf_filtered (stream, "\"%s\"", string); 6219370Spst} 6319370Spst 6419370Spstint 6598944Sobrienis_scmvalue_type (struct type *type) 6619370Spst{ 6719370Spst if (TYPE_CODE (type) == TYPE_CODE_INT 6819370Spst && TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0) 6919370Spst { 7019370Spst return 1; 7119370Spst } 7219370Spst return 0; 7319370Spst} 7419370Spst 7519370Spst/* Get the INDEX'th SCM value, assuming SVALUE is the address 7619370Spst of the 0'th one. */ 7719370Spst 7819370SpstLONGEST 7998944Sobrienscm_get_field (LONGEST svalue, int index) 8019370Spst{ 8119370Spst char buffer[20]; 8219370Spst read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm), 8319370Spst buffer, TYPE_LENGTH (builtin_type_scm)); 8419370Spst return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm)); 8519370Spst} 8619370Spst 8719370Spst/* Unpack a value of type TYPE in buffer VALADDR as an integer 8819370Spst (if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR), 8919370Spst or Boolean (CONTEXT == TYPE_CODE_BOOL). */ 9019370Spst 9119370SpstLONGEST 92130803Smarcelscm_unpack (struct type *type, const char *valaddr, enum type_code context) 9319370Spst{ 9419370Spst if (is_scmvalue_type (type)) 9519370Spst { 9619370Spst LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type)); 9719370Spst if (context == TYPE_CODE_BOOL) 9819370Spst { 9919370Spst if (svalue == SCM_BOOL_F) 10019370Spst return 0; 10119370Spst else 10219370Spst return 1; 10319370Spst } 10446283Sdfr switch (7 & (int) svalue) 10519370Spst { 10698944Sobrien case 2: 10798944Sobrien case 6: /* fixnum */ 10819370Spst return svalue >> 2; 10998944Sobrien case 4: /* other immediate value */ 11098944Sobrien if (SCM_ICHRP (svalue)) /* character */ 11119370Spst return SCM_ICHR (svalue); 11219370Spst else if (SCM_IFLAGP (svalue)) 11319370Spst { 11446283Sdfr switch ((int) svalue) 11519370Spst { 11619370Spst#ifndef SICP 11719370Spst case SCM_EOL: 11819370Spst#endif 11919370Spst case SCM_BOOL_F: 12019370Spst return 0; 12119370Spst case SCM_BOOL_T: 12219370Spst return 1; 12319370Spst } 12419370Spst } 12519370Spst error ("Value can't be converted to integer."); 12619370Spst default: 12719370Spst return svalue; 12819370Spst } 12919370Spst } 13019370Spst else 13119370Spst return unpack_long (type, valaddr); 13219370Spst} 13319370Spst 13419370Spst/* True if we're correctly in Guile's eval.c (the evaluator and apply). */ 13519370Spst 13619370Spststatic int 13798944Sobrienin_eval_c (void) 13819370Spst{ 139130803Smarcel struct symtab_and_line cursal = get_current_source_symtab_and_line (); 140130803Smarcel 141130803Smarcel if (cursal.symtab && cursal.symtab->filename) 14219370Spst { 143130803Smarcel char *filename = cursal.symtab->filename; 14419370Spst int len = strlen (filename); 14519370Spst if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0) 14619370Spst return 1; 14719370Spst } 14819370Spst return 0; 14919370Spst} 15019370Spst 15119370Spst/* Lookup a value for the variable named STR. 15219370Spst First lookup in Scheme context (using the scm_lookup_cstr inferior 15319370Spst function), then try lookup_symbol for compiled variables. */ 15419370Spst 15598944Sobrienstatic struct value * 15698944Sobrienscm_lookup_name (char *str) 15719370Spst{ 15898944Sobrien struct value *args[3]; 15919370Spst int len = strlen (str); 16098944Sobrien struct value *func; 16198944Sobrien struct value *val; 16219370Spst struct symbol *sym; 16319370Spst args[0] = value_allocate_space_in_inferior (len); 16419370Spst args[1] = value_from_longest (builtin_type_int, len); 16519370Spst write_memory (value_as_long (args[0]), str, len); 16619370Spst 16719370Spst if (in_eval_c () 16819370Spst && (sym = lookup_symbol ("env", 16919370Spst expression_context_block, 170130803Smarcel VAR_DOMAIN, (int *) NULL, 17119370Spst (struct symtab **) NULL)) != NULL) 17219370Spst args[2] = value_of_variable (sym, expression_context_block); 17319370Spst else 17419370Spst /* FIXME in this case, we should try lookup_symbol first */ 17519370Spst args[2] = value_from_longest (builtin_type_scm, SCM_EOL); 17619370Spst 17719370Spst func = find_function_in_inferior ("scm_lookup_cstr"); 17819370Spst val = call_function_by_hand (func, 3, args); 17919370Spst if (!value_logical_not (val)) 18019370Spst return value_ind (val); 18119370Spst 18219370Spst sym = lookup_symbol (str, 18319370Spst expression_context_block, 184130803Smarcel VAR_DOMAIN, (int *) NULL, 18519370Spst (struct symtab **) NULL); 18619370Spst if (sym) 18719370Spst return value_of_variable (sym, NULL); 188130803Smarcel error ("No symbol \"%s\" in current context.", str); 18919370Spst} 19019370Spst 19198944Sobrienstruct value * 19298944Sobrienscm_evaluate_string (char *str, int len) 19319370Spst{ 19498944Sobrien struct value *func; 19598944Sobrien struct value *addr = value_allocate_space_in_inferior (len + 1); 19619370Spst LONGEST iaddr = value_as_long (addr); 19719370Spst write_memory (iaddr, str, len); 19819370Spst /* FIXME - should find and pass env */ 19919370Spst write_memory (iaddr + len, "", 1); 20019370Spst func = find_function_in_inferior ("scm_evstr"); 20119370Spst return call_function_by_hand (func, 1, &addr); 20219370Spst} 20319370Spst 20498944Sobrienstatic struct value * 205130803Smarcelevaluate_subexp_scm (struct type *expect_type, struct expression *exp, 206130803Smarcel int *pos, enum noside noside) 20719370Spst{ 20819370Spst enum exp_opcode op = exp->elts[*pos].opcode; 20998944Sobrien int len, pc; 21098944Sobrien char *str; 21119370Spst switch (op) 21219370Spst { 21319370Spst case OP_NAME: 21419370Spst pc = (*pos)++; 21519370Spst len = longest_to_int (exp->elts[pc + 1].longconst); 21619370Spst (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1); 21719370Spst if (noside == EVAL_SKIP) 21819370Spst goto nosideret; 21919370Spst str = &exp->elts[pc + 2].string; 22019370Spst return scm_lookup_name (str); 22119370Spst case OP_EXPRSTRING: 22219370Spst pc = (*pos)++; 22319370Spst len = longest_to_int (exp->elts[pc + 1].longconst); 22419370Spst (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1); 22519370Spst if (noside == EVAL_SKIP) 22619370Spst goto nosideret; 22719370Spst str = &exp->elts[pc + 2].string; 22819370Spst return scm_evaluate_string (str, len); 22998944Sobrien default:; 23019370Spst } 23119370Spst return evaluate_subexp_standard (expect_type, exp, pos, noside); 23298944Sobriennosideret: 23319370Spst return value_from_longest (builtin_type_long, (LONGEST) 1); 23419370Spst} 23519370Spst 236130803Smarcelconst struct exp_descriptor exp_descriptor_scm = 237130803Smarcel{ 238130803Smarcel print_subexp_standard, 239130803Smarcel operator_length_standard, 240130803Smarcel op_name_standard, 241130803Smarcel dump_subexp_body_standard, 242130803Smarcel evaluate_subexp_scm 243130803Smarcel}; 244130803Smarcel 24598944Sobrienconst struct language_defn scm_language_defn = 24698944Sobrien{ 24719370Spst "scheme", /* Language name */ 24819370Spst language_scm, 24919370Spst c_builtin_types, 25019370Spst range_check_off, 25119370Spst type_check_off, 25298944Sobrien case_sensitive_off, 253130803Smarcel &exp_descriptor_scm, 25419370Spst scm_parse, 25519370Spst c_error, 25646283Sdfr scm_printchar, /* Print a character constant */ 25719370Spst scm_printstr, /* Function to print string constant */ 25846283Sdfr NULL, /* Function to print a single character */ 25946283Sdfr NULL, /* Create fundamental type in this language */ 26019370Spst c_print_type, /* Print a type using appropriate syntax */ 26119370Spst scm_val_print, /* Print a value using appropriate syntax */ 26219370Spst scm_value_print, /* Print a top-level value */ 263130803Smarcel NULL, /* Language specific skip_trampoline */ 264130803Smarcel value_of_this, /* value_of_this */ 265130803Smarcel basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */ 266130803Smarcel basic_lookup_transparent_type,/* lookup_transparent_type */ 267130803Smarcel NULL, /* Language specific symbol demangler */ 26898944Sobrien {"", "", "", ""}, /* Binary format info */ 26998944Sobrien {"#o%lo", "#o", "o", ""}, /* Octal format info */ 27098944Sobrien {"%ld", "", "d", ""}, /* Decimal format info */ 27198944Sobrien {"#x%lX", "#X", "X", ""}, /* Hex format info */ 27219370Spst NULL, /* expression operators for printing */ 27319370Spst 1, /* c-style arrays */ 27419370Spst 0, /* String lower bound */ 27598944Sobrien &builtin_type_char, /* Type of string elements */ 276130803Smarcel default_word_break_characters, 27719370Spst LANG_MAGIC 27819370Spst}; 27919370Spst 28019370Spstvoid 28198944Sobrien_initialize_scheme_language (void) 28219370Spst{ 28319370Spst add_language (&scm_language_defn); 28419370Spst builtin_type_scm = init_type (TYPE_CODE_INT, 28519370Spst TARGET_LONG_BIT / TARGET_CHAR_BIT, 28619370Spst 0, "SCM", (struct objfile *) NULL); 28719370Spst} 288