[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,
  operator_check_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];
433759f7	73
6ceaaae5	74	read_memory (SCM2PTR (svalue) + index * size, buffer, size);
e17a4113	75	return extract_signed_integer (buffer, size, byte_order);
d4310edb LC	76	}
	77
	78	/* Unpack a value of type TYPE in buffer VALADDR as an integer
	79	(if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
	80	or Boolean (CONTEXT == TYPE_CODE_BOOL). */
	81
	82	LONGEST
	83	scm_unpack (struct type type, const gdb_byte valaddr, enum type_code context)
	84	{
	85	if (is_scmvalue_type (type))
	86	{
e17a4113 UW	87	enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
	88	LONGEST svalue
	89	= extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order);
	90
d4310edb LC	91	if (context == TYPE_CODE_BOOL)
	92	{
	93	if (svalue == SCM_BOOL_F)
	94	return 0;
	95	else
	96	return 1;
	97	}
	98	switch (7 & (int) svalue)
	99	{
	100	case 2:
	101	case 6: /* fixnum */
	102	return svalue >> 2;
	103	case 4: /* other immediate value */
	104	if (SCM_ICHRP (svalue)) /* character */
	105	return SCM_ICHR (svalue);
	106	else if (SCM_IFLAGP (svalue))
	107	{
	108	switch ((int) svalue)
	109	{
	110	#ifndef SICP
	111	case SCM_EOL:
	112	#endif
	113	case SCM_BOOL_F:
	114	return 0;
	115	case SCM_BOOL_T:
	116	return 1;
	117	}
	118	}
	119	error (_("Value can't be converted to integer."));
	120	default:
	121	return svalue;
	122	}
	123	}
	124	else
	125	return unpack_long (type, valaddr);
	126	}
	127
	128	/* True if we're correctly in Guile's eval.c (the evaluator and apply). */
	129
	130	static int
	131	in_eval_c (void)
	132	{
	133	struct symtab_and_line cursal = get_current_source_symtab_and_line ();
	134
	135	if (cursal.symtab && cursal.symtab->filename)
	136	{
	137	char *filename = cursal.symtab->filename;
	138	int len = strlen (filename);
433759f7	139
d4310edb LC	140	if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
	141	return 1;
	142	}
	143	return 0;
	144	}
	145
	146	/* Lookup a value for the variable named STR.
	147	First lookup in Scheme context (using the scm_lookup_cstr inferior
	148	function), then try lookup_symbol for compiled variables. */
	149
	150	static struct value *
6ceaaae5	151	scm_lookup_name (struct gdbarch gdbarch, char str)
d4310edb LC	152	{
	153	struct value *args[3];
	154	int len = strlen (str);
	155	struct value *func;
	156	struct value *val;
	157	struct symbol *sym;
3e3b026f	158
6ceaaae5	159	func = find_function_in_inferior ("scm_lookup_cstr", NULL);
3e3b026f	160
d4310edb	161	args[0] = value_allocate_space_in_inferior (len);
3e3b026f	162	args[1] = value_from_longest (builtin_type (gdbarch)->builtin_int, len);
d4310edb LC	163	write_memory (value_as_long (args[0]), (gdb_byte *) str, len);
	164
	165	if (in_eval_c ()
	166	&& (sym = lookup_symbol ("env",
	167	expression_context_block,
2570f2b7	168	VAR_DOMAIN, (int *) NULL)) != NULL)
d4310edb LC	169	args[2] = value_of_variable (sym, expression_context_block);
	170	else
	171	/* FIXME in this case, we should try lookup_symbol first */
6ceaaae5 UW	172	args[2] = value_from_longest (builtin_scm_type (gdbarch)->builtin_scm,
6ceaaae5 UW	173	SCM_EOL);
d4310edb	174
d4310edb LC	175	val = call_function_by_hand (func, 3, args);
	176	if (!value_logical_not (val))
	177	return value_ind (val);
	178
	179	sym = lookup_symbol (str,
	180	expression_context_block,
2570f2b7	181	VAR_DOMAIN, (int *) NULL);
d4310edb LC	182	if (sym)
	183	return value_of_variable (sym, NULL);
	184	error (_("No symbol \"%s\" in current context."), str);
	185	}
	186
	187	struct value *
	188	scm_evaluate_string (char *str, int len)
	189	{
	190	struct value *func;
	191	struct value *addr = value_allocate_space_in_inferior (len + 1);
	192	LONGEST iaddr = value_as_long (addr);
433759f7	193
d4310edb LC	194	write_memory (iaddr, (gdb_byte *) str, len);
	195	/* FIXME - should find and pass env */
	196	write_memory (iaddr + len, (gdb_byte *) "", 1);
3e3b026f	197	func = find_function_in_inferior ("scm_evstr", NULL);
d4310edb LC	198	return call_function_by_hand (func, 1, &addr);
	199	}
	200
	201	static struct value *
	202	evaluate_exp (struct type expect_type, struct expression exp,
	203	int *pos, enum noside noside)
	204	{
	205	enum exp_opcode op = exp->elts[*pos].opcode;
	206	int len, pc;
	207	char *str;
433759f7	208
d4310edb LC	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;
6ceaaae5	218	return scm_lookup_name (exp->gdbarch, str);
d4310edb LC	219	case OP_STRING:
	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);
	230	nosideret:
