[deliverable/binutils-gdb.git] / gdb / scm-lang.c

/* Scheme/Guile language support routines for GDB, the GNU debugger.

   Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
   2008, 2009, 2010 Free Software Foundation, Inc.

   This file is part of GDB.

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */

#include "defs.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "parser-defs.h"
#include "language.h"
#include "value.h"
#include "c-lang.h"
#include "scm-lang.h"
#include "scm-tags.h"
#include "source.h"
#include "gdb_string.h"
#include "gdbcore.h"
#include "infcall.h"
#include "objfiles.h"

extern void _initialize_scheme_language (void);
static struct value *scm_lookup_name (struct gdbarch *, char *);
static int in_eval_c (void);

void
scm_printchar (int c, struct type *type, struct ui_file *stream)
{
  fprintf_filtered (stream, "#\\%c", c);
}

static void
scm_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
	      unsigned int length, const char *encoding, int force_ellipses,
	      const struct value_print_options *options)
{
  fprintf_filtered (stream, "\"%s\"", string);
}

int
is_scmvalue_type (struct type *type)
{
  if (TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
    {
      return 1;
    }
  return 0;
}

/* Get the INDEX'th SCM value, assuming SVALUE is the address
   of the 0'th one.  */

LONGEST
scm_get_field (LONGEST svalue, int index, int size,
	       enum bfd_endian byte_order)
{
  gdb_byte buffer[20];
  read_memory (SCM2PTR (svalue) + index * size, buffer, size);
  return extract_signed_integer (buffer, size, byte_order);
}

/* Unpack a value of type TYPE in buffer VALADDR as an integer
   (if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
   or Boolean (CONTEXT == TYPE_CODE_BOOL).  */

LONGEST
scm_unpack (struct type *type, const gdb_byte *valaddr, enum type_code context)
{
  if (is_scmvalue_type (type))
    {
      enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
      LONGEST svalue
	= extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order);

      if (context == TYPE_CODE_BOOL)
	{
	  if (svalue == SCM_BOOL_F)
	    return 0;
	  else
	    return 1;
	}
      switch (7 & (int) svalue)
	{
	case 2:
	case 6:		/* fixnum */
	  return svalue >> 2;
	case 4:		/* other immediate value */
	  if (SCM_ICHRP (svalue))	/* character */
	    return SCM_ICHR (svalue);
	  else if (SCM_IFLAGP (svalue))
	    {
	      switch ((int) svalue)
		{
#ifndef SICP
		case SCM_EOL:
#endif
		case SCM_BOOL_F:
		  return 0;
		case SCM_BOOL_T:
		  return 1;
		}
	    }
	  error (_("Value can't be converted to integer."));
	default:
	  return svalue;
	}
    }
  else
    return unpack_long (type, valaddr);
}

/* True if we're correctly in Guile's eval.c (the evaluator and apply). */

static int
in_eval_c (void)
{
  struct symtab_and_line cursal = get_current_source_symtab_and_line ();
  
  if (cursal.symtab && cursal.symtab->filename)
    {
      char *filename = cursal.symtab->filename;
      int len = strlen (filename);
      if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
	return 1;
    }
  return 0;
}

/* Lookup a value for the variable named STR.
   First lookup in Scheme context (using the scm_lookup_cstr inferior
   function), then try lookup_symbol for compiled variables. */

static struct value *
scm_lookup_name (struct gdbarch *gdbarch, char *str)
{
  struct value *args[3];
  int len = strlen (str);
  struct value *func;
  struct value *val;
  struct symbol *sym;

  func = find_function_in_inferior ("scm_lookup_cstr", NULL);

  args[0] = value_allocate_space_in_inferior (len);
  args[1] = value_from_longest (builtin_type (gdbarch)->builtin_int, len);
  write_memory (value_as_long (args[0]), (gdb_byte *) str, len);

  if (in_eval_c ()
      && (sym = lookup_symbol ("env",
			       expression_context_block,
			       VAR_DOMAIN, (int *) NULL)) != NULL)
    args[2] = value_of_variable (sym, expression_context_block);
  else
    /* FIXME in this case, we should try lookup_symbol first */
    args[2] = value_from_longest (builtin_scm_type (gdbarch)->builtin_scm,
				  SCM_EOL);

  val = call_function_by_hand (func, 3, args);
  if (!value_logical_not (val))
    return value_ind (val);

  sym = lookup_symbol (str,
		       expression_context_block,
		       VAR_DOMAIN, (int *) NULL);
  if (sym)
    return value_of_variable (sym, NULL);
  error (_("No symbol \"%s\" in current context."), str);
}

