[binutils.git] / gdb / scm-exp.c

/* Scheme/Guile language support routines for GDB, the GNU debugger.
   Copyright 1995 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"

#define USE_EXPRSTRING 0

static void scm_lreadparen PARAMS ((int));
static int scm_skip_ws PARAMS ((void));
static void scm_read_token PARAMS ((int, int));
static LONGEST scm_istring2number PARAMS ((char *, int, int));
static LONGEST scm_istr2int PARAMS ((char *, int, int));
static void scm_lreadr PARAMS ((int));

static LONGEST
scm_istr2int(str, len, radix)
     char *str;
     int len;
     int radix;
{
  int i = 0;
  LONGEST inum = 0;
  int c;
  int sign = 0;

  if (0 >= len) return SCM_BOOL_F;	/* zero scm_length */
  switch (str[0])
    {		/* leading sign */
    case '-':
    case '+':
      sign = str[0];
      if (++i==len)
	return SCM_BOOL_F; /* bad if lone `+' or `-' */
    }
  do {
    switch (c = str[i++]) {
    case '0': case '1': case '2': case '3': case '4':
    case '5': case '6': case '7': case '8': case '9':
      c = c - '0';
      goto accumulate;
    case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
      c = c-'A'+10;
      goto accumulate;
    case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
      c = c-'a'+10;
    accumulate:
      if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
      inum *= radix;
      inum += c;
      break;
    default:
      return SCM_BOOL_F;		/* not a digit */
    }
  } while (i < len);
  if (sign == '-')
    inum = -inum;
  return SCM_MAKINUM (inum);
}

static LONGEST
scm_istring2number(str, len, radix)
     char *str;
     int len;
     int radix;
{
  int i = 0;
  char ex = 0;
  char ex_p = 0, rx_p = 0;	/* Only allow 1 exactness and 1 radix prefix */
#if 0
  SCM res;
#endif
  if (len==1)
    if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */
      return SCM_BOOL_F;

  while ((len-i) >= 2  &&  str[i]=='#' && ++i)
    switch (str[i++]) {
    case 'b': case 'B':  if (rx_p++) return SCM_BOOL_F; radix = 2;  break;
    case 'o': case 'O':  if (rx_p++) return SCM_BOOL_F; radix = 8;  break;
    case 'd': case 'D':  if (rx_p++) return SCM_BOOL_F; radix = 10; break;
    case 'x': case 'X':  if (rx_p++) return SCM_BOOL_F; radix = 16; break;
    case 'i': case 'I':  if (ex_p++) return SCM_BOOL_F; ex = 2;     break;
    case 'e': case 'E':  if (ex_p++) return SCM_BOOL_F; ex = 1;     break;
    default:  return SCM_BOOL_F;
    }

  switch (ex) {
  case 1:
    return scm_istr2int(&str[i], len-i, radix);
  case 0:
    return scm_istr2int(&str[i], len-i, radix);
#if 0
    if NFALSEP(res) return res;
#ifdef FLOATS
  case 2: return scm_istr2flo(&str[i], len-i, radix);
#endif
#endif
  }
  return SCM_BOOL_F;
}

static void
scm_read_token (c, weird)
     int c;
     int weird;
{
  while (1)
    {
      c = *lexptr++;
      switch (c)
	{
	case '[':
	case ']':
	case '(':
	case ')':
	case '\"':
	case ';':
	case ' ':  case '\t':  case '\r':  case '\f':
	case '\n':
	  if (weird)
	    goto default_case;
	case '\0':  /* End of line */
	eof_case:
	  --lexptr;
	  return;
	case '\\':
	  if (!weird)
	    goto default_case;
	  else
	    {
	      c = *lexptr++;
	      if (c == '\0')
		goto eof_case;
	      else
		goto default_case;
	    }
	case '}':
	  if (!weird)
	    goto default_case;

	  c = *lexptr++;
	  if (c == '#')
	    return;
	  else
	    {
	      --lexptr;
	      c = '}';
	      goto default_case;
	    }

	default:
	default_case:
	  ;
	}
    }
}

static int 
scm_skip_ws ()
{
  register int c;
  while (1)
    switch ((c = *lexptr++))
      {
      case '\0':
      goteof:
	return c;
      case ';':
      lp:
	switch ((c = *lexptr++))
	  {
	  case '\0':
	    goto goteof;
	  default:
	    goto lp;
	  case '\n':
	    break;
	  }
      case ' ':  case '\t':  case '\r':  case '\f':  case '\n':
	break;
      default:
	return c;
      }
}

