Initial revision

1 files changed, 423 insertions, 0 deletions

diff --git a/gdb/scm-exp.c b/gdb/scm-exp.c
new file mode 100644
index 00000000000..63995639dcf
--- /dev/null
+++ b/gdb/scm-exp.c
@@ -0,0 +1,423 @@
+/* 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 PARAMS ((int));
+static int scm_skip_ws PARAMS ((void));
+static void scm_read_token PARAMS ((int, int));
+static LONGEST scm_istring2number PARAMS ((char *, int, int));
+static LONGEST scm_istr2int PARAMS ((char *, int, int));
+static void scm_lreadr PARAMS ((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;
+}