[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 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 *evaluate_subexp_scm (struct type *, struct expression *,
				      int *, enum noside);
static struct value *scm_lookup_name (char *);
static int in_eval_c (void);

struct type *builtin_type_scm;

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

static void
scm_printstr (struct ui_file *stream, const gdb_byte *string,
	      unsigned int length, int width, int force_ellipses)
{
  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)
{
  gdb_byte buffer[20];
  read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm),
	       buffer, TYPE_LENGTH (builtin_type_scm));
  return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm));
}

/* 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))
    {
      LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
      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 (char *str)
{
  struct objfile *objf;
  struct gdbarch *gdbarch;
  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", &objf);
  gdbarch = get_objfile_arch (objf);

  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_type_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 (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_int8, (LONGEST) 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,
  &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,
  LANG_MAGIC
};

void
_initialize_scheme_language (void)
{
  add_language (&scm_language_defn);
  builtin_type_scm =
    init_type (TYPE_CODE_INT,
	       gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
	       0, "SCM", (struct objfile *) NULL);
}
Commit	Line	Data
d4310edb LC	1	/* Scheme/Guile language support routines for GDB, the GNU debugger.
d4310edb LC	2
9b254dd1 DJ	3	Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
9b254dd1 DJ	4	2008 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
	37	extern void _initialize_scheme_language (void);
	38	static struct value evaluate_subexp_scm (struct type , struct expression *,
	39	int *, enum noside);
	40	static struct value scm_lookup_name (char );
	41	static int in_eval_c (void);
	42
	43	struct type *builtin_type_scm;
	44
	45	void
	46	scm_printchar (int c, struct ui_file *stream)
	47	{
	48	fprintf_filtered (stream, "#\\%c", c);
	49	}
	50
	51	static void
	52	scm_printstr (struct ui_file stream, const gdb_byte string,
	53	unsigned int length, int width, int force_ellipses)
	54	{
	55	fprintf_filtered (stream, "\"%s\"", string);
	56	}
	57
	58	int
	59	is_scmvalue_type (struct type *type)
	60	{
	61	if (TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
	62	{
	63	return 1;
	64	}
	65	return 0;
	66	}
	67
	68	/* Get the INDEX'th SCM value, assuming SVALUE is the address
	69	of the 0'th one. */
	70
	71	LONGEST
	72	scm_get_field (LONGEST svalue, int index)
	73	{
	74	gdb_byte buffer[20];
	75	read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm),
	76	buffer, TYPE_LENGTH (builtin_type_scm));
	77	return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm));
	78	}
	79
	80	/* Unpack a value of type TYPE in buffer VALADDR as an integer
	81	(if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
	82	or Boolean (CONTEXT == TYPE_CODE_BOOL). */
	83
	84	LONGEST
	85	scm_unpack (struct type type, const gdb_byte valaddr, enum type_code context)
	86	{
	87	if (is_scmvalue_type (type))
	88	{
	89	LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
	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 *
149	scm_lookup_name (char *str)
150	{
3e3b026f UW	151	struct objfile *objf;
3e3b026f UW	152	struct gdbarch *gdbarch;
d4310edb LC	153	struct value *args[3];
	154	int len = strlen (str);
	155	struct value *func;
	156	struct value *val;
	157	struct symbol *sym;
3e3b026f UW	158
	159	func = find_function_in_inferior ("scm_lookup_cstr", &objf);
	160	gdbarch = get_objfile_arch (objf);
	161
d4310edb	162	args[0] = value_allocate_space_in_inferior (len);
3e3b026f	163	args[1] = value_from_longest (builtin_type (gdbarch)->builtin_int, len);
d4310edb LC	164	write_memory (value_as_long (args[0]), (gdb_byte *) str, len);
	165
	166	if (in_eval_c ()
	167	&& (sym = lookup_symbol ("env",
	168	expression_context_block,
2570f2b7	169	VAR_DOMAIN, (int *) NULL)) != NULL)
d4310edb LC	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
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);
	193	write_memory (iaddr, (gdb_byte *) str, len);
	194	/* FIXME - should find and pass env */
	195	write_memory (iaddr + len, (gdb_byte *) "", 1);
3e3b026f	196	func = find_function_in_inferior ("scm_evstr", NULL);
d4310edb LC	197	return call_function_by_hand (func, 1, &addr);
	198	}
	199
	200	static struct value *
	201	evaluate_exp (struct type expect_type, struct expression exp,
	202	int *pos, enum noside noside)
	203	{
	204	enum exp_opcode op = exp->elts[*pos].opcode;
	205	int len, pc;
	206	char *str;
	207	switch (op)
	208	{
	209	case OP_NAME:
	210	pc = (*pos)++;
	211	len = longest_to_int (exp->elts[pc + 1].longconst);
	212	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	213	if (noside == EVAL_SKIP)
	214	goto nosideret;
	215	str = &exp->elts[pc + 2].string;
	216	return scm_lookup_name (str);
	217	case OP_STRING:
	218	pc = (*pos)++;
	219	len = longest_to_int (exp->elts[pc + 1].longconst);
	220	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	221	if (noside == EVAL_SKIP)
	222	goto nosideret;
	223	str = &exp->elts[pc + 2].string;
	224	return scm_evaluate_string (str, len);
	225	default:;
	226	}
	227	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	228	nosideret:
cb18ec49	229	return value_from_longest (builtin_type_int8, (LONGEST) 1);
d4310edb LC	230	}
	231
	232	const struct exp_descriptor exp_descriptor_scm =
	233	{
	234	print_subexp_standard,
	235	operator_length_standard,
	236	op_name_standard,
	237	dump_subexp_body_standard,
	238	evaluate_exp
	239	};
	240
	241	const struct language_defn scm_language_defn =
	242	{
	243	"scheme", /* Language name */
	244	language_scm,
d4310edb LC	245	range_check_off,
	246	type_check_off,
	247	case_sensitive_off,
	248	array_row_major,
	249	&exp_descriptor_scm,
	250	scm_parse,
	251	c_error,
	252	null_post_parser,
	253	scm_printchar, /* Print a character constant */
	254	scm_printstr, /* Function to print string constant */
	255	NULL, /* Function to print a single character */
d4310edb	256	c_print_type, /* Print a type using appropriate syntax */
5c6ce71d	257	default_print_typedef, /* Print a typedef using appropriate syntax */
d4310edb LC	258	scm_val_print, /* Print a value using appropriate syntax */
	259	scm_value_print, /* Print a top-level value */
	260	NULL, /* Language specific skip_trampoline */
2b2d9e11	261	NULL, /* name_of_this */
d4310edb LC	262	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
	263	basic_lookup_transparent_type,/* lookup_transparent_type */
	264	NULL, /* Language specific symbol demangler */
	265	NULL, /* Language specific class_name_from_physname */
	266	NULL, /* expression operators for printing */
	267	1, /* c-style arrays */
	268	0, /* String lower bound */
d4310edb	269	default_word_break_characters,
41d27058	270	default_make_symbol_completion_list,
d4310edb LC	271	c_language_arch_info,
d4310edb LC	272	default_print_array_index,
41f1b697	273	default_pass_by_reference,
d4310edb LC	274	LANG_MAGIC
	275	};
	276
	277	void
	278	_initialize_scheme_language (void)
	279	{
	280	add_language (&scm_language_defn);
	281	builtin_type_scm =
	282	init_type (TYPE_CODE_INT,
	283	gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
	284	0, "SCM", (struct objfile *) NULL);
	285	}