[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
   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)));
	  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 (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
9b254dd1 DJ	3	Copyright (C) 1995, 1996, 2000, 2003, 2005, 2008
9b254dd1 DJ	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),
315	TYPE_LENGTH (value_type (val)));
316	goto handle_immediate;
317	}
318	return;
319	case ',':
320	c = *lexptr++;
321	if ('@' != c)
322	lexptr--;
323	scm_lreadr (skipping);
324	return;
325	case '#':
326	c = *lexptr++;
327	switch (c)
328	{
329	case '[':
330	case '(':
331	scm_lreadparen (skipping);
332	return;
333	case 't':
334	case 'T':
335	svalue = SCM_BOOL_T;
336	goto handle_immediate;
337	case 'f':
338	case 'F':
339	svalue = SCM_BOOL_F;
340	goto handle_immediate;
341	case 'b':
342	case 'B':
343	case 'o':
344	case 'O':
345	case 'd':
346	case 'D':
347	case 'x':
348	case 'X':
349	case 'i':
350	case 'I':
351	case 'e':
352	case 'E':
353	lexptr--;
354	c = '#';
355	goto num;
356	case '': / bitvector */
357	scm_read_token (c, 0);
358	return;
359	case '{':
360	scm_read_token (c, 1);
361	return;
362	case '\\': /* character */
363	c = *lexptr++;
364	scm_read_token (c, 0);
365	return;
366	case '\|':
367	j = 1; /* here j is the comment nesting depth */
368	lp:
369	c = *lexptr++;
370	lpc:
371	switch (c)
372	{
373	case '\0':
374	error ("unbalanced comment");
375	default:
376	goto lp;
377	case '\|':
378	if ('#' != (c = *lexptr++))
379	goto lpc;
380	if (--j)
381	goto lp;
382	break;
383	case '#':
384	if ('\|' != (c = *lexptr++))
385	goto lpc;
386	++j;
387	goto lp;
388	}
389	goto tryagain;
390	case '.':
391	default:
392	#if 0
393	callshrp:
394	#endif
395	scm_lreadr (skipping);
396	return;
397	}
398	case '\"':
399	while ('\"' != (c = *lexptr++))
400	{
401	if (c == '\\')
402	switch (c = *lexptr++)
403	{
404	case '\0':
405	error ("non-terminated string literal");
406	case '\n':
407	continue;
408	case '0':
409	case 'f':
410	case 'n':
411	case 'r':
412	case 't':
413	case 'a':
414	case 'v':
415	break;
416	}
417	}
418	return;
419	case '0':
420	case '1':
421	case '2':
422	case '3':
423	case '4':
424	case '5':
425	case '6':
426	case '7':
427	case '8':
428	case '9':
429	case '.':
430	case '-':
431	case '+':
432	num:
433	{
434	str.ptr = lexptr - 1;
435	scm_read_token (c, 0);
436	if (!skipping)
437	{
438	svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
439	if (svalue != SCM_BOOL_F)
440	goto handle_immediate;
441	goto tok;
442	}
443	}
444	return;
445	case ':':
446	scm_read_token ('-', 0);
447	return;
448	#if 0
449	do_symbol:
450	#endif
451	default:
452	str.ptr = lexptr - 1;
453	scm_read_token (c, 0);
454	tok:
455	if (!skipping)
456	{
457	str.length = lexptr - str.ptr;
458	if (str.ptr[0] == '$')
459	{
460	write_dollar_variable (str);
461	return;
462	}
463	write_exp_elt_opcode (OP_NAME);
464	write_exp_string (str);
465	write_exp_elt_opcode (OP_NAME);
466	}
467	return;
468	}
469	handle_immediate:
470	if (!skipping)
471	{
472	write_exp_elt_opcode (OP_LONG);
473	write_exp_elt_type (builtin_type_scm);
474	write_exp_elt_longcst (svalue);
475	write_exp_elt_opcode (OP_LONG);
476	}
477	}
478
479	int
480	scm_parse (void)
481	{
482	char *start;
483	while (*lexptr == ' ')
484	lexptr++;
485	start = lexptr;
486	scm_lreadr (USE_EXPRSTRING);
487	#if USE_EXPRSTRING
488	str.length = lexptr - start;
489	str.ptr = start;
490	write_exp_elt_opcode (OP_EXPRSTRING);
491	write_exp_string (str);
492	write_exp_elt_opcode (OP_EXPRSTRING);
493	#endif
494	return 0;
495	}