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

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, 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_NAMESPACE, (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_NAMESPACE, (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 */
  {"", "", "", ""},		/* 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.
f23631e4	2	Copyright 1995, 1996, 1998, 2000, 2001, 2002
6943961c	3	Free Software Foundation, Inc.
c906108c	4
c5aa993b	5	This file is part of GDB.
c906108c	6
c5aa993b JM	7	This program is free software; you can redistribute it and/or modify
	8	it under the terms of the GNU General Public License as published by
	9	the Free Software Foundation; either version 2 of the License, or
	10	(at your option) any later version.
c906108c	11
c5aa993b JM	12	This program is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
c906108c	16
c5aa993b JM	17	You should have received a copy of the GNU General Public License
	18	along with this program; if not, write to the Free Software
	19	Foundation, Inc., 59 Temple Place - Suite 330,
	20	Boston, MA 02111-1307, USA. */
c906108c SS	21
	22	#include "defs.h"
	23	#include "symtab.h"
	24	#include "gdbtypes.h"
	25	#include "expression.h"
	26	#include "parser-defs.h"
	27	#include "language.h"
	28	#include "value.h"
	29	#include "c-lang.h"
	30	#include "scm-lang.h"
	31	#include "scm-tags.h"
0378c332	32	#include "source.h"
c906108c SS	33	#include "gdb_string.h"
	34	#include "gdbcore.h"
	35
a14ed312	36	extern void _initialize_scheme_language (void);
6943961c	37	static struct value evaluate_subexp_scm (struct type , struct expression *,
a14ed312	38	int *, enum noside);
6943961c	39	static struct value scm_lookup_name (char );
a14ed312	40	static int in_eval_c (void);
d9fcf2fb JM	41	static void scm_printstr (struct ui_file * stream, char *string,
	42	unsigned int length, int width,
	43	int force_ellipses);
c906108c	44
6c6ea35e	45	extern struct type **const (c_builtin_types[]);
c906108c SS	46
	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
fba45db2	90	scm_unpack (struct type type, 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,
	168	VAR_NAMESPACE, (int *) NULL,
	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,
	182	VAR_NAMESPACE, (int *) NULL,
	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 *
fba45db2 KB	203	evaluate_subexp_scm (struct type expect_type, register struct expression exp,
fba45db2 KB	204	register 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
c5aa993b JM	234	const struct language_defn scm_language_defn =
c5aa993b JM	235	{
c906108c SS	236	"scheme", /* Language name */
	237	language_scm,
	238	c_builtin_types,
	239	range_check_off,
	240	type_check_off,
63872f9d	241	case_sensitive_off,
c906108c SS	242	scm_parse,
	243	c_error,
	244	evaluate_subexp_scm,
	245	scm_printchar, /* Print a character constant */
	246	scm_printstr, /* Function to print string constant */
	247	NULL, /* Function to print a single character */
	248	NULL, /* Create fundamental type in this language */
	249	c_print_type, /* Print a type using appropriate syntax */
	250	scm_val_print, /* Print a value using appropriate syntax */
	251	scm_value_print, /* Print a top-level value */
c5aa993b JM	252	{"", "", "", ""}, /* Binary format info */
	253	{"#o%lo", "#o", "o", ""}, /* Octal format info */
	254	{"%ld", "", "d", ""}, /* Decimal format info */
	255	{"#x%lX", "#X", "X", ""}, /* Hex format info */
c906108c SS	256	NULL, /* expression operators for printing */
	257	1, /* c-style arrays */
	258	0, /* String lower bound */
c5aa993b	259	&builtin_type_char, /* Type of string elements */
c906108c SS	260	LANG_MAGIC
	261	};
	262
	263	void
fba45db2	264	_initialize_scheme_language (void)
c906108c SS	265	{
	266	add_language (&scm_language_defn);
	267	builtin_type_scm = init_type (TYPE_CODE_INT,
	268	TARGET_LONG_BIT / TARGET_CHAR_BIT,
	269	0, "SCM", (struct objfile *) NULL);
	270	}