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

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

   Copyright (C) 1995, 1996, 2000, 2003, 2005, 2008, 2009, 2010
   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"

#define USE_EXPRSTRING 0

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

static LONGEST
scm_istr2int (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 (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 (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 (void)
{
  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 (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 (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)
	{
	  struct value *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)),
					   gdbarch_byte_order (parse_gdbarch));
	  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_scm_type (parse_gdbarch)->builtin_scm);
      write_exp_elt_longcst (svalue);
      write_exp_elt_opcode (OP_LONG);
    }
}

int
scm_parse (void)
{
  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
d4310edb LC	1	/* Scheme/Guile language support routines for GDB, the GNU debugger.
d4310edb LC	2
4c38e0a4	3	Copyright (C) 1995, 1996, 2000, 2003, 2005, 2008, 2009, 2010
9b254dd1	4	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
	32	#define USE_EXPRSTRING 0
	33
	34	static void scm_lreadparen (int);
	35	static int scm_skip_ws (void);
	36	static void scm_read_token (int, int);
	37	static LONGEST scm_istring2number (char *, int, int);
	38	static LONGEST scm_istr2int (char *, int, int);
	39	static void scm_lreadr (int);
	40
	41	static LONGEST
	42	scm_istr2int (char *str, int len, int radix)
	43	{
	44	int i = 0;
	45	LONGEST inum = 0;
	46	int c;
	47	int sign = 0;
	48
	49	if (0 >= len)
	50	return SCM_BOOL_F; /* zero scm_length */
	51	switch (str[0])
	52	{ /* leading sign */
	53	case '-':
	54	case '+':
	55	sign = str[0];
	56	if (++i == len)
	57	return SCM_BOOL_F; /* bad if lone `+' or `-' */
	58	}
	59	do
	60	{
	61	switch (c = str[i++])
	62	{
	63	case '0':
	64	case '1':
	65	case '2':
	66	case '3':
	67	case '4':
	68	case '5':
	69	case '6':
	70	case '7':
	71	case '8':
	72	case '9':
	73	c = c - '0';
	74	goto accumulate;
	75	case 'A':
	76	case 'B':
	77	case 'C':
	78	case 'D':
	79	case 'E':
	80	case 'F':
	81	c = c - 'A' + 10;
	82	goto accumulate;
	83	case 'a':
84	case 'b':
85	case 'c':
86	case 'd':
87	case 'e':
88	case 'f':
89	c = c - 'a' + 10;
90	accumulate:
91	if (c >= radix)
92	return SCM_BOOL_F; /* bad digit for radix */
93	inum *= radix;
94	inum += c;
95	break;
96	default:
97	return SCM_BOOL_F; /* not a digit */
98	}
99	}
100	while (i < len);
101	if (sign == '-')
102	inum = -inum;
103	return SCM_MAKINUM (inum);
104	}
105
106	static LONGEST
107	scm_istring2number (char *str, int len, int radix)
108	{
109	int i = 0;
110	char ex = 0;
111	char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
112	#if 0
113	SCM res;
114	#endif
433759f7	115
d4310edb LC	116	if (len == 1)
	117	if (str == '+' \|\| str == '-') /* Catches lone `+' and `-' for speed */
	118	return SCM_BOOL_F;
	119
	120	while ((len - i) >= 2 && str[i] == '#' && ++i)
	121	switch (str[i++])
	122	{
	123	case 'b':
	124	case 'B':
	125	if (rx_p++)
	126	return SCM_BOOL_F;
	127	radix = 2;
	128	break;
	129	case 'o':
	130	case 'O':
	131	if (rx_p++)
	132	return SCM_BOOL_F;
	133	radix = 8;
	134	break;
	135	case 'd':
	136	case 'D':
	137	if (rx_p++)
	138	return SCM_BOOL_F;
	139	radix = 10;
	140	break;
	141	case 'x':
	142	case 'X':
	143	if (rx_p++)
	144	return SCM_BOOL_F;
	145	radix = 16;
	146	break;
	147	case 'i':
	148	case 'I':
	149	if (ex_p++)
	150	return SCM_BOOL_F;
	151	ex = 2;
	152	break;
	153	case 'e':
	154	case 'E':
	155	if (ex_p++)
	156	return SCM_BOOL_F;
	157	ex = 1;
	158	break;
	159	default:
	160	return SCM_BOOL_F;
	161	}
	162
	163	switch (ex)
	164	{
	165	case 1:
	166	return scm_istr2int (&str[i], len - i, radix);
	167	case 0:
	168	return scm_istr2int (&str[i], len - i, radix);
	169	#if 0
	170	if NFALSEP
	171	(res) return res;
	172	#ifdef FLOATS
	173	case 2:
	174	return scm_istr2flo (&str[i], len - i, radix);
	175	#endif
	176	#endif
	177	}
	178	return SCM_BOOL_F;
	179	}
