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

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

   Copyright 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004 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 2 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, write to the Free Software
   Foundation, Inc., 59 Temple Place - Suite 330,
   Boston, MA 02111-1307, USA.  */

#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"

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);
static void scm_printstr (struct ui_file * stream, char *string,
			  unsigned int length, int width,
			  int force_ellipses);

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, char *string, unsigned int length,
	      int width, int force_ellipses)
{
  fprintf_filtered (stream, "\"%s\"", string);
}

int
is_scmvalue_type (struct type *type)
{
  if (TYPE_CODE (type) == TYPE_CODE_INT
      && 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)
{
  char 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 char *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 value *args[3];
  int len = strlen (str);
  struct value *func;
  struct value *val;
  struct symbol *sym;
  args[0] = value_allocate_space_in_inferior (len);
  args[1] = value_from_longest (builtin_type_int, len);
  write_memory (value_as_long (args[0]), str, len);

  if (in_eval_c ()
      && (sym = lookup_symbol ("env",
			       expression_context_block,
			       VAR_DOMAIN, (int *) NULL,
			       (struct symtab **) 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);

  func = find_function_in_inferior ("scm_lookup_cstr");
  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,
		       (struct symtab **) 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, str, len);
  /* FIXME - should find and pass env */
  write_memory (iaddr + len, "", 1);
  func = find_function_in_inferior ("scm_evstr");
  return call_function_by_hand (func, 1, &addr);
}

static struct value *
evaluate_subexp_scm (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_EXPRSTRING:
      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_long, (LONGEST) 1);
}

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

const struct language_defn scm_language_defn =
{
  "scheme",			/* Language name */
  language_scm,
  NULL,
  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 */
  NULL,				/* Create fundamental type in this language */
  c_print_type,			/* Print a type 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 */
  value_of_this,		/* value_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 */
  NULL,
  default_word_break_characters,
  c_language_arch_info,
  LANG_MAGIC
};

void
_initialize_scheme_language (void)
{
  add_language (&scm_language_defn);
  builtin_type_scm = init_type (TYPE_CODE_INT,
				TARGET_LONG_BIT / TARGET_CHAR_BIT,
				0, "SCM", (struct objfile *) NULL);
}
Commit	Line	Data
c906108c	1	/* Scheme/Guile language support routines for GDB, the GNU debugger.
1bac305b	2
b368761e	3	Copyright 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004 Free Software
1bac305b	4	Foundation, Inc.
c906108c	5
c5aa993b	6	This file is part of GDB.
c906108c	7
c5aa993b JM	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
	10	the Free Software Foundation; either version 2 of the License, or
	11	(at your option) any later version.
c906108c	12
c5aa993b JM	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.
c906108c	17
c5aa993b JM	18	You should have received a copy of the GNU General Public License
	19	along with this program; if not, write to the Free Software
	20	Foundation, Inc., 59 Temple Place - Suite 330,
	21	Boston, MA 02111-1307, USA. */
c906108c SS	22
	23	#include "defs.h"
	24	#include "symtab.h"
	25	#include "gdbtypes.h"
	26	#include "expression.h"
	27	#include "parser-defs.h"
	28	#include "language.h"
	29	#include "value.h"
	30	#include "c-lang.h"
	31	#include "scm-lang.h"
	32	#include "scm-tags.h"
0378c332	33	#include "source.h"
c906108c SS	34	#include "gdb_string.h"
c906108c SS	35	#include "gdbcore.h"
04714b91	36	#include "infcall.h"
c906108c	37
a14ed312	38	extern void _initialize_scheme_language (void);
6943961c	39	static struct value evaluate_subexp_scm (struct type , struct expression *,
a14ed312	40	int *, enum noside);
6943961c	41	static struct value scm_lookup_name (char );
a14ed312	42	static int in_eval_c (void);
d9fcf2fb JM	43	static void scm_printstr (struct ui_file * stream, char *string,
	44	unsigned int length, int width,
	45	int force_ellipses);
c906108c	46
c906108c SS	47	struct type *builtin_type_scm;
	48
	49	void
fba45db2	50	scm_printchar (int c, struct ui_file *stream)
c906108c SS	51	{
	52	fprintf_filtered (stream, "#\\%c", c);
	53	}
	54
	55	static void
fba45db2 KB	56	scm_printstr (struct ui_file stream, char string, unsigned int length,
fba45db2 KB	57	int width, int force_ellipses)
c906108c SS	58	{
	59	fprintf_filtered (stream, "\"%s\"", string);
	60	}
	61
	62	int
fba45db2	63	is_scmvalue_type (struct type *type)
c906108c SS	64	{
	65	if (TYPE_CODE (type) == TYPE_CODE_INT
	66	&& TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
	67	{
	68	return 1;
	69	}
	70	return 0;
	71	}
	72
	73	/* Get the INDEX'th SCM value, assuming SVALUE is the address
	74	of the 0'th one. */
	75
	76	LONGEST
fba45db2	77	scm_get_field (LONGEST svalue, int index)
c906108c SS	78	{
	79	char buffer[20];
	80	read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm),
	81	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
	89	LONGEST
66140c26	90	scm_unpack (struct type type, const char valaddr, enum type_code context)
c906108c SS	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	{
c5aa993b JM	104	case 2:
c5aa993b JM	105	case 6: /* fixnum */
c906108c	106	return svalue >> 2;
c5aa993b JM	107	case 4: /* other immediate value */
c5aa993b JM	108	if (SCM_ICHRP (svalue)) /* character */
c906108c SS	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
	134	static int
fba45db2	135	in_eval_c (void)
c906108c	136	{
c214a6fd	137	struct symtab_and_line cursal = get_current_source_symtab_and_line ();
0378c332 FN	138
0378c332 FN	139	if (cursal.symtab && cursal.symtab->filename)
c906108c	140	{
0378c332	141	char *filename = cursal.symtab->filename;
c906108c SS	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
6943961c	153	static struct value *
fba45db2	154	scm_lookup_name (char *str)
c906108c	155	{
f23631e4	156	struct value *args[3];
c906108c	157	int len = strlen (str);
6943961c AC	158	struct value *func;
6943961c AC	159	struct value *val;
c906108c SS	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,
176620f1	168	VAR_DOMAIN, (int *) NULL,
c906108c SS	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,
176620f1	182	VAR_DOMAIN, (int *) NULL,
c906108c SS	183	(struct symtab **) NULL);
	184	if (sym)
	185	return value_of_variable (sym, NULL);
823ca731	186	error ("No symbol \"%s\" in current context.", str);
c906108c SS	187	}
c906108c SS	188
6943961c	189	struct value *
fba45db2	190	scm_evaluate_string (char *str, int len)
c906108c	191	{
6943961c AC	192	struct value *func;
6943961c AC	193	struct value *addr = value_allocate_space_in_inferior (len + 1);
c906108c SS	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
6943961c	202	static struct value *
f86f5ca3 PH	203	evaluate_subexp_scm (struct type expect_type, struct expression exp,
f86f5ca3 PH	204	int *pos, enum noside noside)
c906108c SS	205	{
c906108c SS	206	enum exp_opcode op = exp->elts[*pos].opcode;
c5aa993b JM	207	int len, pc;
c5aa993b JM	208	char *str;
c906108c SS	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);
c5aa993b	227	default:;
c906108c SS	228	}
c906108c SS	229	return evaluate_subexp_standard (expect_type, exp, pos, noside);
c5aa993b	230	nosideret:
c906108c SS	231	return value_from_longest (builtin_type_long, (LONGEST) 1);
	232	}
	233
5f9769d1 PH	234	const 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
c5aa993b JM	243	const struct language_defn scm_language_defn =
c5aa993b JM	244	{
c906108c SS	245	"scheme", /* Language name */
c906108c SS	246	language_scm,
e9667a65	247	NULL,
c906108c SS	248	range_check_off,
c906108c SS	249	type_check_off,
63872f9d	250	case_sensitive_off,
7ca2d3a3	251	array_row_major,
5f9769d1	252	&exp_descriptor_scm,
c906108c SS	253	scm_parse,
c906108c SS	254	c_error,
e85c3284	255	null_post_parser,
c906108c SS	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 */
f636b87d	263	NULL, /* Language specific skip_trampoline */
5f9a71c3 DC	264	value_of_this, /* value_of_this */
5f9a71c3 DC	265	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
b368761e	266	basic_lookup_transparent_type,/* lookup_transparent_type */
9a3d7dfd	267	NULL, /* Language specific symbol demangler */
31c27f77	268	NULL, /* Language specific class_name_from_physname */
c906108c SS	269	NULL, /* expression operators for printing */
	270	1, /* c-style arrays */
	271	0, /* String lower bound */
e9667a65	272	NULL,
6084f43a	273	default_word_break_characters,
e9667a65	274	c_language_arch_info,
c906108c SS	275	LANG_MAGIC
	276	};
	277
	278	void
fba45db2	279	_initialize_scheme_language (void)
c906108c SS	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	}