darling-gdb/gdb/scm-exp.c

/* Scheme/Guile language support routines for GDB, the GNU debugger.

   Copyright (C) 1995, 1996, 2000, 2003, 2005 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., 51 Franklin Street, Fifth Floor,
   Boston, MA 02110-1301, 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 (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;
}