binutils-gdb/gdb/scm-exp.c

506 lines
8.7 KiB
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_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 (str, len, radix)
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 (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 */
#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 (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 = 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)
{
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:
#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 ()
{
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;
}