[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 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);

extern struct type **const (c_builtin_types[]);

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, register struct expression *exp,
		     register 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 language_defn scm_language_defn =
{
  "scheme",			/* Language name */
  language_scm,
  c_builtin_types,
  range_check_off,
  type_check_off,
  case_sensitive_off,
  scm_parse,
  c_error,
  evaluate_subexp_scm,
  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 */
  NULL,				/* Language specific symbol demangler */
  {"", "", "", ""},		/* Binary format info */
  {"#o%lo", "#o", "o", ""},	/* Octal format info */
  {"%ld", "", "d", ""},		/* Decimal format info */
  {"#x%lX", "#X", "X", ""},	/* Hex format info */
  NULL,				/* expression operators for printing */
  1,				/* c-style arrays */
  0,				/* String lower bound */
  &builtin_type_char,		/* Type of string elements */
  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 AC	2
	3	Copyright 1995, 1996, 1998, 2000, 2001, 2002, 2003 Free Software
	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
6c6ea35e	47	extern struct type **const (c_builtin_types[]);
c906108c SS	48
	49	struct type *builtin_type_scm;
	50
	51	void
fba45db2	52	scm_printchar (int c, struct ui_file *stream)
c906108c SS	53	{
	54	fprintf_filtered (stream, "#\\%c", c);
	55	}
	56
	57	static void
fba45db2 KB	58	scm_printstr (struct ui_file stream, char string, unsigned int length,
fba45db2 KB	59	int width, int force_ellipses)
c906108c SS	60	{
	61	fprintf_filtered (stream, "\"%s\"", string);
	62	}
	63
	64	int
fba45db2	65	is_scmvalue_type (struct type *type)
c906108c SS	66	{
	67	if (TYPE_CODE (type) == TYPE_CODE_INT
	68	&& TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
	69	{
	70	return 1;
	71	}
	72	return 0;
	73	}
	74
	75	/* Get the INDEX'th SCM value, assuming SVALUE is the address
	76	of the 0'th one. */
	77
	78	LONGEST
fba45db2	79	scm_get_field (LONGEST svalue, int index)
c906108c SS	80	{
	81	char buffer[20];
	82	read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm),
	83	buffer, TYPE_LENGTH (builtin_type_scm));
	84	return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm));
	85	}
	86
	87	/* Unpack a value of type TYPE in buffer VALADDR as an integer
	88	(if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
	89	or Boolean (CONTEXT == TYPE_CODE_BOOL). */
	90
	91	LONGEST
66140c26	92	scm_unpack (struct type type, const char valaddr, enum type_code context)
c906108c SS	93	{
	94	if (is_scmvalue_type (type))
	95	{
	96	LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
	97	if (context == TYPE_CODE_BOOL)
	98	{
	99	if (svalue == SCM_BOOL_F)
	100	return 0;
	101	else
	102	return 1;
	103	}
	104	switch (7 & (int) svalue)
	105	{
c5aa993b JM	106	case 2:
c5aa993b JM	107	case 6: /* fixnum */
c906108c	108	return svalue >> 2;
c5aa993b JM	109	case 4: /* other immediate value */
c5aa993b JM	110	if (SCM_ICHRP (svalue)) /* character */
c906108c SS	111	return SCM_ICHR (svalue);
	112	else if (SCM_IFLAGP (svalue))
	113	{
	114	switch ((int) svalue)
	115	{
	116	#ifndef SICP
	117	case SCM_EOL:
	118	#endif
	119	case SCM_BOOL_F:
	120	return 0;
	121	case SCM_BOOL_T:
	122	return 1;
	123	}
	124	}
	125	error ("Value can't be converted to integer.");
	126	default:
	127	return svalue;
	128	}
	129	}
	130	else
	131	return unpack_long (type, valaddr);
	132	}
	133
	134	/* True if we're correctly in Guile's eval.c (the evaluator and apply). */
	135
	136	static int
fba45db2	137	in_eval_c (void)
c906108c	138	{
c214a6fd	139	struct symtab_and_line cursal = get_current_source_symtab_and_line ();
0378c332 FN	140
0378c332 FN	141	if (cursal.symtab && cursal.symtab->filename)
c906108c	142	{
0378c332	143	char *filename = cursal.symtab->filename;
c906108c SS	144	int len = strlen (filename);
	145	if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
	146	return 1;
	147	}
	148	return 0;
	149	}
	150
	151	/* Lookup a value for the variable named STR.
	152	First lookup in Scheme context (using the scm_lookup_cstr inferior
	153	function), then try lookup_symbol for compiled variables. */
	154
