1/* Scheme/Guile language support routines for GDB, the GNU debugger.
2
3   Copyright 1995, 1996, 2000, 2003 Free Software Foundation, Inc.
4
5   This file is part of GDB.
6
7   This program is free software; you can redistribute it and/or modify
8   it under the terms of the GNU General Public License as published by
9   the Free Software Foundation; either version 2 of the License, or
10   (at your option) any later version.
11
12   This program is distributed in the hope that it will be useful,
13   but WITHOUT ANY WARRANTY; without even the implied warranty of
14   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15   GNU General Public License for more details.
16
17   You should have received a copy of the GNU General Public License
18   along with this program; if not, write to the Free Software
19   Foundation, Inc., 59 Temple Place - Suite 330,
20   Boston, MA 02111-1307, USA.  */
21
22#include "defs.h"
23#include "symtab.h"
24#include "gdbtypes.h"
25#include "expression.h"
26#include "parser-defs.h"
27#include "language.h"
28#include "value.h"
29#include "c-lang.h"
30#include "scm-lang.h"
31#include "scm-tags.h"
32
33#define USE_EXPRSTRING 0
34
35static void scm_lreadparen (int);
36static int scm_skip_ws (void);
37static void scm_read_token (int, int);
38static LONGEST scm_istring2number (char *, int, int);
39static LONGEST scm_istr2int (char *, int, int);
40static void scm_lreadr (int);
41
42static LONGEST
43scm_istr2int (char *str, int len, int radix)
44{
45  int i = 0;
46  LONGEST inum = 0;
47  int c;
48  int sign = 0;
49
50  if (0 >= len)
51    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    {
62      switch (c = str[i++])
63	{
64	case '0':
65	case '1':
66	case '2':
67	case '3':
68	case '4':
69	case '5':
70	case '6':
71	case '7':
72	case '8':
73	case '9':
74	  c = c - '0';
75	  goto accumulate;
76	case 'A':
77	case 'B':
78	case 'C':
79	case 'D':
80	case 'E':
81	case 'F':
82	  c = c - 'A' + 10;
83	  goto accumulate;
84	case 'a':
85	case 'b':
86	case 'c':
87	case 'd':
88	case 'e':
89	case 'f':
90	  c = c - 'a' + 10;
91	accumulate:
92	  if (c >= radix)
93	    return SCM_BOOL_F;	/* bad digit for radix */
94	  inum *= radix;
95	  inum += c;
96	  break;
97	default:
98	  return SCM_BOOL_F;	/* not a digit */
99	}
100    }
101  while (i < len);
102  if (sign == '-')
103    inum = -inum;
104  return SCM_MAKINUM (inum);
105}
106
107static LONGEST
108scm_istring2number (char *str, int len, int radix)
109{
110  int i = 0;
111  char ex = 0;
112  char ex_p = 0, rx_p = 0;	/* Only allow 1 exactness and 1 radix prefix */
113#if 0
114  SCM res;
115#endif
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
181static void
182scm_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
238static int
239scm_skip_ws (void)
240{
241  int c;
242  while (1)
243    switch ((c = *lexptr++))
244      {
245      case '\0':
246      goteof:
247	return c;
248      case ';':
249      lp:
250	switch ((c = *lexptr++))
251	  {
252	  case '\0':
253	    goto goteof;
254	  default:
255	    goto lp;
256	  case '\n':
257	    break;
258	  }
259      case ' ':
260      case '\t':
261      case '\r':
262      case '\f':
263      case '\n':
264	break;
265      default:
266	return c;
267      }
268}
269
270static void
271scm_lreadparen (int skipping)
272{
273  for (;;)
274    {
275      int c = scm_skip_ws ();
276      if (')' == c || ']' == c)
277	return;
278      --lexptr;
279      if (c == '\0')
280	error ("missing close paren");
281      scm_lreadr (skipping);
282    }
283}
284
285static void
286scm_lreadr (int skipping)
287{
288  int c, j;
289  struct stoken str;
290  LONGEST svalue = 0;
291tryagain:
292  c = *lexptr++;
293  switch (c)
294    {
295    case '\0':
296      lexptr--;
297      return;
298    case '[':
299    case '(':
300      scm_lreadparen (skipping);
301      return;
302    case ']':
303    case ')':
304      error ("unexpected #\\%c", c);
305      goto tryagain;
306    case '\'':
307    case '`':
308      str.ptr = lexptr - 1;
309      scm_lreadr (skipping);
310      if (!skipping)
311	{
312	  struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
313	  if (!is_scmvalue_type (VALUE_TYPE (val)))
314	    error ("quoted scm form yields non-SCM value");
315	  svalue = extract_signed_integer (VALUE_CONTENTS (val),
316					   TYPE_LENGTH (VALUE_TYPE (val)));
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    }
470handle_immediate:
471  if (!skipping)
472    {
473      write_exp_elt_opcode (OP_LONG);
474      write_exp_elt_type (builtin_type_scm);
475      write_exp_elt_longcst (svalue);
476      write_exp_elt_opcode (OP_LONG);
477    }
478}
479
480int
481scm_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}
497