struct value *
scm_evaluate_string (char *str, int len)
{
  struct value *func;
  struct value *addr = value_allocate_space_in_inferior (len + 1);
  LONGEST iaddr = value_as_long (addr);
  write_memory (iaddr, (gdb_byte *) str, len);
  /* FIXME - should find and pass env */
  write_memory (iaddr + len, (gdb_byte *) "", 1);
  func = find_function_in_inferior ("scm_evstr", NULL);
  return call_function_by_hand (func, 1, &addr);
}

static struct value *
evaluate_exp (struct type *expect_type, struct expression *exp,
	      int *pos, enum noside noside)
{
  enum exp_opcode op = exp->elts[*pos].opcode;
  int len, pc;
  char *str;
  switch (op)
    {
    case OP_NAME:
      pc = (*pos)++;
      len = longest_to_int (exp->elts[pc + 1].longconst);
      (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
      if (noside == EVAL_SKIP)
	goto nosideret;
      str = &exp->elts[pc + 2].string;
      return scm_lookup_name (exp->gdbarch, str);
    case OP_STRING:
      pc = (*pos)++;
      len = longest_to_int (exp->elts[pc + 1].longconst);
      (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
      if (noside == EVAL_SKIP)
	goto nosideret;
      str = &exp->elts[pc + 2].string;
      return scm_evaluate_string (str, len);
    default:;
    }
  return evaluate_subexp_standard (expect_type, exp, pos, noside);
nosideret:
  return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
}

const struct exp_descriptor exp_descriptor_scm = 
{
  print_subexp_standard,
  operator_length_standard,
  op_name_standard,
  dump_subexp_body_standard,
  evaluate_exp
};

const struct language_defn scm_language_defn =
{
  "scheme",			/* Language name */
  language_scm,
  range_check_off,
  type_check_off,
  case_sensitive_off,
  array_row_major,
  macro_expansion_no,
  &exp_descriptor_scm,
  scm_parse,
  c_error,
  null_post_parser,
  scm_printchar,		/* Print a character constant */
  scm_printstr,			/* Function to print string constant */
  NULL,				/* Function to print a single character */
  c_print_type,			/* Print a type using appropriate syntax */
  default_print_typedef,	/* Print a typedef using appropriate syntax */
  scm_val_print,		/* Print a value using appropriate syntax */
  scm_value_print,		/* Print a top-level value */
  NULL,				/* Language specific skip_trampoline */
  NULL,	                        /* name_of_this */
  basic_lookup_symbol_nonlocal,	/* lookup_symbol_nonlocal */
  basic_lookup_transparent_type,/* lookup_transparent_type */
  NULL,				/* Language specific symbol demangler */
  NULL,				/* Language specific class_name_from_physname */
  NULL,				/* expression operators for printing */
  1,				/* c-style arrays */
  0,				/* String lower bound */
  default_word_break_characters,
  default_make_symbol_completion_list,
  c_language_arch_info,
  default_print_array_index,
  default_pass_by_reference,
  default_get_string,
  LANG_MAGIC
};

static void *
build_scm_types (struct gdbarch *gdbarch)
{
  struct builtin_scm_type *builtin_scm_type
    = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_scm_type);

  builtin_scm_type->builtin_scm
    = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 0, "SCM");

  return builtin_scm_type;
}

static struct gdbarch_data *scm_type_data;