static void
scm_lreadparen (skipping)
     int skipping;
{
  for (;;)
    {
      int c = scm_skip_ws ();
      if (')' == c || ']' == c)
	return;
      --lexptr;
      if (c == '\0')
	error ("missing close paren");
      scm_lreadr (skipping);
    }
}

static void
scm_lreadr (skipping)
     int skipping;
{
  int c, j;
  struct stoken str;
  LONGEST svalue = 0;
 tryagain:
  c = *lexptr++;
  switch (c)
    {
    case '\0':
      lexptr--;
      return;
    case '[':
    case '(':
      scm_lreadparen (skipping);
      return;
    case ']':
    case ')':
      error ("unexpected #\\%c", c);
      goto tryagain;
    case '\'':
    case '`':
      str.ptr = lexptr - 1;
      scm_lreadr (skipping);
      if (!skipping)
	{
	  value_ptr val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
	  if (!is_scmvalue_type (VALUE_TYPE (val)))
	    error ("quoted scm form yields non-SCM value");
	  svalue = extract_signed_integer (VALUE_CONTENTS (val),
					   TYPE_LENGTH (VALUE_TYPE (val)));
	  goto handle_immediate;
	}
      return;
    case ',':
      c = *lexptr++;
      if ('@' != c)
	lexptr--;
      scm_lreadr (skipping);
      return;
    case '#':
      c = *lexptr++;
      switch (c)
	{
	case '[':
	case '(':
	  scm_lreadparen (skipping);
	  return;
	case 't':  case 'T':
	  svalue = SCM_BOOL_T;
	  goto handle_immediate;
	case 'f':  case 'F':
	  svalue = SCM_BOOL_F;
	  goto handle_immediate;
	case 'b':  case 'B':
	case 'o':  case 'O':
	case 'd':  case 'D':
	case 'x':  case 'X':
	case 'i':  case 'I':
	case 'e':  case 'E':
	  lexptr--;
	  c = '#';
	  goto num;
	case '*': /* bitvector */
	  scm_read_token (c, 0);
	  return;
	case '{':
	  scm_read_token (c, 1);
	  return;
	case '\\': /* character */
	  c = *lexptr++;
	  scm_read_token (c, 0);
	  return;
	case '|':
	  j = 1;		/* here j is the comment nesting depth */
	lp:
	  c = *lexptr++;
	lpc:
	  switch (c)
	    {
	    case '\0':
	      error ("unbalanced comment");
	    default:
	      goto lp;
	    case '|':
	      if ('#' != (c = *lexptr++))
		goto lpc;
	      if (--j)
		goto lp;
	      break;
	    case '#':
	      if ('|' != (c = *lexptr++))
		goto lpc;
	      ++j;
	      goto lp;
	    }
	  goto tryagain;
	case '.':
	default:
#if 0
	callshrp:
#endif
	  scm_lreadr (skipping);
	  return;
	}
    case '\"':
      while ('\"' != (c = *lexptr++))
	{
	  if (c == '\\')
	    switch (c = *lexptr++)
	      {
	      case '\0':
		error ("non-terminated string literal");
	      case '\n':
		continue;
	      case '0':
	      case 'f':
	      case 'n':
	      case 'r':
	      case 't':
	      case 'a':
	      case 'v':
		break;
	      }
	}
      return;
    case '0': case '1': case '2': case '3': case '4':
    case '5': case '6': case '7': case '8': case '9':
    case '.':
    case '-':
    case '+':
    num:
      {
	str.ptr = lexptr-1;
	scm_read_token (c, 0);
	if (!skipping)
	  {
	    svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
	    if (svalue != SCM_BOOL_F)
	      goto handle_immediate;
	    goto tok;
	  }
      }
      return;
    case ':':
      scm_read_token ('-', 0);
      return;
#if 0
    do_symbol:
#endif
    default:
      str.ptr = lexptr-1;
      scm_read_token (c, 0);
    tok:
      if (!skipping)
	{
	  str.length = lexptr - str.ptr;
	  if (str.ptr[0] == '$')
	    {
	      write_dollar_variable (str);
	      return;
	    }
	  write_exp_elt_opcode (OP_NAME);
	  write_exp_string (str);
	  write_exp_elt_opcode (OP_NAME);
	}
      return;
    }
 handle_immediate:
  if (!skipping)
    {
      write_exp_elt_opcode (OP_LONG);
      write_exp_elt_type (builtin_type_scm);
      write_exp_elt_longcst (svalue);
      write_exp_elt_opcode (OP_LONG);
    }
}