180
181	static void
182	scm_read_token (int c, int weird)
183	{
184	while (1)
185	{
186	c = *lexptr++;
187	switch (c)
188	{
189	case '[':
190	case ']':
191	case '(':
192	case ')':
193	case '\"':
194	case ';':
195	case ' ':
196	case '\t':
197	case '\r':
198	case '\f':
199	case '\n':
200	if (weird)
201	goto default_case;
202	case '\0': /* End of line */
203	eof_case:
204	--lexptr;
205	return;
206	case '\\':
207	if (!weird)
208	goto default_case;
209	else
210	{
211	c = *lexptr++;
212	if (c == '\0')
213	goto eof_case;
214	else
215	goto default_case;
216	}
217	case '}':
218	if (!weird)
219	goto default_case;
220
221	c = *lexptr++;
222	if (c == '#')
223	return;
224	else
225	{
226	--lexptr;
227	c = '}';
228	goto default_case;
229	}
230
231	default:
232	default_case:
233	;
234	}
235	}
236	}
237
238	static int
239	scm_skip_ws (void)
240	{
241	int c;
433759f7	242
d4310edb LC	243	while (1)
	244	switch ((c = *lexptr++))
	245	{
	246	case '\0':
	247	goteof:
	248	return c;
	249	case ';':
	250	lp:
	251	switch ((c = *lexptr++))
	252	{
	253	case '\0':
	254	goto goteof;
	255	default:
	256	goto lp;
	257	case '\n':
	258	break;
	259	}
	260	case ' ':
	261	case '\t':
	262	case '\r':
	263	case '\f':
	264	case '\n':
	265	break;
	266	default:
	267	return c;
	268	}
	269	}
	270
	271	static void
	272	scm_lreadparen (int skipping)
	273	{
	274	for (;;)
	275	{
	276	int c = scm_skip_ws ();
433759f7	277
d4310edb LC	278	if (')' == c \|\| ']' == c)
	279	return;
	280	--lexptr;
	281	if (c == '\0')
	282	error ("missing close paren");
	283	scm_lreadr (skipping);
	284	}
	285	}
	286
	287	static void
	288	scm_lreadr (int skipping)
	289	{
	290	int c, j;
	291	struct stoken str;
	292	LONGEST svalue = 0;
433759f7	293
d4310edb LC	294	tryagain:
	295	c = *lexptr++;
	296	switch (c)
	297	{
	298	case '\0':
	299	lexptr--;
	300	return;
	301	case '[':
	302	case '(':
	303	scm_lreadparen (skipping);
	304	return;
	305	case ']':
	306	case ')':
	307	error ("unexpected #\\%c", c);
	308	goto tryagain;
	309	case '\'':
	310	case '`':
	311	str.ptr = lexptr - 1;
	312	scm_lreadr (skipping);
	313	if (!skipping)
	314	{
	315	struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
433759f7	316
d4310edb LC	317	if (!is_scmvalue_type (value_type (val)))
	318	error ("quoted scm form yields non-SCM value");
	319	svalue = extract_signed_integer (value_contents (val),
e17a4113 UW	320	TYPE_LENGTH (value_type (val)),
e17a4113 UW	321	gdbarch_byte_order (parse_gdbarch));
d4310edb LC	322	goto handle_immediate;
	323	}
	324	return;
	325	case ',':
	326	c = *lexptr++;
	327	if ('@' != c)
	328	lexptr--;
	329	scm_lreadr (skipping);
	330	return;
	331	case '#':
	332	c = *lexptr++;
	333	switch (c)
	334	{
	335	case '[':
	336	case '(':
	337	scm_lreadparen (skipping);
	338	return;
	339	case 't':
	340	case 'T':
	341	svalue = SCM_BOOL_T;
	342	goto handle_immediate;
	343	case 'f':
	344	case 'F':
	345	svalue = SCM_BOOL_F;
	346	goto handle_immediate;
	347	case 'b':
	348	case 'B':
	349	case 'o':
	350	case 'O':
	351	case 'd':
	352	case 'D':
	353	case 'x':
	354	case 'X':
	355	case 'i':
	356	case 'I':
	357	case 'e':
	358	case 'E':
	359	lexptr--;
	360	c = '#';
	361	goto num;
	362	case '': / bitvector */
	363	scm_read_token (c, 0);
	364	return;
	365	case '{':
	366	scm_read_token (c, 1);
	367	return;
	368	case '\\': /* character */
	369	c = *lexptr++;
	370	scm_read_token (c, 0);
	371	return;
	372	case '\|':
	373	j = 1; /* here j is the comment nesting depth */
	374	lp:
	375	c = *lexptr++;
	376	lpc:
	377	switch (c)
	378	{
	379	case '\0':
	380	error ("unbalanced comment");
	381	default:
	382	goto lp;
	383	case '\|':
	384	if ('#' != (c = *lexptr++))
	385	goto lpc;
386	if (--j)
387	goto lp;
388	break;
389	case '#':
390	if ('\|' != (c = *lexptr++))
391	goto lpc;
392	++j;
393	goto lp;
394	}
395	goto tryagain;
396	case '.':
397	default:
398	#if 0
399	callshrp:
400	#endif
401	scm_lreadr (skipping);
402	return;
403	}
404	case '\"':
405	while ('\"' != (c = *lexptr++))
406	{
407	if (c == '\\')
408	switch (c = *lexptr++)
409	{
410	case '\0':
411	error ("non-terminated string literal");
412	case '\n':
413	continue;
414	case '0':
415	case 'f':
416	case 'n':
417	case 'r':
418	case 't':
419	case 'a':
420	case 'v':
421	break;
422	}
423	}
424	return;
425	case '0':
426	case '1':
427	case '2':
428	case '3':
429	case '4':
430	case '5':
431	case '6':
432	case '7':
433	case '8':
434	case '9':
435	case '.':
436	case '-':
437	case '+':
438	num:
439	{
440	str.ptr = lexptr - 1;
441	scm_read_token (c, 0);
442	if (!skipping)
443	{
444	svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
445	if (svalue != SCM_BOOL_F)
446	goto handle_immediate;
447	goto tok;
448	}
449	}
450	return;
451	case ':':
452	scm_read_token ('-', 0);
453	return;
454	#if 0
455	do_symbol:
456	#endif
457	default:
458	str.ptr = lexptr - 1;
459	scm_read_token (c, 0);
460	tok:
461	if (!skipping)
462	{
463	str.length = lexptr - str.ptr;
464	if (str.ptr[0] == '$')
465	{
466	write_dollar_variable (str);
467	return;
468	}
469	write_exp_elt_opcode (OP_NAME);
470	write_exp_string (str);
471	write_exp_elt_opcode (OP_NAME);
472	}
473	return;
474	}
475	handle_immediate:
476	if (!skipping)
477	{
478	write_exp_elt_opcode (OP_LONG);
6ceaaae5	479	write_exp_elt_type (builtin_scm_type (parse_gdbarch)->builtin_scm);
d4310edb LC	480	write_exp_elt_longcst (svalue);
	481	write_exp_elt_opcode (OP_LONG);
	482	}
	483	}
	484
	485	int
	486	scm_parse (void)
	487	{
	488	char *start;
433759f7	489
d4310edb LC	490	while (*lexptr == ' ')
	491	lexptr++;
	492	start = lexptr;
	493	scm_lreadr (USE_EXPRSTRING);
	494	#if USE_EXPRSTRING
	495	str.length = lexptr - start;
	496	str.ptr = start;
	497	write_exp_elt_opcode (OP_EXPRSTRING);
	498	write_exp_string (str);
	499	write_exp_elt_opcode (OP_EXPRSTRING);
	500	#endif
	501	return 0;
	502	}