* expression.h (enum exp_code): Added OP_NAME.

* expprint.c (print_subexp):  Add OP_NAME support.
	* parse.c (length_of_subexp, prefixify_subexp):  Likewise.
	* scm-lang.c (scm_unpack, in_eval_c, scm_lookup_name):  new function.
	* scm-lang.h:  Declare builtin_type_scm;  other minor tweaks.
	* values.c (unpack_long):  If type is SCM, call scm_unpack.
	* scm-valprint.c (scm_val_print):  Use extract_signed_integer,
	instead unpack_long
	* scm-lang.c: More Scheme expression parsing from here ...
	* scm-exp.c:  ... to here.  New file.
	Also, provide for gdb to evaluate simple constants and names..
	* Makefile.in:  Note new scm-exp.{c,o}.

gdb/.Sanitize

@@ -286,6 +286,7 @@ rs6000-nat.c
 rs6000-tdep.c
 rom68k-rom.c
 saber.suppress
+scm-exp.c
 scm-lang.c
 scm-lang.h
 scm-tags.h

gdb/ChangeLog

@@ -1,3 +1,18 @@
+Wed Oct  4 18:41:34 1995  Per Bothner  <bothner@kalessin.cygnus.com>
+
+	* expression.h (enum exp_code):  Added OP_NAME.
+	* expprint.c (print_subexp):  Add OP_NAME support.
+	* parse.c (length_of_subexp, prefixify_subexp):  Likewise.
+	* scm-lang.c (scm_unpack, in_eval_c, scm_lookup_name):  new function.
+	* scm-lang.h:  Declare builtin_type_scm;  other minor tweaks.
+	* values.c (unpack_long):  If type is SCM, call scm_unpack.
+	* scm-valprint.c (scm_val_print):  Use extract_signed_integer,
+	instead unpack_long
+	* scm-lang.c: More Scheme expression parsing from here ...
+	* scm-exp.c:  ... to here.  New file.
+	Also, provide for gdb to evaluate simple constants and names..	
+	* Makefile.in:  Note new scm-exp.{c,o}.
+	
 Wed Oct  4 17:23:03 1995  Per Bothner  <bothner@kalessin.cygnus.com>
 
 	* gdbtypes.c (get_discrete_bounds):  New function.

gdb/Makefile.in

@@ -355,7 +355,7 @@ 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 scm-lang.c scm-valprint.c \
+	printcmd.c remote.c remote-nrom.c scm-exp.c scm-lang.c scm-valprint.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 \
@@ -466,8 +466,8 @@ 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 scm-lang.o scm-valprint.o \
+	c-lang.o ch-lang.o f-lang.o m2-lang.o \
-	complaints.o typeprint.o \
+	scm-exp.o scm-lang.o scm-valprint.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 \
 	nlmread.o serial.o mdebugread.o os9kread.o top.o utils.o callback.o

gdb/parse.c

@@ -512,6 +512,7 @@ length_of_subexp (expr, endpos)
       /* fall through */
     case OP_M2_STRING:
     case OP_STRING:
+    case OP_NAME:
     case OP_EXPRSTRING:
       oplen = longest_to_int (expr->elts[endpos - 2].longconst);
       oplen = 4 + BYTES_TO_EXP_ELEM (oplen + 1);
@@ -650,6 +651,7 @@ prefixify_subexp (inexpr, outexpr, inend, outbeg)
       /* fall through */
     case OP_M2_STRING:
     case OP_STRING:
+    case OP_NAME:
     case OP_EXPRSTRING:
       oplen = longest_to_int (inexpr->elts[inend - 2].longconst);
       oplen = 4 + BYTES_TO_EXP_ELEM (oplen + 1);

gdb/scm-exp.c

@@ -0,0 +1,409 @@
+/* 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_lreadr PARAMS ((int));
+
+LONGEST
+scm_istr2int(str, len, radix)
+     char *str;
+     int len;
+     int radix;
+{
+  int j;
+  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);
+}
+
+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 */
+  SCM res;
+  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;
+ 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:
+	callshrp:
+	  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;
+    do_symbol:
+    default:
+      str.ptr = lexptr-1;
+      scm_read_token (c, 0);
+    tok:
+      if (!skipping)
+	{
+	  str.length = lexptr - str.ptr;
+	  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;
+  struct stoken str;
+  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;
+}

