* defs.h (enum language): Add language_scm.

	* expression.h (enum exp_code):  Added OP_EXPRSTRING.
	* scm-lang.c:  Preliminary support for Guile /SCM dialect of Scheme.
	* expprint.c (print_subexp):  Add OP_EXPRSTRING support.
	* parse.c (length_of_subexp, prefixify_subexp):  Likewise.
	* valops.c (find_function_in_inferior):  New function.
	(value_allocate_space_in_inferior):  New function.
	(allocate_space_in_inferior):  Redefine using previous function.
	* Makefile.in (SFILES):  Add scm-lang.c.
	(COMMON_OBS):  Add scm-lang.o

6 files changed, 534 insertions, 3 deletions

diff --git a/gdb/.Sanitize b/gdb/.Sanitize
index d633a06..972b9a4 100644
--- a/gdb/.Sanitize
+++ b/gdb/.Sanitize
@@ -286,6 +286,7 @@ rs6000-nat.c
 rs6000-tdep.c
 rom68k-rom.c
 saber.suppress
+scm-lang.c
 ser-e7kpc.c
 ser-go32.c
 ser-mac.c
diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index bbc916b..b9ccf72 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,16 @@
+Thu Sep 28 17:43:39 1995  Per Bothner  <bothner@kalessin.cygnus.com>
+
+	* defs.h (enum language):  Add language_scm.
+	* expression.h (enum exp_code):  Added OP_EXPRSTRING.
+	* scm-lang.c:  Preliminary support for Guile /SCM dialect of Scheme.
+	* expprint.c (print_subexp):  Add OP_EXPRSTRING support.
+	* parse.c (length_of_subexp, prefixify_subexp):  Likewise.
+	* valops.c (find_function_in_inferior):  New function.
+	(value_allocate_space_in_inferior):  New function.
+	(allocate_space_in_inferior):  Redefine using previous function.
+	* Makefile.in (SFILES):  Add scm-lang.c.
+	(COMMON_OBS):  Add scm-lang.o
+
 Thu Sep 28 14:32:11 1995  steve chamberlain  <sac@slash.cygnus.com>
 
 	* callback.[ch]: New files.
diff --git a/gdb/Makefile.in b/gdb/Makefile.in
index c2d2d40..2938c63 100644
--- a/gdb/Makefile.in
+++ b/gdb/Makefile.in
@@ -355,7 +355,8 @@ SFILES = blockframe.c breakpoint.c buildsym.c callback.c c-exp.y c-lang.c \
 	gdbtypes.c infcmd.c inflow.c infrun.c language.c \
 	m2-exp.y m2-lang.c m2-typeprint.c m2-valprint.c main.c maint.c \
 	mem-break.c minsyms.c mipsread.c nlmread.c objfiles.c parse.c \
-	printcmd.c remote.c remote-nrom.c source.c stabsread.c stack.c symfile.c symmisc.c \
+	printcmd.c remote.c remote-nrom.c scm-lang.c \
+	source.c stabsread.c stack.c symfile.c symmisc.c \
 	symtab.c target.c thread.c top.c \
 	typeprint.c utils.c valarith.c valops.c \
 	valprint.c values.c serial.c ser-unix.c mdebugread.c os9kread.c
@@ -465,7 +466,7 @@ COMMON_OBS = version.o blockframe.o breakpoint.o findvar.o stack.o thread.o \
 	exec.o objfiles.o minsyms.o maint.o demangle.o \
 	dbxread.o coffread.o elfread.o \
 	dwarfread.o mipsread.o stabsread.o core.o \
-	c-lang.o ch-lang.o f-lang.o m2-lang.o \
+	c-lang.o ch-lang.o f-lang.o m2-lang.o scm-lang.o \
 	complaints.o typeprint.o \
 	c-typeprint.o ch-typeprint.o f-typeprint.o m2-typeprint.o \
 	c-valprint.o cp-valprint.o ch-valprint.o f-valprint.o m2-valprint.o \