int
scm_parse ()
{
  char* start;
  while (*lexptr == ' ')
    lexptr++;
  start = lexptr;
  scm_lreadr (USE_EXPRSTRING);
#if USE_EXPRSTRING
  str.length = lexptr - start;
  str.ptr = start;
  write_exp_elt_opcode (OP_EXPRSTRING);
  write_exp_string (str);
  write_exp_elt_opcode (OP_EXPRSTRING);
#endif
  return 0;
}
Commit	Line	Data
3c02944a PB	1	/* Scheme/Guile language support routines for GDB, the GNU debugger.
	2	Copyright 1995 Free Software Foundation, Inc.
	3
	4	This file is part of GDB.
	5
	6	This program is free software; you can redistribute it and/or modify
	7	it under the terms of the GNU General Public License as published by
	8	the Free Software Foundation; either version 2 of the License, or
	9	(at your option) any later version.
	10
	11	This program is distributed in the hope that it will be useful,
	12	but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	GNU General Public License for more details.
	15
	16	You should have received a copy of the GNU General Public License
	17	along with this program; if not, write to the Free Software
	18	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
	19
	20	#include "defs.h"
	21	#include "symtab.h"
	22	#include "gdbtypes.h"
	23	#include "expression.h"
	24	#include "parser-defs.h"
	25	#include "language.h"
	26	#include "value.h"
	27	#include "c-lang.h"
	28	#include "scm-lang.h"
	29	#include "scm-tags.h"
	30
	31	#define USE_EXPRSTRING 0
	32
b607efe7 FF	33	static void scm_lreadparen PARAMS ((int));
	34	static int scm_skip_ws PARAMS ((void));
	35	static void scm_read_token PARAMS ((int, int));
	36	static LONGEST scm_istring2number PARAMS ((char *, int, int));
	37	static LONGEST scm_istr2int PARAMS ((char *, int, int));
3c02944a PB	38	static void scm_lreadr PARAMS ((int));
3c02944a PB	39
b607efe7	40	static LONGEST
3c02944a PB	41	scm_istr2int(str, len, radix)
	42	char *str;
	43	int len;
	44	int radix;
	45	{
3c02944a PB	46	int i = 0;
	47	LONGEST inum = 0;
	48	int c;
	49	int sign = 0;
	50
	51	if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
	52	switch (str[0])
	53	{ /* leading sign */
	54	case '-':
	55	case '+':
	56	sign = str[0];
	57	if (++i==len)
	58	return SCM_BOOL_F; /* bad if lone `+' or `-' */
	59	}
	60	do {
	61	switch (c = str[i++]) {
	62	case '0': case '1': case '2': case '3': case '4':
	63	case '5': case '6': case '7': case '8': case '9':
	64	c = c - '0';
	65	goto accumulate;
	66	case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
	67	c = c-'A'+10;
	68	goto accumulate;
	69	case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
	70	c = c-'a'+10;
	71	accumulate:
	72	if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
	73	inum *= radix;
	74	inum += c;
	75	break;
	76	default:
	77	return SCM_BOOL_F; /* not a digit */
	78	}
	79	} while (i < len);
	80	if (sign == '-')
	81	inum = -inum;
	82	return SCM_MAKINUM (inum);
	83	}
	84