gdb/scm-lang.c

@@ -32,253 +32,7 @@ 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 ();
+struct type *builtin_type_scm;
-
-struct type *SCM_TYPE = NULL;
-
-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;
-}
 
 void
 scm_printchar (c, stream)
@@ -305,7 +59,6 @@ is_scmvalue_type (type)
   if (TYPE_CODE (type) == TYPE_CODE_INT
       && TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
     {
-      SCM_TYPE = type;
       return 1;
     }
   return 0;
@@ -321,11 +74,127 @@ scm_get_field (svalue, index)
 {
   value_ptr val;
   char buffer[20];
-  if (SCM_TYPE == NULL)
+  read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm),
-    error ("internal error - no SCM type");
+	       buffer, TYPE_LENGTH (builtin_type_scm));
-  read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (SCM_TYPE),
+  return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm));
-	       buffer, TYPE_LENGTH (SCM_TYPE));
+}
-  return unpack_long (SCM_TYPE, buffer);
+
+/* Unpack a value of type TYPE in buffer VALADDR as an integer
+   (if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
+   or Boolean (CONTEXT == TYPE_CODE_BOOL).  */
+
+LONGEST
+scm_unpack (type, valaddr, context)
+     struct type *type;
+     char *valaddr;
+     enum type_code context;
+{
+  if (is_scmvalue_type (type))
+    {
+      LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
+      if (context == TYPE_CODE_BOOL)
+	{
+	  if (svalue == SCM_BOOL_F)
+	    return 0;
+	  else
+	    return 1;
+	}
+      switch (7 & svalue)
+	{
+	case 2:  case 6: /* fixnum */
+	  return svalue >> 2;
+	case 4: /* other immediate value */
+	  if (SCM_ICHRP (svalue)) /* character */
+	    return SCM_ICHR (svalue);
+	  else if (SCM_IFLAGP (svalue))
+	    {
+	      switch (svalue)
+		{
+#ifndef SICP
+		case SCM_EOL:
+#endif
+		case SCM_BOOL_F:
+		  return 0;
+		case SCM_BOOL_T:
+		  return 1;
+		}
+	    }
+	  error ("Value can't be converted to integer.");
+	default:
+	  return svalue;
+	}
+    }
+  else
+    return unpack_long (type, valaddr);
+}
+
+/* True if we're correctly in Guile's eval.c (the evaluator and apply). */
+
+static int
+in_eval_c ()
+{
+  if (current_source_symtab && current_source_symtab->filename)
+    {
+      char *filename = current_source_symtab->filename;
+      int len = strlen (filename);
+      if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
+	return 1;
+    }
+  return 0;
+}
+
+/* Lookup a value for the variable named STR.
+   First lookup in Scheme context (using the scm_lookup_cstr inferior
+   function), then try lookup_symbol for compiled variables. */
+
+value_ptr
+scm_lookup_name (str)
+     char *str;
+{
+  value_ptr args[3];
+  int len = strlen (str);
+  value_ptr symval, func, val;
+  struct symbol *sym;
+  args[0] = value_allocate_space_in_inferior (len);
+  args[1] = value_from_longest (builtin_type_int, len);
+  write_memory (value_as_long (args[0]), str, len);
+
+  if (in_eval_c ()
+      && (sym = lookup_symbol ("env",
+			       expression_context_block,
+			       VAR_NAMESPACE, (int *) NULL,
+			       (struct symtab **) NULL)) != NULL)
+    args[2] = value_of_variable (sym, expression_context_block);
+  else
+    /* FIXME in this case, we should try lookup_symbol first */
+    args[2] = value_from_longest (builtin_type_scm, SCM_EOL);
+
+  func = find_function_in_inferior ("scm_lookup_cstr");
+  val = call_function_by_hand (func, 3, args);
+  if (!value_logical_not (val))
+    return value_ind (val);
+
+  sym = lookup_symbol (str,
+		       expression_context_block,
+		       VAR_NAMESPACE, (int *) NULL,
+		       (struct symtab **) NULL);
+  if (sym)
+    return value_of_variable (sym, NULL);
+  error ("No symbol \"%s\" in current context.");
+}
+
+value_ptr
+scm_evaluate_string (str, len)
+     char *str; int len;
+{
+  value_ptr func;
+  value_ptr addr = value_allocate_space_in_inferior (len + 1);
+  LONGEST iaddr = value_as_long (addr);
+  write_memory (iaddr, str, len);
+  /* FIXME - should find and pass env */
+  write_memory (iaddr + len, "", 1);
+  func = find_function_in_inferior ("scm_evstr");
+  return call_function_by_hand (func, 1, &addr);
 }
 
 static value_ptr