diff --git a/gdb/defs.h b/gdb/defs.h
index cd13c2e..af94db8 100644
--- a/gdb/defs.h
+++ b/gdb/defs.h
@@ -115,7 +115,8 @@ enum language
    language_chill,		/* Chill */
    language_fortran,		/* Fortran */
    language_m2,			/* Modula-2 */
-   language_asm			/* Assembly language */
+   language_asm,		/* Assembly language */
+   language_scm			/* Scheme / Guile */
 };
 
 /* the cleanup list records things that have to be undone
diff --git a/gdb/parse.c b/gdb/parse.c
index ad38e8b..a545814 100644
--- a/gdb/parse.c
+++ b/gdb/parse.c
@@ -512,6 +512,7 @@ length_of_subexp (expr, endpos)
       /* fall through */
     case OP_M2_STRING:
     case OP_STRING:
+    case OP_EXPRSTRING:
       oplen = longest_to_int (expr->elts[endpos - 2].longconst);
       oplen = 4 + BYTES_TO_EXP_ELEM (oplen + 1);
       break;
@@ -649,6 +650,7 @@ prefixify_subexp (inexpr, outexpr, inend, outbeg)
       /* fall through */
     case OP_M2_STRING:
     case OP_STRING:
+    case OP_EXPRSTRING:
       oplen = longest_to_int (inexpr->elts[inend - 2].longconst);
       oplen = 4 + BYTES_TO_EXP_ELEM (oplen + 1);
       break;