b607efe7	85	static LONGEST
3c02944a PB	86	scm_istring2number(str, len, radix)
	87	char *str;
	88	int len;
	89	int radix;
	90	{
	91	int i = 0;
	92	char ex = 0;
	93	char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
b607efe7	94	#if 0
3c02944a	95	SCM res;
b607efe7	96	#endif
3c02944a PB	97	if (len==1)
	98	if (str=='+' \|\| str=='-') /* Catches lone `+' and `-' for speed */
	99	return SCM_BOOL_F;
	100
	101	while ((len-i) >= 2 && str[i]=='#' && ++i)
	102	switch (str[i++]) {
	103	case 'b': case 'B': if (rx_p++) return SCM_BOOL_F; radix = 2; break;
	104	case 'o': case 'O': if (rx_p++) return SCM_BOOL_F; radix = 8; break;
	105	case 'd': case 'D': if (rx_p++) return SCM_BOOL_F; radix = 10; break;
	106	case 'x': case 'X': if (rx_p++) return SCM_BOOL_F; radix = 16; break;
	107	case 'i': case 'I': if (ex_p++) return SCM_BOOL_F; ex = 2; break;
	108	case 'e': case 'E': if (ex_p++) return SCM_BOOL_F; ex = 1; break;
	109	default: return SCM_BOOL_F;
	110	}
	111
	112	switch (ex) {
	113	case 1:
	114	return scm_istr2int(&str[i], len-i, radix);
	115	case 0:
	116	return scm_istr2int(&str[i], len-i, radix);
	117	#if 0
	118	if NFALSEP(res) return res;
	119	#ifdef FLOATS
	120	case 2: return scm_istr2flo(&str[i], len-i, radix);
	121	#endif
	122	#endif
	123	}
	124	return SCM_BOOL_F;
	125	}
	126
	127	static void
	128	scm_read_token (c, weird)
	129	int c;
	130	int weird;
	131	{
	132	while (1)
	133	{
	134	c = *lexptr++;
	135	switch (c)
	136	{
	137	case '[':
	138	case ']':
	139	case '(':
	140	case ')':
	141	case '\"':
	142	case ';':
	143	case ' ': case '\t': case '\r': case '\f':
	144	case '\n':
	145	if (weird)
	146	goto default_case;
	147	case '\0': /* End of line */
	148	eof_case:
	149	--lexptr;
	150	return;
	151	case '\\':
	152	if (!weird)
	153	goto default_case;
	154	else
	155	{
	156	c = *lexptr++;
	157	if (c == '\0')
	158	goto eof_case;
	159	else
	160	goto default_case;
161	}
162	case '}':
163	if (!weird)
164	goto default_case;
165
166	c = *lexptr++;
167	if (c == '#')
168	return;
169	else
170	{
171	--lexptr;
172	c = '}';
173	goto default_case;
174	}
175
176	default:
177	default_case:
178	;
179	}
180	}
181	}
182
183	static int
184	scm_skip_ws ()
185	{
186	register int c;
187	while (1)
188	switch ((c = *lexptr++))
189	{
190	case '\0':
191	goteof:
192	return c;
193	case ';':
194	lp:
195	switch ((c = *lexptr++))
196	{
197	case '\0':
198	goto goteof;
199	default:
200	goto lp;
201	case '\n':
202	break;
203	}
204	case ' ': case '\t': case '\r': case '\f': case '\n':
205	break;
206	default:
207	return c;
208	}
209	}
210
211	static void
212	scm_lreadparen (skipping)
213	int skipping;
214	{
215	for (;;)
216	{
217	int c = scm_skip_ws ();
218	if (')' == c \|\| ']' == c)
219	return;
220	--lexptr;
221	if (c == '\0')
222	error ("missing close paren");
223	scm_lreadr (skipping);
224	}
225	}
226
227	static void
228	scm_lreadr (skipping)
229	int skipping;
230	{
231	int c, j;
232	struct stoken str;
c1d58bcd	233	LONGEST svalue = 0;
3c02944a PB	234	tryagain:
	235	c = *lexptr++;
	236	switch (c)
	237	{
	238	case '\0':
	239	lexptr--;
	240	return;
	241	case '[':
	242	case '(':
	243	scm_lreadparen (skipping);
	244	return;
	245	case ']':
	246	case ')':
	247	error ("unexpected #\\%c", c);
	248	goto tryagain;
	249	case '\'':
	250	case '`':
	251	str.ptr = lexptr - 1;
	252	scm_lreadr (skipping);
	253	if (!skipping)
	254	{
	255	value_ptr val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
	256	if (!is_scmvalue_type (VALUE_TYPE (val)))
	257	error ("quoted scm form yields non-SCM value");
	258	svalue = extract_signed_integer (VALUE_CONTENTS (val),
	259	TYPE_LENGTH (VALUE_TYPE (val)));
	260	goto handle_immediate;
	261	}
	262	return;
	263	case ',':
	264	c = *lexptr++;
	265	if ('@' != c)
	266	lexptr--;
	267	scm_lreadr (skipping);
	268	return;
	269	case '#':
	270	c = *lexptr++;
	271	switch (c)
	272	{
	273	case '[':
	274	case '(':
	275	scm_lreadparen (skipping);
	276	return;
	277	case 't': case 'T':
	278	svalue = SCM_BOOL_T;
	279	goto handle_immediate;
	280	case 'f': case 'F':
	281	svalue = SCM_BOOL_F;
	282	goto handle_immediate;
	283	case 'b': case 'B':
	284	case 'o': case 'O':
	285	case 'd': case 'D':
	286	case 'x': case 'X':
	287	case 'i': case 'I':
	288	case 'e': case 'E':
	289	lexptr--;
	290	c = '#';
	291	goto num;
	292	case '': / bitvector */
	293	scm_read_token (c, 0);
	294	return;
	295	case '{':
	296	scm_read_token (c, 1);
	297	return;
298	case '\\': /* character */
299	c = *lexptr++;
300	scm_read_token (c, 0);
301	return;
302	case '\|':
303	j = 1; /* here j is the comment nesting depth */
304	lp:
305	c = *lexptr++;
306	lpc:
307	switch (c)
308	{
309	case '\0':
310	error ("unbalanced comment");
311	default:
312	goto lp;
313	case '\|':
314	if ('#' != (c = *lexptr++))
315	goto lpc;
316	if (--j)
317	goto lp;
318	break;
319	case '#':
320	if ('\|' != (c = *lexptr++))
321	goto lpc;
322	++j;
323	goto lp;
324	}
325	goto tryagain;
326	case '.':
327	default:
b607efe7	328	#if 0
3c02944a	329	callshrp:
b607efe7	330	#endif
3c02944a PB	331	scm_lreadr (skipping);
	332	return;
	333	}
	334	case '\"':
	335	while ('\"' != (c = *lexptr++))
	336	{
	337	if (c == '\\')
	338	switch (c = *lexptr++)
	339	{
	340	case '\0':
	341	error ("non-terminated string literal");
	342	case '\n':
	343	continue;
	344	case '0':
	345	case 'f':
	346	case 'n':
	347	case 'r':
	348	case 't':
	349	case 'a':
	350	case 'v':
	351	break;
	352	}
	353	}
	354	return;
	355	case '0': case '1': case '2': case '3': case '4':
	356	case '5': case '6': case '7': case '8': case '9':
	357	case '.':
	358	case '-':
	359	case '+':
	360	num:
	361	{
	362	str.ptr = lexptr-1;
	363	scm_read_token (c, 0);
	364	if (!skipping)
	365	{
	366	svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
	367	if (svalue != SCM_BOOL_F)
	368	goto handle_immediate;
	369	goto tok;
	370	}
	371	}
	372	return;
	373	case ':':
	374	scm_read_token ('-', 0);
	375	return;
b607efe7	376	#if 0
3c02944a	377	do_symbol:
b607efe7	378	#endif
3c02944a PB	379	default:
	380	str.ptr = lexptr-1;
	381	scm_read_token (c, 0);
	382	tok:
	383	if (!skipping)
	384	{
	385	str.length = lexptr - str.ptr;
c700638c PB	386	if (str.ptr[0] == '$')
	387	{
	388	write_dollar_variable (str);
	389	return;
	390	}
3c02944a PB	391	write_exp_elt_opcode (OP_NAME);
	392	write_exp_string (str);
	393	write_exp_elt_opcode (OP_NAME);
	394	}
	395	return;
	396	}
	397	handle_immediate:
	398	if (!skipping)
	399	{
	400	write_exp_elt_opcode (OP_LONG);
	401	write_exp_elt_type (builtin_type_scm);
	402	write_exp_elt_longcst (svalue);
	403	write_exp_elt_opcode (OP_LONG);
	404	}
	405	}
	406
	407	int
	408	scm_parse ()
	409	{
	410	char* start;
3c02944a PB	411	while (*lexptr == ' ')
	412	lexptr++;
	413	start = lexptr;
	414	scm_lreadr (USE_EXPRSTRING);
	415	#if USE_EXPRSTRING
	416	str.length = lexptr - start;
	417	str.ptr = start;
	418	write_exp_elt_opcode (OP_EXPRSTRING);
	419	write_exp_string (str);
	420	write_exp_elt_opcode (OP_EXPRSTRING);
	421	#endif
	422	return 0;
	423	}