const struct builtin_scm_type *
builtin_scm_type (struct gdbarch *gdbarch)
{
  return gdbarch_data (gdbarch, scm_type_data);
}

void
_initialize_scheme_language (void)
{
  scm_type_data = gdbarch_data_register_post_init (build_scm_types);

  add_language (&scm_language_defn);
}
Commit	Line	Data
d4310edb LC	1	/* Scheme/Guile language support routines for GDB, the GNU debugger.
d4310edb LC	2
9b254dd1	3	Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
4c38e0a4	4	2008, 2009, 2010 Free Software Foundation, Inc.
d4310edb LC	5
	6	This file is part of GDB.
	7
	8	This program is free software; you can redistribute it and/or modify
	9	it under the terms of the GNU General Public License as published by
a9762ec7	10	the Free Software Foundation; either version 3 of the License, or
d4310edb LC	11	(at your option) any later version.
	12
	13	This program is distributed in the hope that it will be useful,
	14	but WITHOUT ANY WARRANTY; without even the implied warranty of
	15	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	GNU General Public License for more details.
	17
	18	You should have received a copy of the GNU General Public License
a9762ec7	19	along with this program. If not, see <http://www.gnu.org/licenses/>. */
d4310edb LC	20
	21	#include "defs.h"
	22	#include "symtab.h"
	23	#include "gdbtypes.h"
	24	#include "expression.h"
	25	#include "parser-defs.h"
	26	#include "language.h"
	27	#include "value.h"
	28	#include "c-lang.h"
	29	#include "scm-lang.h"
	30	#include "scm-tags.h"
	31	#include "source.h"
	32	#include "gdb_string.h"
	33	#include "gdbcore.h"
	34	#include "infcall.h"
3e3b026f	35	#include "objfiles.h"
d4310edb LC	36
d4310edb LC	37	extern void _initialize_scheme_language (void);
6ceaaae5	38	static struct value scm_lookup_name (struct gdbarch , char *);
d4310edb LC	39	static int in_eval_c (void);
d4310edb LC	40
d4310edb	41	void
6c7a06a3	42	scm_printchar (int c, struct type type, struct ui_file stream)
d4310edb LC	43	{
	44	fprintf_filtered (stream, "#\\%c", c);
	45	}
	46
	47	static void
6c7a06a3	48	scm_printstr (struct ui_file stream, struct type type, const gdb_byte *string,
be759fcf	49	unsigned int length, const char *encoding, int force_ellipses,
79a45b7d	50	const struct value_print_options *options)
d4310edb LC	51	{
	52	fprintf_filtered (stream, "\"%s\"", string);
	53	}
	54
	55	int
	56	is_scmvalue_type (struct type *type)
	57	{
	58	if (TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
	59	{
	60	return 1;
	61	}
	62	return 0;
	63	}
	64
	65	/* Get the INDEX'th SCM value, assuming SVALUE is the address
	66	of the 0'th one. */
	67
	68	LONGEST
e17a4113 UW	69	scm_get_field (LONGEST svalue, int index, int size,
e17a4113 UW	70	enum bfd_endian byte_order)
d4310edb LC	71	{
d4310edb LC	72	gdb_byte buffer[20];
6ceaaae5	73	read_memory (SCM2PTR (svalue) + index * size, buffer, size);
e17a4113	74	return extract_signed_integer (buffer, size, byte_order);
d4310edb LC	75	}
	76
	77	/* Unpack a value of type TYPE in buffer VALADDR as an integer
	78	(if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
	79	or Boolean (CONTEXT == TYPE_CODE_BOOL). */
	80
	81	LONGEST
	82	scm_unpack (struct type type, const gdb_byte valaddr, enum type_code context)
	83	{
	84	if (is_scmvalue_type (type))
	85	{
e17a4113 UW	86	enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
	87	LONGEST svalue
	88	= extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order);
	89
d4310edb LC	90	if (context == TYPE_CODE_BOOL)
	91	{
	92	if (svalue == SCM_BOOL_F)
	93	return 0;
	94	else
	95	return 1;
	96	}
	97	switch (7 & (int) svalue)
	98	{
	99	case 2:
	100	case 6: /* fixnum */
	101	return svalue >> 2;
	102	case 4: /* other immediate value */
	103	if (SCM_ICHRP (svalue)) /* character */
	104	return SCM_ICHR (svalue);
	105	else if (SCM_IFLAGP (svalue))
	106	{
	107	switch ((int) svalue)
	108	{
	109	#ifndef SICP
	110	case SCM_EOL:
	111	#endif
	112	case SCM_BOOL_F:
	113	return 0;
	114	case SCM_BOOL_T:
	115	return 1;
	116	}
	117	}
	118	error (_("Value can't be converted to integer."));
	119	default:
	120	return svalue;
	121	}
	122	}
	123	else
	124	return unpack_long (type, valaddr);
	125	}
	126
	127	/* True if we're correctly in Guile's eval.c (the evaluator and apply). */
	128
	129	static int
	130	in_eval_c (void)
	131	{
	132	struct symtab_and_line cursal = get_current_source_symtab_and_line ();
	133
	134	if (cursal.symtab && cursal.symtab->filename)
	135	{
	136	char *filename = cursal.symtab->filename;
	137	int len = strlen (filename);
	138	if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
	139	return 1;
	140	}
	141	return 0;
	142	}
	143
	144	/* Lookup a value for the variable named STR.
	145	First lookup in Scheme context (using the scm_lookup_cstr inferior
	146	function), then try lookup_symbol for compiled variables. */
	147
	148	static struct value *