diff --git a/gdb/scm-lang.c b/gdb/scm-lang.c
new file mode 100644
index 0000000..f3d2df4
--- /dev/null
+++ b/gdb/scm-lang.c
@@ -0,0 +1,513 @@
+/* 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 "c-lang.h"
+#include "value.h"
+
+extern struct type ** const (c_builtin_types[]);
+extern value_ptr value_allocate_space_in_inferior PARAMS ((int));
+extern value_ptr find_function_in_inferior PARAMS ((char*));
+
+static void scm_lreadr ();
+
+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 ()
+{
+  for (;;)
+    {
+      int c = scm_skip_ws ();
+      if (')' == c || ']' == c)
+	return;
+      --lexptr;
+      if (c == '\0')
+	error ("missing close paren");
+      scm_lreadr ();
+    }
+}
+
+static void
+scm_lreadr ()
+{
+  int c, j;
+ tryagain:
+  c = *lexptr++;
+  switch (c)
+    {
+    case '\0':
+      lexptr--;
+      return;
+    case '[':
+    case '(':
+      scm_lreadparen ();
+      return;
+    case ']':
+    case ')':
+      error ("unexpected #\\%c", c);
+      goto tryagain;
+    case '\'':
+    case '`':
+      scm_lreadr ();
+      return;
+    case ',':
+      c = *lexptr++;
+      if ('@' != c)
+	lexptr--;
+      scm_lreadr ();
+      return;
+    case '#':
+      c = *lexptr++;
+      switch (c)
+	{
+	case '[':
+	case '(':
+	  scm_lreadparen ();
+	  return;
+	case 't':  case 'T':
+	case 'f':  case 'F':
+	  return;
+	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 ();
+	  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:
+      scm_read_token (c, 0);
+      return;
+    case ':':
+      scm_read_token ('-', 0);
+      return;
+    default:
+      scm_read_token (c, 0);
+    tok:
+      return;
+    }
+}
+
+int
+scm_parse ()
+{
+  char* start;
+  struct stoken str;
+  while (*lexptr == ' ')
+    lexptr++;
+  start = lexptr;
+  scm_lreadr ();
+  str.length = lexptr - start;
+  str.ptr = start;
+  write_exp_elt_opcode (OP_EXPRSTRING);
+  write_exp_string (str);
+  write_exp_elt_opcode (OP_EXPRSTRING);
+  return 0;
+}
+
+static void
+scm_printchar (c, stream)
+     int c;
+     GDB_FILE *stream;
+{
+  fprintf_filtered (stream, "#\\%c", c);
+}
+
+static void
+scm_printstr (stream, string, length, force_ellipses)
+     GDB_FILE *stream;
+     char *string;
+     unsigned int length;
+     int force_ellipses;
+{
+  fprintf_filtered (stream, "\"%s\"", string);
+}
+
+int
+is_object_type (type)
+     struct type *type;
+{
+  /* FIXME - this should test for the SCM type, but we can't do that ! */
+  return TYPE_CODE (type) == TYPE_CODE_INT
+    && TYPE_NAME (type)
+#if 1
+    && strcmp (TYPE_NAME (type), "SCM") == 0;
+#else
+    && TYPE_LENGTH (type) == TYPE_LENGTH (builtin_type_long)
+    && strcmp (TYPE_NAME (type), "long int") == 0;
+#endif
+}
+
+/* Prints the SCM value VALUE by invoking the inferior, if appropraite.
+   Returns >= 0 on succes;  retunr -1 if the inferior cannot/should not
+   print VALUE. */
+
+int
+scm_inferior_print (value, stream, format, deref_ref, recurse, pretty)
+     LONGEST value;
+     GDB_FILE *stream;
+     int format;
+     int deref_ref;
+     int recurse;
+     enum val_prettyprint pretty;
+{
+  return -1;
+}
+
+#define SCM_ITAG8_DATA(X)	((X)>>8)
+#define SCM_ICHR(x)	((unsigned char)SCM_ITAG8_DATA(x))
+#define SCM_ICHRP(x)    (SCM_ITAG8(x) == scm_tc8_char)
+#define scm_tc8_char 0xf4
+#define SCM_IFLAGP(n)            ((0x87 & (int)(n))==4)
+#define SCM_ISYMNUM(n)           ((int)((n)>>9))
+#define SCM_ISYMCHARS(n)         (scm_isymnames[SCM_ISYMNUM(n)])
+#define SCM_ILOCP(n)             ((0xff & (int)(n))==0xfc)
+#define SCM_ITAG8(X)             ((int)(X) & 0xff)
+
+/* {Names of immediate symbols}
+ * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/
+
+static char *scm_isymnames[] =
+{
+  /* This table must agree with the declarations */
+  "#@and",
+  "#@begin",
+  "#@case",
+  "#@cond",
+  "#@do",
+  "#@if",
+  "#@lambda",
+  "#@let",
+  "#@let*",
+  "#@letrec",
+  "#@or",
+  "#@quote",
+  "#@set!",
+  "#@define",
+#if 0
+  "#@literal-variable-ref",
+  "#@literal-variable-set!",
+#endif
+  "#@apply",
+  "#@call-with-current-continuation",
+
+ /* user visible ISYMS */
+ /* other keywords */
+ /* Flags */
+
+  "#f",
+  "#t",
+  "#<undefined>",
+  "#<eof>",
+  "()",
+  "#<unspecified>"
+};
+
+int
+scm_val_print (type, valaddr, address, stream, format, deref_ref, recurse,
+	     pretty)
+     struct type *type;
+     char *valaddr;
+     CORE_ADDR address;
+     GDB_FILE *stream;
+     int format;
+     int deref_ref;
+     int recurse;
+     enum val_prettyprint pretty;
+{
+  if (is_object_type (type))
+    {
+      LONGEST svalue = unpack_long (type, valaddr);
+      if (scm_inferior_print (svalue, stream, format,
+			      deref_ref, recurse, pretty) >= 0)
+	{
+	}
+      else
+	{
+	  switch (7 & svalue)
+	    {
+	    case 2:
+	    case 6:
+	      print_longest (stream, format ? format : 'd', 1, svalue >> 2);
+	      break;
+	    case 4:
+	      if (SCM_ICHRP (svalue))
+		{
+		  svalue = SCM_ICHR (svalue);
+		  scm_printchar (svalue, stream);
+		  break;
+		}
+	      else if (SCM_IFLAGP (svalue)
+	       && (SCM_ISYMNUM (svalue)
+		   < (sizeof scm_isymnames / sizeof (char *))))
+		{
+		  fputs_filtered (SCM_ISYMCHARS (svalue), stream);
+		  break;
+		}
+	      else if (SCM_ILOCP (svalue))
+		{
+#if 0
+		  fputs_filtered ("#@", stream);
+		  scm_intprint ((long) IFRAME (exp), 10, port);
+		  scm_putc (ICDRP (exp) ? '-' : '+', port);
+		  scm_intprint ((long) IDIST (exp), 10, port);
+		  break;
+#endif
+		}
+	    default:
+	      fprintf_filtered (stream, "#<%lX>", svalue);
+	    }
+	}
+      gdb_flush (stream);
+      return (0);
+    }
+  else
+    {
+      return c_val_print (type, valaddr, address, stream, format,
+			  deref_ref, recurse, pretty);
+    }
+}
+
+int
+scm_value_print (val, stream, format, pretty)
+     value_ptr val;
+     GDB_FILE *stream;
+     int format;
+     enum val_prettyprint pretty;
+{
+  return (val_print (VALUE_TYPE (val), VALUE_CONTENTS (val),
+		     VALUE_ADDRESS (val), stream, format, 1, 0, pretty));
+}
+
+static value_ptr
+evaluate_subexp_scm (expect_type, exp, pos, noside)
+     struct type *expect_type;
+     register struct expression *exp;
+     register int *pos;
+     enum noside noside;
+{
+  enum exp_opcode op = exp->elts[*pos].opcode;
+  value_ptr func, addr;
+  int len, pc;  char *str;
+  switch (op)
+    {
+    case OP_EXPRSTRING:
+      pc = (*pos)++;
+      len = longest_to_int (exp->elts[pc + 1].longconst);
+      (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
+      if (noside == EVAL_SKIP)
+	goto nosideret;
+      str = &exp->elts[ + 2].string;
+      addr = value_allocate_space_in_inferior (len);
+      write_memory (value_as_long (addr), str, len);
+      func = find_function_in_inferior ("scm_evstr");
+      return call_function_by_hand (func, 1, &addr);
+    default: ;
+    }
+  return evaluate_subexp_standard (expect_type, exp, pos, noside);
+ nosideret:
+  return value_from_longest (builtin_type_long, (LONGEST) 1);
+}
+
+const struct language_defn scm_language_defn = {
+  "scheme",			/* Language name */
+  language_scm,
+  c_builtin_types,
+  range_check_off,
+  type_check_off,
+  scm_parse,
+  c_error,
+  evaluate_subexp_scm,
+  scm_printchar,			/* Print a character constant */
+  scm_printstr,			/* Function to print string constant */
+  NULL,	/* Create fundamental type in this language */
+  c_print_type,			/* Print a type using appropriate syntax */
+  scm_val_print,		/* Print a value using appropriate syntax */
+  scm_value_print,		/* Print a top-level value */
+  {"",     "",    "",  ""},	/* Binary format info */
+  {"#o%lo",  "#o",   "o", ""},	/* Octal format info */
+  {"%ld",   "",    "d", ""},	/* Decimal format info */
+  {"#x%lX", "#X",  "X", ""},	/* Hex format info */
+  NULL,				/* expression operators for printing */
+  1,				/* c-style arrays */
+  0,				/* String lower bound */
+  &builtin_type_char,		/* Type of string elements */ 
+  LANG_MAGIC
+};
+
+void
+_initialize_scheme_language ()
+{
+  add_language (&scm_language_defn);
+}