[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_lreadr PARAMS ((int));

LONGEST
scm_istr2int(str, len, radix)
     char *str;
     int len;
     int radix;
{
  int j;
  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);
}

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