22601c15	231	return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
d4310edb LC	232	}
	233
	234	const struct exp_descriptor exp_descriptor_scm =
	235	{
	236	print_subexp_standard,
	237	operator_length_standard,
c0201579	238	operator_check_standard,
d4310edb LC	239	op_name_standard,
	240	dump_subexp_body_standard,
	241	evaluate_exp
	242	};
	243
	244	const struct language_defn scm_language_defn =
	245	{
	246	"scheme", /* Language name */
	247	language_scm,
d4310edb LC	248	range_check_off,
	249	type_check_off,
	250	case_sensitive_off,
	251	array_row_major,
9a044a89	252	macro_expansion_no,
d4310edb LC	253	&exp_descriptor_scm,
	254	scm_parse,
	255	c_error,
	256	null_post_parser,
	257	scm_printchar, /* Print a character constant */
	258	scm_printstr, /* Function to print string constant */
	259	NULL, /* Function to print a single character */
d4310edb	260	c_print_type, /* Print a type using appropriate syntax */
5c6ce71d	261	default_print_typedef, /* Print a typedef using appropriate syntax */
d4310edb LC	262	scm_val_print, /* Print a value using appropriate syntax */
	263	scm_value_print, /* Print a top-level value */
	264	NULL, /* Language specific skip_trampoline */
2b2d9e11	265	NULL, /* name_of_this */
d4310edb LC	266	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
	267	basic_lookup_transparent_type,/* lookup_transparent_type */
	268	NULL, /* Language specific symbol demangler */
	269	NULL, /* Language specific class_name_from_physname */
	270	NULL, /* expression operators for printing */
	271	1, /* c-style arrays */
	272	0, /* String lower bound */
d4310edb	273	default_word_break_characters,
41d27058	274	default_make_symbol_completion_list,
d4310edb LC	275	c_language_arch_info,
d4310edb LC	276	default_print_array_index,
41f1b697	277	default_pass_by_reference,
ae6a3a4c	278	default_get_string,
d4310edb LC	279	LANG_MAGIC
	280	};
	281
6ceaaae5 UW	282	static void *
	283	build_scm_types (struct gdbarch *gdbarch)
	284	{
	285	struct builtin_scm_type *builtin_scm_type
	286	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_scm_type);
	287
e9bb382b UW	288	builtin_scm_type->builtin_scm
e9bb382b UW	289	= arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 0, "SCM");
6ceaaae5 UW	290
	291	return builtin_scm_type;
	292	}
	293
	294	static struct gdbarch_data *scm_type_data;
	295
	296	const struct builtin_scm_type *
	297	builtin_scm_type (struct gdbarch *gdbarch)
	298	{
	299	return gdbarch_data (gdbarch, scm_type_data);
	300	}
	301
d4310edb LC	302	void
	303	_initialize_scheme_language (void)
	304	{
6ceaaae5 UW	305	scm_type_data = gdbarch_data_register_post_init (build_scm_types);
6ceaaae5 UW	306
d4310edb	307	add_language (&scm_language_defn);
d4310edb	308	}