6ceaaae5	149	scm_lookup_name (struct gdbarch gdbarch, char str)
d4310edb LC	150	{
	151	struct value *args[3];
	152	int len = strlen (str);
	153	struct value *func;
	154	struct value *val;
	155	struct symbol *sym;
3e3b026f	156
6ceaaae5	157	func = find_function_in_inferior ("scm_lookup_cstr", NULL);
3e3b026f	158
d4310edb	159	args[0] = value_allocate_space_in_inferior (len);
3e3b026f	160	args[1] = value_from_longest (builtin_type (gdbarch)->builtin_int, len);
d4310edb LC	161	write_memory (value_as_long (args[0]), (gdb_byte *) str, len);
	162
	163	if (in_eval_c ()
	164	&& (sym = lookup_symbol ("env",
	165	expression_context_block,
2570f2b7	166	VAR_DOMAIN, (int *) NULL)) != NULL)
d4310edb LC	167	args[2] = value_of_variable (sym, expression_context_block);
	168	else
	169	/* FIXME in this case, we should try lookup_symbol first */
6ceaaae5 UW	170	args[2] = value_from_longest (builtin_scm_type (gdbarch)->builtin_scm,
6ceaaae5 UW	171	SCM_EOL);
d4310edb	172
d4310edb LC	173	val = call_function_by_hand (func, 3, args);
	174	if (!value_logical_not (val))
	175	return value_ind (val);
	176
	177	sym = lookup_symbol (str,
	178	expression_context_block,
2570f2b7	179	VAR_DOMAIN, (int *) NULL);
d4310edb LC	180	if (sym)
	181	return value_of_variable (sym, NULL);
	182	error (_("No symbol \"%s\" in current context."), str);
	183	}
	184
	185	struct value *
	186	scm_evaluate_string (char *str, int len)
	187	{
	188	struct value *func;
	189	struct value *addr = value_allocate_space_in_inferior (len + 1);
	190	LONGEST iaddr = value_as_long (addr);
	191	write_memory (iaddr, (gdb_byte *) str, len);
	192	/* FIXME - should find and pass env */
	193	write_memory (iaddr + len, (gdb_byte *) "", 1);
3e3b026f	194	func = find_function_in_inferior ("scm_evstr", NULL);
d4310edb LC	195	return call_function_by_hand (func, 1, &addr);
	196	}
	197
	198	static struct value *
	199	evaluate_exp (struct type expect_type, struct expression exp,
	200	int *pos, enum noside noside)
	201	{
	202	enum exp_opcode op = exp->elts[*pos].opcode;
	203	int len, pc;
	204	char *str;
	205	switch (op)
	206	{
	207	case OP_NAME:
	208	pc = (*pos)++;
	209	len = longest_to_int (exp->elts[pc + 1].longconst);
	210	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	211	if (noside == EVAL_SKIP)
	212	goto nosideret;
	213	str = &exp->elts[pc + 2].string;
6ceaaae5	214	return scm_lookup_name (exp->gdbarch, str);
d4310edb LC	215	case OP_STRING:
	216	pc = (*pos)++;
	217	len = longest_to_int (exp->elts[pc + 1].longconst);
	218	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	219	if (noside == EVAL_SKIP)
	220	goto nosideret;
	221	str = &exp->elts[pc + 2].string;
	222	return scm_evaluate_string (str, len);
	223	default:;
	224	}
	225	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	226	nosideret:
22601c15	227	return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
d4310edb LC	228	}
	229
	230	const struct exp_descriptor exp_descriptor_scm =
	231	{
	232	print_subexp_standard,
	233	operator_length_standard,
	234	op_name_standard,
	235	dump_subexp_body_standard,
	236	evaluate_exp
	237	};
	238
	239	const struct language_defn scm_language_defn =
	240	{
	241	"scheme", /* Language name */
	242	language_scm,
d4310edb LC	243	range_check_off,
	244	type_check_off,
	245	case_sensitive_off,
	246	array_row_major,
9a044a89	247	macro_expansion_no,
d4310edb LC	248	&exp_descriptor_scm,
	249	scm_parse,
	250	c_error,
	251	null_post_parser,
	252	scm_printchar, /* Print a character constant */
	253	scm_printstr, /* Function to print string constant */
	254	NULL, /* Function to print a single character */
d4310edb	255	c_print_type, /* Print a type using appropriate syntax */
5c6ce71d	256	default_print_typedef, /* Print a typedef using appropriate syntax */
d4310edb LC	257	scm_val_print, /* Print a value using appropriate syntax */
	258	scm_value_print, /* Print a top-level value */
	259	NULL, /* Language specific skip_trampoline */
2b2d9e11	260	NULL, /* name_of_this */
d4310edb LC	261	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
	262	basic_lookup_transparent_type,/* lookup_transparent_type */
	263	NULL, /* Language specific symbol demangler */
	264	NULL, /* Language specific class_name_from_physname */
	265	NULL, /* expression operators for printing */
	266	1, /* c-style arrays */
	267	0, /* String lower bound */
d4310edb	268	default_word_break_characters,
41d27058	269	default_make_symbol_completion_list,
d4310edb LC	270	c_language_arch_info,
d4310edb LC	271	default_print_array_index,
41f1b697	272	default_pass_by_reference,
ae6a3a4c	273	default_get_string,
d4310edb LC	274	LANG_MAGIC
	275	};
	276
6ceaaae5 UW	277	static void *
	278	build_scm_types (struct gdbarch *gdbarch)
	279	{
	280	struct builtin_scm_type *builtin_scm_type
	281	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_scm_type);
	282
e9bb382b UW	283	builtin_scm_type->builtin_scm
e9bb382b UW	284	= arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 0, "SCM");
6ceaaae5 UW	285
	286	return builtin_scm_type;
	287	}
	288
	289	static struct gdbarch_data *scm_type_data;
	290
	291	const struct builtin_scm_type *
	292	builtin_scm_type (struct gdbarch *gdbarch)
	293	{
	294	return gdbarch_data (gdbarch, scm_type_data);
	295	}
	296
d4310edb LC	297	void
	298	_initialize_scheme_language (void)
	299	{
6ceaaae5 UW	300	scm_type_data = gdbarch_data_register_post_init (build_scm_types);
6ceaaae5 UW	301
d4310edb	302	add_language (&scm_language_defn);
d4310edb	303	}