6943961c	155	static struct value *
fba45db2	156	scm_lookup_name (char *str)
c906108c	157	{
f23631e4	158	struct value *args[3];
c906108c	159	int len = strlen (str);
6943961c AC	160	struct value *func;
6943961c AC	161	struct value *val;
c906108c SS	162	struct symbol *sym;
	163	args[0] = value_allocate_space_in_inferior (len);
	164	args[1] = value_from_longest (builtin_type_int, len);
	165	write_memory (value_as_long (args[0]), str, len);
	166
	167	if (in_eval_c ()
	168	&& (sym = lookup_symbol ("env",
	169	expression_context_block,
176620f1	170	VAR_DOMAIN, (int *) NULL,
c906108c SS	171	(struct symtab **) NULL)) != NULL)
	172	args[2] = value_of_variable (sym, expression_context_block);
	173	else
	174	/* FIXME in this case, we should try lookup_symbol first */
	175	args[2] = value_from_longest (builtin_type_scm, SCM_EOL);
	176
	177	func = find_function_in_inferior ("scm_lookup_cstr");
	178	val = call_function_by_hand (func, 3, args);
	179	if (!value_logical_not (val))
	180	return value_ind (val);
	181
	182	sym = lookup_symbol (str,
	183	expression_context_block,
176620f1	184	VAR_DOMAIN, (int *) NULL,
c906108c SS	185	(struct symtab **) NULL);
	186	if (sym)
	187	return value_of_variable (sym, NULL);
823ca731	188	error ("No symbol \"%s\" in current context.", str);
c906108c SS	189	}
c906108c SS	190
6943961c	191	struct value *
fba45db2	192	scm_evaluate_string (char *str, int len)
c906108c	193	{
6943961c AC	194	struct value *func;
6943961c AC	195	struct value *addr = value_allocate_space_in_inferior (len + 1);
c906108c SS	196	LONGEST iaddr = value_as_long (addr);
	197	write_memory (iaddr, str, len);
	198	/* FIXME - should find and pass env */
	199	write_memory (iaddr + len, "", 1);
	200	func = find_function_in_inferior ("scm_evstr");
	201	return call_function_by_hand (func, 1, &addr);
	202	}
	203
6943961c	204	static struct value *
fba45db2 KB	205	evaluate_subexp_scm (struct type expect_type, register struct expression exp,
fba45db2 KB	206	register int *pos, enum noside noside)
c906108c SS	207	{
c906108c SS	208	enum exp_opcode op = exp->elts[*pos].opcode;
c5aa993b JM	209	int len, pc;
c5aa993b JM	210	char *str;
c906108c SS	211	switch (op)
	212	{
	213	case OP_NAME:
	214	pc = (*pos)++;
	215	len = longest_to_int (exp->elts[pc + 1].longconst);
	216	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	217	if (noside == EVAL_SKIP)
	218	goto nosideret;
	219	str = &exp->elts[pc + 2].string;
	220	return scm_lookup_name (str);
	221	case OP_EXPRSTRING:
	222	pc = (*pos)++;
	223	len = longest_to_int (exp->elts[pc + 1].longconst);
	224	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	225	if (noside == EVAL_SKIP)
	226	goto nosideret;
	227	str = &exp->elts[pc + 2].string;
	228	return scm_evaluate_string (str, len);
c5aa993b	229	default:;
c906108c SS	230	}
c906108c SS	231	return evaluate_subexp_standard (expect_type, exp, pos, noside);
c5aa993b	232	nosideret:
c906108c SS	233	return value_from_longest (builtin_type_long, (LONGEST) 1);
	234	}
	235
c5aa993b JM	236	const struct language_defn scm_language_defn =
c5aa993b JM	237	{
c906108c SS	238	"scheme", /* Language name */
	239	language_scm,
	240	c_builtin_types,
	241	range_check_off,
	242	type_check_off,
63872f9d	243	case_sensitive_off,
c906108c SS	244	scm_parse,
	245	c_error,
	246	evaluate_subexp_scm,
	247	scm_printchar, /* Print a character constant */
	248	scm_printstr, /* Function to print string constant */
	249	NULL, /* Function to print a single character */
	250	NULL, /* Create fundamental type in this language */
	251	c_print_type, /* Print a type using appropriate syntax */
	252	scm_val_print, /* Print a value using appropriate syntax */
	253	scm_value_print, /* Print a top-level value */
f636b87d	254	NULL, /* Language specific skip_trampoline */
5f9a71c3 DC	255	value_of_this, /* value_of_this */
5f9a71c3 DC	256	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
9a3d7dfd	257	NULL, /* Language specific symbol demangler */
c5aa993b JM	258	{"", "", "", ""}, /* Binary format info */
	259	{"#o%lo", "#o", "o", ""}, /* Octal format info */
	260	{"%ld", "", "d", ""}, /* Decimal format info */
	261	{"#x%lX", "#X", "X", ""}, /* Hex format info */
c906108c SS	262	NULL, /* expression operators for printing */
	263	1, /* c-style arrays */
	264	0, /* String lower bound */
c5aa993b	265	&builtin_type_char, /* Type of string elements */
c906108c SS	266	LANG_MAGIC
	267	};
	268
	269	void
fba45db2	270	_initialize_scheme_language (void)
c906108c SS	271	{
	272	add_language (&scm_language_defn);
	273	builtin_type_scm = init_type (TYPE_CODE_INT,
	274	TARGET_LONG_BIT / TARGET_CHAR_BIT,
	275	0, "SCM", (struct objfile *) NULL);
	276	}