@@ -336,21 +205,25 @@ evaluate_subexp_scm (expect_type, exp, pos, noside)
      enum noside noside;
 {
   enum exp_opcode op = exp->elts[*pos].opcode;
-  value_ptr func, addr;
   int len, pc;  char *str;
   switch (op)
     {
+    case OP_NAME:
+      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[pc + 2].string;
+      return scm_lookup_name (str);
     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;
+      str = &exp->elts[pc + 2].string;
-      addr = value_allocate_space_in_inferior (len);
+      return scm_evaluate_string (str, 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);
@@ -388,4 +261,7 @@ void
 _initialize_scheme_language ()
 {
   add_language (&scm_language_defn);
+  builtin_type_scm = init_type (TYPE_CODE_INT,
+				TARGET_LONG_BIT / TARGET_CHAR_BIT,
+				0, "SCM", (struct objfile *) NULL);
 }

gdb/scm-lang.h

@@ -20,6 +20,7 @@
 #define SCM_VELTS(x) ((SCM *)SCM_CDR(x))
 #define SCM_CLOSCAR(x) (SCM_CAR(x)-scm_tc3_closure)
 #define SCM_CODE(x) SCM_CAR(SCM_CLOSCAR (x))
+#define SCM_MAKINUM(x) (((x)<<2)+2L)
 
 #ifdef __STDC__		/* Forward decls for prototypes */
 struct value;
@@ -40,5 +41,8 @@ extern int is_scmvalue_type PARAMS ((struct type*));
 
 extern void scm_printchar PARAMS ((int, GDB_FILE*));
 
-struct type *SCM_TYPE;
+extern struct value * scm_evaluate_string PARAMS ((char*, int));
 
+extern struct type *builtin_type_scm;
+
+extern int scm_parse ();

gdb/scm-valprint.c

@@ -128,7 +128,7 @@ scm_ipruk (hdr, ptr, stream)
      GDB_FILE *stream;
 {
   fprintf_filtered (stream, "#<unknown-%s", hdr);
-#define SCM_SIZE (SCM_TYPE ? TYPE_LENGTH (SCM_TYPE) : sizeof (void*))
+#define SCM_SIZE TYPE_LENGTH (builtin_type_scm)
   if (SCM_CELLP (ptr))
     fprintf_filtered (stream, " (0x%lx . 0x%lx) @",
 		      (long) SCM_CAR (ptr), (long) SCM_CDR (ptr));
@@ -372,7 +372,7 @@ scm_val_print (type, valaddr, address, stream, format, deref_ref, recurse,
 {
   if (is_scmvalue_type (type))
     {
-      LONGEST svalue = unpack_long (type, valaddr);
+      LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
       if (scm_inferior_print (svalue, stream, format,
 			      deref_ref, recurse, pretty) >= 0)
 	{

gdb/values.c

@@ -630,6 +630,10 @@ unpack_long (type, valaddr)
   register int len = TYPE_LENGTH (type);
   register int nosign = TYPE_UNSIGNED (type);
 
+  if (current_language->la_language == language_scm
+      && is_scmvalue_type (type))
+    return scm_unpack (type, valaddr, TYPE_CODE_INT);
+
   switch (code)
     {
     case TYPE_CODE_ENUM: