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