Enhanced language support for Modula-2

Enhanced language support for Modula-2

[Gaius Mulley]

Hi,

I'm working on the GNU Modula-2 front end to gcc and as a consequence
I've had to debug quite a lot of Modula-2 code with gdb :-), rarely
bother to run an a.out without gdb.

Anyhow this patch provides better support for Modula-2 in the
following areas:

  *  basic types are printed correctly when -gdwarf-2 is specified
     on the gm2 command line.
  *  set types are supported (type printing and value printing).
     The patch correctly identifies:  SET OF CHAR, SET OF ['a'..'z']
     etc.
  *  long and short (word length) sets are supported.
  *  range types are also identified and `ptype' prints them correctly.
  *  automatic detection of Modula-2 generated executable is enabled.
  *  VAR parameters are printed correctly
  *  hexadecimal addresses are written using the Modula-2 syntax.
  *  character constants are written using the octal syntax
     (in the same way as PIM-[234].)

A few years ago I signed a assignment future form and transferred any
copyright to the FSF for any gdb work, so if these patches are of
any use, please use them..

BTW these patches work better when the patch from Waldek Hebisch is
applied. In fact these patches assume that Waldek's patch for
dwarf2read.c was applied, as they modify his work slightly to include
Modula-2.

http://sources.redhat.com/ml/gdb-patches/2005-05/msg00505.html

best wishes and thanks for maintaining gdb,

Gaius


--- latest-cvs-gdb/src-cvs/gdb/m2-lang.h	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-lang.h	2006-02-15 10:49:54.000000000 +0000
@@ -27,6 +27,11 @@
 extern void m2_print_type (struct type *, char *, struct ui_file *, int,
 			   int);
 
+extern int m2_is_long_set (struct type *type);
+
 extern int m2_val_print (struct type *, const gdb_byte *, int, CORE_ADDR,
 			 struct ui_file *, int, int, int,
 			 enum val_prettyprint);
+
+extern int get_long_set_bounds (struct type *type, LONGEST *low,
+				LONGEST *high);
--- latest-cvs-gdb/src-cvs/gdb/m2-typeprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-typeprint.c	2006-02-15 14:49:46.000000000 +0000
@@ -1,5 +1,6 @@
 /* Support for printing Modula 2 types for GDB, the GNU debugger.
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    This file is part of GDB.
@@ -20,22 +21,794 @@
    Boston, MA 02110-1301, USA.  */
 
 #include "defs.h"
+#include "gdb_obstack.h"
 #include "bfd.h"		/* Binary File Description */
 #include "symtab.h"
 #include "gdbtypes.h"
 #include "expression.h"
 #include "value.h"
 #include "gdbcore.h"
-#include "target.h"
 #include "m2-lang.h"
+#include "target.h"
+#include "language.h"
+#include "demangle.h"
+#include "c-lang.h"
+#include "typeprint.h"
+#include "cp-abi.h"
+
+#include "gdb_string.h"
 #include <errno.h>
 
+static void m2_type_print_args (struct type *, struct ui_file *);
+
+void m2_type_print_varspec_prefix (struct type *, struct ui_file *, int,
+				   int);
+void m2_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
+				   int show, int passed_a_ptr, int demangled_args);
+
+
+void m2_type_print_base (struct type *type, struct ui_file *stream, int show,
+			 int level);
+
+static void m2_print_bounds (struct type *type,
+			     struct ui_file *stream, int show, int level,
+			     int print_high);
+
+/* Print "const", "volatile", or address space modifiers. */
+static void m2_type_print_modifier (struct type *, struct ui_file *,
+				   int, int);
+
 void
 m2_print_type (struct type *type, char *varstring, struct ui_file *stream,
-	       int show, int level)
+	      int show, int level)
+{
+  enum type_code code;
+  int demangled_args;
+
+  if (show > 0)
+    CHECK_TYPEDEF (type);
+
+  code = TYPE_CODE (type);
+
+  /*
+   *  is it a VAR parameter?
+   */
+  if (code == TYPE_CODE_REF)
+    fputs_filtered ("VAR", stream);
+
+  m2_type_print_varspec_prefix (type, stream, show, 0);
+  m2_type_print_varspec_suffix (type, stream, show, 0, 0);
+  m2_type_print_base (type, stream, show, level);
+}
+
+/* Print any asterisks or open-parentheses needed before the
+   variable name (to describe its type).
+
+   On outermost call, pass 0 for PASSED_A_PTR.
+   On outermost call, SHOW > 0 means should ignore
+   any typename for TYPE and show its details.
+   SHOW is always zero on recursive calls.  */
+
+void
+m2_type_print_varspec_prefix (struct type *type, struct ui_file *stream,
+			     int show, int passed_a_ptr)
+{
+  char *name;
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_PTR:
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_FUNC) {
+	m2_type_print_modifier (type, stream, 1, 0);
+	fprintf_filtered (stream, "POINTER TO ");
+	m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
+      }
+      break;
+
+    case TYPE_CODE_MEMBER:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, "(");
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      fprintf_filtered (stream, " ");
+      name = type_name_no_tag (TYPE_DOMAIN_TYPE (type));
+      if (name)
+	fputs_filtered (name, stream);
+      else
+	m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, 0, passed_a_ptr);
+      fprintf_filtered (stream, "::");
+      break;
+
+    case TYPE_CODE_METHOD:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, "(");
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      if (passed_a_ptr)
+	{
+	  fprintf_filtered (stream, " ");
+	  m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, 0, passed_a_ptr);
+	  fprintf_filtered (stream, "::");
+	}
+      break;
+
+    case TYPE_CODE_REF:
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
+      fprintf_filtered (stream, " ");
+      m2_type_print_modifier (type, stream, 1, 0);
+      break;
+
+    case TYPE_CODE_FUNC:
+      break;
+
+    case TYPE_CODE_ARRAY:
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_STRING:
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_TYPEDEF:
+    case TYPE_CODE_TEMPLATE:
+      /* These types need no prefix.  They are listed here so that
+         gcc -Wall will reveal any types that haven't been handled.  */
+      break;
+    default:
+      error ("type not handled in m2_type_print_varspec_prefix()");
+      break;
+    }
+}
+
+/* Print out "const" and "volatile" attributes.
+   TYPE is a pointer to the type being printed out.
+   STREAM is the output destination.
+   NEED_SPACE = 1 indicates an initial white space is needed */
+
+static void
+m2_type_print_modifier (struct type *type, struct ui_file *stream,
+		       int need_pre_space, int need_post_space)
+{
+  int did_print_modifier = 0;
+  const char *address_space_id;
+
+  /* We don't print `const' qualifiers for references --- since all
+     operators affect the thing referenced, not the reference itself,
+     every reference is `const'.  */
+  if (TYPE_CONST (type)
+      && TYPE_CODE (type) != TYPE_CODE_REF)
+    {
+      if (need_pre_space)
+	fprintf_filtered (stream, " ");
+      fprintf_filtered (stream, "const");
+      did_print_modifier = 1;
+    }
+
+  if (TYPE_VOLATILE (type))
+    {
+      if (did_print_modifier || need_pre_space)
+	fprintf_filtered (stream, " ");
+      fprintf_filtered (stream, "volatile");
+      did_print_modifier = 1;
+    }
+
+  address_space_id = address_space_int_to_name (TYPE_INSTANCE_FLAGS (type));
+  if (address_space_id)
+    {
+      if (did_print_modifier || need_pre_space)
+	fprintf_filtered (stream, " ");
+      fprintf_filtered (stream, "@%s", address_space_id);
+      did_print_modifier = 1;
+    }
+
+  if (did_print_modifier && need_post_space)
+    fprintf_filtered (stream, " ");
+}
+
+
+
+
+static void
+m2_type_print_args (struct type *type, struct ui_file *stream)
 {
-  extern void c_print_type (struct type *, char *, struct ui_file *, int,
-			    int);
+  int i;
+  struct field *args;
+
+  fprintf_filtered (stream, "(");
+  args = TYPE_FIELDS (type);
+  if (args != NULL)
+    {
+      int i;
+
+      /* FIXME drow/2002-05-31: Always skips the first argument,
+	 should we be checking for static members?  */
+
+      for (i = 1; i < TYPE_NFIELDS (type); i++)
+	{
+	  c_print_type (args[i].type, "", stream, -1, 0);
+	  if (i != TYPE_NFIELDS (type))
+	    {
+	      fprintf_filtered (stream, ",");
+	      wrap_here ("    ");
+	    }
+	}
+      if (TYPE_VARARGS (type))
+	fprintf_filtered (stream, "...");
+      else if (i == 1
+	       && (current_language->la_language == language_cplus))
+	fprintf_filtered (stream, "void");
+    }
+  else if (current_language->la_language == language_cplus)
+    {
+      fprintf_filtered (stream, "void");
+    }
+
+  fprintf_filtered (stream, ")");
+}
+
+
+
+
+/* Print any array sizes, function arguments or close parentheses
+   needed after the variable name (to describe its type).
+   Args work like m2_type_print_varspec_prefix.  */
+
+void
+m2_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
+			      int show, int passed_a_ptr, int demangled_args)
+{
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      fprintf_filtered (stream, "ARRAY [");
+      if (TYPE_LENGTH (type) >= 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0
+	  && TYPE_ARRAY_UPPER_BOUND_TYPE (type) != BOUND_CANNOT_BE_DETERMINED) {
+	if (TYPE_INDEX_TYPE (type) != 0) {
+	  m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 0);
+	  fprintf_filtered (stream, "..");
+	  m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 1);
+	}
+	else
+	  fprintf_filtered (stream, "%d",
+			    (TYPE_LENGTH (type)
+			     / TYPE_LENGTH (TYPE_TARGET_TYPE (type))));
+      }
+      fprintf_filtered (stream, "] OF ");
+
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      break;
+
+    case TYPE_CODE_MEMBER:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, ")");
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      break;
+
+    case TYPE_CODE_METHOD:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, ")");
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      if (passed_a_ptr)	{
+	m2_type_print_args (type, stream);
+      }
+      break;
+
+    case TYPE_CODE_PTR:
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_FUNC) {
+	fprintf_filtered (stream, "PROCEDURE");
+	break;
+      }
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
+      break;
+
+    case TYPE_CODE_REF:
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
+      break;
+
+    case TYPE_CODE_FUNC:
+      if (!demangled_args)
+	{
+	  int i, len = TYPE_NFIELDS (type);
+
+	  fprintf_filtered (stream, " (");
+	  for (i = 0; i < len; i++)
+	    {
+	      if (i > 0)
+		{
+		  fputs_filtered (", ", stream);
+		  wrap_here ("    ");
+		}
+	      m2_print_type (TYPE_FIELD_TYPE (type, i), "", stream, -1, 0);
+	    }
+	  fprintf_filtered (stream, ")");
+	}
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID) {
+	fprintf_filtered (stream, " : ");
+	m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
+				      passed_a_ptr, 0);
+      }
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_STRING:
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_TYPEDEF:
+    case TYPE_CODE_TEMPLATE:
+      /* These types do not need a suffix.  They are listed so that
+         gcc -Wall will report types that may not have been considered.  */
+      break;
+    default:
+      error ("type not handled in m2_type_print_varspec_suffix()");
+      break;
+    }
+}
+
+
+static void
+m2_print_bounds (struct type *type,
+		 struct ui_file *stream, int show, int level,
+		 int print_high)
+{
+  struct type *target = TYPE_TARGET_TYPE (type);
+
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (TYPE_NFIELDS(type) == 0)
+    return;
+
+  if (print_high)
+    print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+  else
+    print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+}
+
+static void
+m2_short_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  fprintf_filtered(stream, "SET [");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 0);
+
+  fprintf_filtered(stream, "..");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 1);
+  fprintf_filtered(stream, "]");
+}
+
+int
+m2_is_long_set (struct type *type)
+{
+  LONGEST previous_high = 0;  /* unnecessary initialization keeps gcc -Wall happy */
+  int len, i;
+  struct type *range;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+
+    /*
+     *  check if all fields of the RECORD are consecutive sets
+     */
+    len = TYPE_NFIELDS (type);
+    for (i = TYPE_N_BASECLASSES (type); i < len; i++) {
+      if (TYPE_FIELD_TYPE (type, i) == NULL)
+	return 0;
+      if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) != TYPE_CODE_SET)
+	return 0;
+      if (TYPE_FIELD_NAME (type, i) != NULL
+	  && (strcmp (TYPE_FIELD_NAME (type, i), "") != 0))
+	return 0;
+      range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+      if ((i > TYPE_N_BASECLASSES (type))
+	  && previous_high + 1 != TYPE_LOW_BOUND (range))
+	return 0;
+      previous_high = TYPE_HIGH_BOUND (range);
+    }
+    return len>0;
+  }
+  return 0;
+}
+
+/*
+ *  m2_get_discrete_bounds - a wrapper for get_discrete_bounds which
+ *                           understands that CHARs might be signed.
+ *                           This should be integrated into gdbtypes.c
+ *                           inside get_discrete_bounds.
+ */
+
+int
+m2_get_discrete_bounds (struct type *type, LONGEST *lowp, LONGEST *highp)
+{
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_CHAR:
+      if (TYPE_LENGTH (type) < sizeof (LONGEST)) {
+	if (!TYPE_UNSIGNED (type))
+	  {
+	    *lowp = -(1 << (TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1));
+	    *highp = -*lowp - 1;
+	    return 0;
+	  }
+      }
+      /* fall through */
+    default:
+      return get_discrete_bounds (type, lowp, highp);
+    }
+}
+
+/*
+ *  m2_is_long_set_of_type - returns TRUE if the long set was declared as SET OF <oftype>
+ *                           of_type is assigned to the subtype.
+ */
+
+int
+m2_is_long_set_of_type (struct type *type, struct type **of_type)
+{
+  int len, i;
+  struct type *range;
+  struct type *target;
+  LONGEST l1, l2;
+  LONGEST h1, h2;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+    target = TYPE_TARGET_TYPE (range);
+    if (target == NULL)
+      target = builtin_type_int;
+
+    l1 = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    h1 = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    *of_type = target;
+    if (m2_get_discrete_bounds (target, &l2, &h2) >= 0)
+      return (l1 == l2 && h1 == h2);
+    error ("long_set failed to find discrete bounds for its subtype");
+    return 0;
+  }
+  error ("expecting long_set");
+  return 0;
+}
+
+static int
+m2_long_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  struct type *index_type;
+  struct type *range_type;
+  struct type *of_type;
+  int i;
+  int len = TYPE_NFIELDS (type);
+  LONGEST low;
+  LONGEST high;
+
+  if (m2_is_long_set (type)) {
+    if (TYPE_TAG_NAME (type) != NULL) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+    else if (TYPE_NAME (type) != NULL) {
+      fputs_filtered (TYPE_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+
+    if (TYPE_TAG_NAME (type) != NULL || TYPE_NAME (type) != NULL)
+      fputs_filtered (" = ", stream);
+
+    if (get_long_set_bounds (type, &low, &high)) {
+      fprintf_filtered(stream, "SET OF ");
+      i = TYPE_N_BASECLASSES (type);
+      if (m2_is_long_set_of_type (type, &of_type))
+	m2_print_type (of_type, "", stream, show - 1, level);
+      else {
+	fprintf_filtered(stream, "[");
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)),
+			 stream, show - 1, level, 0);
+
+	fprintf_filtered(stream, "..");
+
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)),
+			 stream, show - 1, level, 1);
+	fprintf_filtered(stream, "]");
+      }
+    }
+    else
+      fprintf_filtered(stream, "SET OF <unknown> ");
+
+    return 1;
+  }
+  return 0;
+}
+
+void
+m2_record_fields (struct type *type, struct ui_file *stream, int show,
+		  int level)
+{
+  /* Print the tag if it exists. 
+   */
+  if (TYPE_TAG_NAME (type) != NULL) {
+    if (strncmp (TYPE_TAG_NAME (type), "$$", 2) != 0) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show > 0)
+	fprintf_filtered (stream, " = ");
+    }
+  }
+  wrap_here ("    ");
+  if (show < 0)
+    {
+      if (TYPE_CODE (type) == DECLARED_TYPE_STRUCT)
+	fprintf_filtered (stream, "RECORD ... END ");
+      else if (TYPE_DECLARED_TYPE (type) == DECLARED_TYPE_UNION)
+	fprintf_filtered (stream, "CASE ... END ");
+    }
+  else if (show > 0)
+    {
+      if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
+	fprintf_filtered (stream, "RECORD\n");
+      else if (TYPE_CODE (type) == TYPE_CODE_UNION)
+	fprintf_filtered (stream, "CASE <variant> OF\n");
+      int i;
+      int len = TYPE_NFIELDS (type);
+
+      for (i = TYPE_N_BASECLASSES (type); i < len; i++)
+	{
+	  QUIT;
+
+	  print_spaces_filtered (level + 4, stream);
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	  fputs_filtered (" : ", stream);
+	  m2_print_type (TYPE_FIELD_TYPE (type, i),
+			 "",
+			 stream, 0, level + 4);
+	  if (TYPE_FIELD_PACKED (type, i))
+	    {
+	      /* It is a bitfield.  This code does not attempt
+		 to look at the bitpos and reconstruct filler,
+		 unnamed fields.  This would lead to misleading
+		 results if the compiler does not put out fields
+		 for such things (I don't know what it does).  */
+	      fprintf_filtered (stream, " : %d",
+				TYPE_FIELD_BITSIZE (type, i));
+	    }
+	  fprintf_filtered (stream, ";\n");
+	}
+      
+      fprintfi_filtered (level, stream, "END ");
+    }
+}
+
+/* Print the name of the type (or the ultimate pointer target,
+   function value or array element), or the description of a
+   structure or union.
+
+   SHOW positive means print details about the type (e.g. enum values),
+   and print structure elements passing SHOW - 1 for show.
+   SHOW negative means just print the type name or struct tag if there is one.
+   If there is no name, print something sensible but concise like
+   "struct {...}".
+   SHOW zero means just print the type name or struct tag if there is one.
+   If there is no name, print something sensible but not as concise like
+   "struct {int x; int y;}".
+
+   LEVEL is the number of spaces to indent by.
+   We increase it for some recursive calls.  */
+
+void
+m2_type_print_base (struct type *type, struct ui_file *stream, int show,
+		    int level)
+{
+  int i;
+  int len, real_len;
+  int lastval;
+  char *mangled_name;
+  char *demangled_name;
+  char *demangled_no_static;
+  enum
+    {
+      s_none, s_public, s_private, s_protected
+    }
+  section_type;
+  int need_access_label = 0;
+  int j, len2;
+
+  QUIT;
+
+  wrap_here ("    ");
+  if (type == NULL)
+    {
+      fputs_filtered ("<type unknown>", stream);
+      return;
+    }
+
+  /* When SHOW is zero or less, and there is a valid type name, then always
+     just print the type name directly from the type.  */
+  /* If we have "typedef struct foo {. . .} bar;" do we want to print it
+     as "struct foo" or as "bar"?  Pick the latter, because C++ folk tend
+     to expect things like "class5 *foo" rather than "struct class5 *foo".  */
+
+  if (show <= 0
+      && TYPE_NAME (type) != NULL)
+    {
+      m2_type_print_modifier (type, stream, 0, 1);
+      fputs_filtered (TYPE_NAME (type), stream);
+      return;
+    }
+
+  CHECK_TYPEDEF (type);
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_TYPEDEF:
+    case TYPE_CODE_ARRAY:
+    case TYPE_CODE_PTR:
+    case TYPE_CODE_MEMBER:
+    case TYPE_CODE_REF:
+    case TYPE_CODE_METHOD:
+      m2_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
+      break;
+
+    case TYPE_CODE_FUNC:
+      break;
+
+    case TYPE_CODE_SET:
+      m2_short_set(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_STRUCT:
+      if (m2_long_set (type, stream, show, level))
+	break;
+      m2_type_print_modifier (type, stream, 0, 1);
+      m2_record_fields(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_UNION:
+      m2_type_print_modifier (type, stream, 0, 1);
+      m2_record_fields(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_ENUM:
+      m2_type_print_modifier (type, stream, 0, 1);
+      /* HP C supports sized enums */
+      if (deprecated_hp_som_som_object_present)
+	switch (TYPE_LENGTH (type))
+	  {
+	  case 1:
+	    fputs_filtered ("char ", stream);
+	    break;
+	  case 2:
+	    fputs_filtered ("short ", stream);
+	    break;
+	  default:
+	    break;
+	  }
+      /* Print the tag name if it exists.
+         The aCC compiler emits a spurious 
+         "{unnamed struct}"/"{unnamed union}"/"{unnamed enum}"
+         tag for unnamed struct/union/enum's, which we don't
+         want to print. */
+      if (TYPE_TAG_NAME (type) != NULL &&
+	  strncmp (TYPE_TAG_NAME (type), "{unnamed", 8))
+	{
+	  fputs_filtered (TYPE_TAG_NAME (type), stream);
+	  if (show > 0)
+	    fputs_filtered (" ", stream);
+	}
+
+      wrap_here ("    ");
+      if (show < 0)
+	{
+	  /* If we just printed a tag name, no need to print anything else.  */
+	  if (TYPE_TAG_NAME (type) == NULL)
+	    fprintf_filtered (stream, "(...)");
+	}
+      else if (show > 0 || TYPE_TAG_NAME (type) == NULL)
+	{
+	  fprintf_filtered (stream, "(");
+	  len = TYPE_NFIELDS (type);
+	  lastval = 0;
+	  for (i = 0; i < len; i++)
+	    {
+	      QUIT;
+	      if (i)
+		fprintf_filtered (stream, ", ");
+	      wrap_here ("    ");
+	      fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	      if (lastval != TYPE_FIELD_BITPOS (type, i))
+		{
+		  fprintf_filtered (stream, " = %d", TYPE_FIELD_BITPOS (type, i));
+		  lastval = TYPE_FIELD_BITPOS (type, i);
+		}
+	      lastval++;
+	    }
+	  fprintf_filtered (stream, ")");
+	}
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "void");
+      break;
+
+    case TYPE_CODE_UNDEF:
+      fprintf_filtered (stream, "struct <unknown>");
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, "<unknown type>");
+      break;
+
+    case TYPE_CODE_RANGE:
+      if (TYPE_HIGH_BOUND (type) == TYPE_LOW_BOUND (type))
+	m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, show, level);
+      else {
+	struct type *target = TYPE_TARGET_TYPE (type);
+
+	fprintf_filtered (stream, "[");
+	print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+	fprintf_filtered (stream, "..");
+	print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+	fprintf_filtered (stream, "]");
+      }
+      break;
+
+    case TYPE_CODE_TEMPLATE:
+      break;
 
-  c_print_type (type, varstring, stream, show, level);	/* FIXME */
+    default:
+      /* Handle types not explicitly handled by the other cases,
+         such as fundamental types.  For these, just print whatever
+         the type name is, as recorded in the type itself.  If there
+         is no type name, then complain. */
+      if (TYPE_NAME (type) != NULL)
+	{
+	  m2_type_print_modifier (type, stream, 0, 1);
+	  fputs_filtered (TYPE_NAME (type), stream);
+	}
+      else
+	{
+	  /* At least for dump_symtab, it is important that this not be
+	     an error ().  */
+	  fprintf_filtered (stream, "<invalid type code %d>",
+			    TYPE_CODE (type));
+	}
+      break;
+    }
 }
--- latest-cvs-gdb/src-cvs/gdb/dwarf2read.c	2006-02-09 18:18:41.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/dwarf2read.c	2006-02-15 10:48:27.000000000 +0000
@@ -921,6 +921,8 @@
 
 static void read_enumeration_type (struct die_info *, struct dwarf2_cu *);
 
+static void read_set_type (struct die_info *, struct dwarf2_cu *);
+
 static void process_enumeration_scope (struct die_info *, struct dwarf2_cu *);
 
 static struct type *dwarf_base_type (int, int, struct dwarf2_cu *);
@@ -2655,6 +2657,9 @@
       read_enumeration_type (die, cu);
       process_enumeration_scope (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
 
     /* FIXME drow/2004-03-14: These initialize die->type, but do not create
        a symbol or process any children.  Therefore it doesn't do anything
@@ -4038,6 +4043,20 @@
   return new_prefix;
 }
 
+static void
+read_set_type (struct die_info * die, struct dwarf2_cu *cu)
+{
+  struct type *domain_type;
+
+  /* Return if we've already decoded this type. */
+  if (die->type)
+    return;
+
+  domain_type = die_type (die, cu);
+  die->type = create_set_type (NULL, domain_type);
+}
+
+
 /* Given a pointer to a die which begins an enumeration, process all
    the dies that define the members of the enumeration, and create the
    symbol for the enumeration type.
@@ -4728,10 +4747,15 @@
 	  code = TYPE_CODE_FLT;
 	  break;
 	case DW_ATE_signed:
-	case DW_ATE_signed_char:
 	  break;
 	case DW_ATE_unsigned:
+	  type_flags |= TYPE_FLAG_UNSIGNED;
+	  break;
+	case DW_ATE_signed_char:
+	  code = TYPE_CODE_CHAR;
+	  break;
 	case DW_ATE_unsigned_char:
+	  code = TYPE_CODE_CHAR;
 	  type_flags |= TYPE_FLAG_UNSIGNED;
 	  break;
 	default:
@@ -6168,10 +6192,14 @@
     case DW_LANG_Ada95:
       cu->language = language_ada;
       break;
-    case DW_LANG_Cobol74:
-    case DW_LANG_Cobol85:
     case DW_LANG_Pascal83:
+      cu->language = language_pascal;
+      break;
     case DW_LANG_Modula2:
+      cu->language = language_m2;
+      break;
+    case DW_LANG_Cobol74:
+    case DW_LANG_Cobol85:
     default:
       cu->language = language_minimal;
       break;
@@ -6959,6 +6987,7 @@
 	case DW_TAG_structure_type:
 	case DW_TAG_union_type:
 	case DW_TAG_enumeration_type:
+	case DW_TAG_set_type:
 	  SYMBOL_CLASS (sym) = LOC_TYPEDEF;
 	  SYMBOL_DOMAIN (sym) = STRUCT_DOMAIN;
 
@@ -7280,6 +7309,9 @@
     case DW_TAG_enumeration_type:
       read_enumeration_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_subprogram:
     case DW_TAG_subroutine_type:
       read_subroutine_type (die, cu);
@@ -7337,7 +7369,8 @@
   struct die_info *parent;
 
   if (cu->language != language_cplus
-      && cu->language != language_java)
+      && cu->language != language_java
+      && cu->language != language_pascal)
     return NULL;
 
   parent = die->parent;
--- latest-cvs-gdb/src-cvs/gdb/m2-valprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-valprint.c	2006-02-15 14:49:28.000000000 +0000
@@ -1,7 +1,8 @@
 /* Support for printing Modula 2 values for GDB, the GNU debugger.
 
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998, 2000, 2005 Free
-   Software Foundation, Inc.
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998,
+                 2000, 2005, 2006
+   Free Software Foundation, Inc.
 
    This file is part of GDB.
 
@@ -23,14 +24,513 @@
 #include "defs.h"
 #include "symtab.h"
 #include "gdbtypes.h"
-#include "m2-lang.h"
+#include "expression.h"
+#include "value.h"
+#include "valprint.h"
+#include "language.h"
+#include "typeprint.h"
 #include "c-lang.h"
+#include "m2-lang.h"
+#include "target.h"
+
+
+/* Print function pointer with inferior address ADDRESS onto stdio
+   stream STREAM.  */
+
+static void
+print_function_pointer_address (CORE_ADDR address, struct ui_file *stream)
+{
+  CORE_ADDR func_addr = gdbarch_convert_from_func_ptr_addr (current_gdbarch,
+							    address,
+							    &current_target);
+
+  /* If the function pointer is represented by a description, print the
+     address of the description.  */
+  if (addressprint && func_addr != address)
+    {
+      fputs_filtered ("@", stream);
+      fputs_filtered (paddress (address), stream);
+      fputs_filtered (": ", stream);
+    }
+  print_address_demangle (func_addr, stream, demangle);
+}
+
+/*
+ *  get_long_set_bounds - assigns the bounds of the long set to low and high.
+ */
+
+int
+get_long_set_bounds (struct type *type, LONGEST *low, LONGEST *high)
+{
+  int len, i;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    *low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    *high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    return 1;
+  }
+  error ("expecting long_set");
+  return 0;
+}
+
+static void
+m2_print_long_set (struct type *type, const gdb_byte *valaddr, int embedded_offset,
+		   CORE_ADDR address, struct ui_file *stream, int format,
+		   enum val_prettyprint pretty)
+{
+  int empty_set        = 1;
+  int element_seen     = 0;
+  LONGEST previous_low = 0;
+  LONGEST previous_high= 0;
+  LONGEST i, low_bound, high_bound;
+  LONGEST field_low, field_high;
+  struct type *range;
+  int len, field;
+  struct type *target;
+  int bitval;
+
+  CHECK_TYPEDEF (type);
+
+  fprintf_filtered (stream, "{");
+  len = TYPE_NFIELDS (type);
+  if (get_long_set_bounds (type, &low_bound, &high_bound)) {
+    field = TYPE_N_BASECLASSES (type);
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+  }
+  else {
+    fprintf_filtered (stream, " <unknown bounds of set> }");
+    return;
+  }
+
+  target = TYPE_TARGET_TYPE (range);
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (get_discrete_bounds (range, &field_low, &field_high) >= 0) {
+    for (i = low_bound; i <= high_bound; i++) {
+      bitval = value_bit_index (TYPE_FIELD_TYPE (type, field),
+				(TYPE_FIELD_BITPOS (type, field) / 8) +
+				valaddr + embedded_offset, i);
+      if (bitval < 0)
+	error ("bit test is out of range");
+      else if (bitval > 0) {
+	previous_high = i;
+	if (! element_seen) {
+	  if (! empty_set)
+	    fprintf_filtered (stream, ", ");
+	  print_type_scalar (target, i, stream);
+	  empty_set    = 0;
+	  element_seen = 1;
+	  previous_low = i;
+	}
+      }
+      else {
+	/* bit is not set */
+	if (element_seen) {
+	  if (previous_low+1 < previous_high)
+	    fprintf_filtered (stream, "..");
+	  if (previous_low+1 < previous_high)
+	    print_type_scalar (target, previous_high, stream);
+	  element_seen = 0;
+	}
+      }
+      if (i == field_high) {
+	field++;
+	if (field == len)
+	  break;
+	range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+	if (get_discrete_bounds (range, &field_low, &field_high) < 0)
+	  break;
+	target = TYPE_TARGET_TYPE (range);
+	if (target == NULL)
+	  target = builtin_type_int;
+      }
+    }
+    if (element_seen) {
+      if (previous_low+1 < previous_high) {
+	fprintf_filtered (stream, "..");
+	print_type_scalar (target, previous_high, stream);
+      }
+      element_seen = 0;
+    }
+    fprintf_filtered (stream, "}");
+  }
+}
+
+/* Print data of type TYPE located at VALADDR (within GDB), which came from
+   the inferior at address ADDRESS, onto stdio stream STREAM according to
+   FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
+   target byte order.
+
+   If the data are a string pointer, returns the number of string characters
+   printed.
+
+   If DEREF_REF is nonzero, then dereference references, otherwise just print
+   them like pointers.
+
+   The PRETTY parameter controls prettyprinting.  */
 
 int
 m2_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 	      CORE_ADDR address, struct ui_file *stream, int format,
 	      int deref_ref, int recurse, enum val_prettyprint pretty)
 {
-  return (c_val_print (type, valaddr, 0, address, stream, format, deref_ref,
-		       recurse, pretty));
+  unsigned int i = 0;	/* Number of characters printed */
+  unsigned len;
+  struct type *elttype;
+  unsigned eltlen;
+  int length_pos, length_size, string_pos;
+  int char_size;
+  LONGEST val;
+  CORE_ADDR addr;
+
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
+	{
+	  elttype = check_typedef (TYPE_TARGET_TYPE (type));
+	  eltlen = TYPE_LENGTH (elttype);
+	  len = TYPE_LENGTH (type) / eltlen;
+	  if (prettyprint_arrays)
+	    {
+	      print_spaces_filtered (2 + 2 * recurse, stream);
+	    }
+	  /* For an array of chars, print with string syntax.  */
+	  if (eltlen == 1 &&
+	      ((TYPE_CODE (elttype) == TYPE_CODE_INT)
+	       || ((current_language->la_language == language_m2)
+		   && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
+	      && (format == 0 || format == 's'))
+	    {
+	      /* If requested, look for the first null char and only print
+	         elements up to it.  */
+	      if (stop_print_at_null)
+		{
+		  unsigned int temp_len;
+
+		  /* Look for a NULL char. */
+		  for (temp_len = 0;
+		       (valaddr + embedded_offset)[temp_len]
+		       && temp_len < len && temp_len < print_max;
+		       temp_len++);
+		  len = temp_len;
+		}
+
+	      LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
+	      i = len;
+	    }
+	  else
+	    {
+	      fprintf_filtered (stream, "{");
+	      val_print_array_elements (type, valaddr + embedded_offset, address, stream,
+				     format, deref_ref, recurse, pretty, 0);
+	      fprintf_filtered (stream, "}");
+	    }
+	  break;
+	}
+      /* Array of unspecified length: treat like pointer to first elt.  */
+      addr = address;
+      goto print_unpacked_pointer;
+
+    case TYPE_CODE_PTR:
+      if (format && format != 's')
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+      {
+	addr = unpack_pointer (type, valaddr + embedded_offset);
+	print_unpacked_pointer:
+	elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+	if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
+	  {
+	    /* Try to print what function it points to.  */
+	    print_function_pointer_address (addr, stream);
+	    /* Return value is irrelevant except for string pointers.  */
+	    return (0);
+	  }
+
+	if (addressprint && format != 's')
+	  {
+	    fputs_filtered (paddress (address), stream);
+	  }
+
+	/* For a pointer to char or unsigned char, also print the string
+	   pointed to, unless pointer is null.  */
+
+	if (TYPE_LENGTH (elttype) == 1
+	    && TYPE_CODE (elttype) == TYPE_CODE_INT
+	    && (format == 0 || format == 's')
+	    && addr != 0)
+	  {
+	    i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
+	  }
+
+	/* Return number of characters printed, including the terminating
+	   '\0' if we reached the end.  val_print_string takes care including
+	   the terminating '\0' if necessary.  */
+	return i;
+      }
+      break;
+
+    case TYPE_CODE_MEMBER:
+      error ("not implemented: member type in m2_val_print");
+      break;
+
+    case TYPE_CODE_REF:
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+      if (addressprint)
+	{
+	  CORE_ADDR addr
+	    = extract_typed_address (valaddr + embedded_offset, type);
+	  fprintf_filtered (stream, "@");
+	  fputs_filtered (paddress (addr), stream);
+	  if (deref_ref)
+	    fputs_filtered (": ", stream);
+	}
+      /* De-reference the reference.  */
+      if (deref_ref)
+	{
+	  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
+	    {
+	      struct value *deref_val =
+	      value_at
+	      (TYPE_TARGET_TYPE (type),
+	       unpack_pointer (lookup_pointer_type (builtin_type_void),
+			       valaddr + embedded_offset));
+	      common_val_print (deref_val, stream, format, deref_ref,
+				recurse, pretty);
+	    }
+	  else
+	    fputs_filtered ("???", stream);
+	}
+      break;
+
+    case TYPE_CODE_UNION:
+      if (recurse && !unionprint)
+	{
+	  fprintf_filtered (stream, "{...}");
+	  break;
+	}
+      /* Fall through.  */
+    case TYPE_CODE_STRUCT:
+      if (m2_is_long_set (type))
+	m2_print_long_set (type, valaddr, embedded_offset, address, stream, format,
+			   pretty);
+      else
+	cp_print_value_fields (type, type, valaddr, embedded_offset, address, stream, format,
+			       recurse, pretty, NULL, 0);
+      break;
+
+    case TYPE_CODE_ENUM:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      len = TYPE_NFIELDS (type);
+      val = unpack_long (type, valaddr + embedded_offset);
+      for (i = 0; i < len; i++)
+	{
+	  QUIT;
+	  if (val == TYPE_FIELD_BITPOS (type, i))
+	    {
+	      break;
+	    }
+	}
+      if (i < len)
+	{
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	}
+      else
+	{
+	  print_longest (stream, 'd', 0, val);
+	}
+      break;
+
+    case TYPE_CODE_FUNC:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      /* FIXME, we should consider, at least for ANSI C language, eliminating
+         the distinction made between FUNCs and POINTERs to FUNCs.  */
+      fprintf_filtered (stream, "{");
+      type_print (type, "", stream, -1);
+      fprintf_filtered (stream, "} ");
+      /* Try to print what function it points to, and its address.  */
+      print_address_demangle (address, stream, demangle);
+      break;
+
+    case TYPE_CODE_BOOL:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (val == 0)
+	    fputs_filtered ("FALSE", stream);
+	  else if (val == 1)
+	    fputs_filtered ("TRUE", stream);
+	  else
+	    fprintf_filtered (stream, "%ld)", (long int) val);
+	}
+      break;
+
+    case TYPE_CODE_RANGE:
+      if (TYPE_LENGTH (type) == TYPE_LENGTH (TYPE_TARGET_TYPE (type))) {
+	m2_val_print (TYPE_TARGET_TYPE (type), valaddr, embedded_offset,
+		      address, stream, format, deref_ref, recurse, pretty);
+	break;
+      }
+      /* FIXME: create_range_type does not set the unsigned bit in a
+         range type (I think it probably should copy it from the target
+         type), so we won't print values which are too large to
+         fit in a signed integer correctly.  */
+      /* FIXME: Doesn't handle ranges of enums correctly.  (Can't just
+         print with the target type, though, because the size of our type
+         and the target type might differ).  */
+      /* FALLTHROUGH */
+
+    case TYPE_CODE_INT:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val_print_type_code_int (type, valaddr + embedded_offset, stream);
+	}
+      break;
+
+    case TYPE_CODE_CHAR:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (TYPE_UNSIGNED (type))
+	    fprintf_filtered (stream, "%u", (unsigned int) val);
+	  else
+	    fprintf_filtered (stream, "%d", (int) val);
+	  fputs_filtered (" ", stream);
+	  LA_PRINT_CHAR ((unsigned char) val, stream);
+	}
+      break;
+
+    case TYPE_CODE_FLT:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  print_floating (valaddr + embedded_offset, type, stream);
+	}
+      break;
+
+    case TYPE_CODE_METHOD:
+      break;
+
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_SET:
+      elttype = TYPE_INDEX_TYPE (type);
+      CHECK_TYPEDEF (elttype);
+      if (TYPE_STUB (elttype))
+	{
+	  fprintf_filtered (stream, "<incomplete type>");
+	  gdb_flush (stream);
+	  break;
+	}
+      else
+	{
+	  struct type *range = elttype;
+	  LONGEST low_bound, high_bound;
+	  int i;
+	  int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
+	  int need_comma = 0;
+
+	  if (is_bitstring)
+	    fputs_filtered ("B'", stream);
+	  else
+	    fputs_filtered ("{", stream);
+
+	  i = get_discrete_bounds (range, &low_bound, &high_bound);
+	maybe_bad_bstring:
+	  if (i < 0)
+	    {
+	      fputs_filtered ("<error value>", stream);
+	      goto done;
+	    }
+
+	  for (i = low_bound; i <= high_bound; i++)
+	    {
+	      int element = value_bit_index (type, valaddr + embedded_offset, i);
+	      if (element < 0)
+		{
+		  i = element;
+		  goto maybe_bad_bstring;
+		}
+	      if (is_bitstring)
+		fprintf_filtered (stream, "%d", element);
+	      else if (element)
+		{
+		  if (need_comma)
+		    fputs_filtered (", ", stream);
+		  print_type_scalar (range, i, stream);
+		  need_comma = 1;
+
+		  if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))
+		    {
+		      int j = i;
+		      fputs_filtered ("..", stream);
+		      while (i + 1 <= high_bound
+			     && value_bit_index (type, valaddr + embedded_offset, ++i))
+			j = i;
+		      print_type_scalar (range, j, stream);
+		    }
+		}
+	    }
+	done:
+	  if (is_bitstring)
+	    fputs_filtered ("'", stream);
+	  else
+	    fputs_filtered ("}", stream);
+	}
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "void");
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, "<error type>");
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
+         dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
+         and no complete type for struct foo in that file.  */
+      fprintf_filtered (stream, "<incomplete type>");
+      break;
+
+    default:
+      error ("Invalid m2 type code %d in symbol table.", TYPE_CODE (type));
+    }
+  gdb_flush (stream);
+  return (0);
 }

Re: Enhanced language support for Modula-2

[Jim Blandy]

Hi, Gaius.  Thanks for the patch.

I went back and looked at Waldek's patch from last May, and as I said
in October, it still looks fine.  However, Waldek does not have
copyright assignment paperwork on file for changes to GDB, so we need
to get that process completed before we can put in his patch.

You, however, do have paperwork on file.  To avoid blocking your patch
on Waldek's paperwork, could you produce a version of your patch that
does not assume Waldek's patch is applied?

Re: Enhanced language support for Modula-2

[Eli Zaretskii]

> From: Gaius Mulley <gaius@glam.ac.uk>
> Date: 15 Feb 2006 23:14:32 +0000
> 
> Anyhow this patch provides better support for Modula-2 in the
> following areas:
> 
>   *  basic types are printed correctly when -gdwarf-2 is specified
>      on the gm2 command line.
>   *  set types are supported (type printing and value printing).
>      The patch correctly identifies:  SET OF CHAR, SET OF ['a'..'z']
>      etc.
>   *  long and short (word length) sets are supported.
>   *  range types are also identified and `ptype' prints them correctly.
>   *  automatic detection of Modula-2 generated executable is enabled.
>   *  VAR parameters are printed correctly
>   *  hexadecimal addresses are written using the Modula-2 syntax.
>   *  character constants are written using the octal syntax
>      (in the same way as PIM-[234].)

Thanks.

I think some of these changes might need updates in the user's manual.
Could you please look at the "Modula-2" section and its subsections,
and see if anything there should be added/removed/modified?

> +      error ("type not handled in m2_type_print_varspec_prefix()");

User messages should be in _(), to allow for translations into other
languages.

> +      fprintf_filtered(stream, "SET OF <unknown> ");

"SET OF" probably won't be translated, but "<unknown>" should, so this
message should be in _() as well.

Re: Enhanced language support for Modula-2

[Gaius Mulley]

Jim Blandy <jimb@red-bean.com> writes:

> Hi, Gaius.  Thanks for the patch.
> 
> I went back and looked at Waldek's patch from last May, and as I said
> in October, it still looks fine.  However, Waldek does not have
> copyright assignment paperwork on file for changes to GDB, so we need
> to get that process completed before we can put in his patch.
> 
> You, however, do have paperwork on file.  To avoid blocking your patch
> on Waldek's paperwork, could you produce a version of your patch that
> does not assume Waldek's patch is applied?

Hi,

certainly.. will do..

Gaius

Re: Enhanced language support for Modula-2

[Gaius Mulley]

Eli Zaretskii <eliz@gnu.org> writes:

> > From: Gaius Mulley <gaius@glam.ac.uk>
> > Date: 15 Feb 2006 23:14:32 +0000
> > 
> > Anyhow this patch provides better support for Modula-2 in the
> > following areas:
> > 
> >   *  basic types are printed correctly when -gdwarf-2 is specified
> >      on the gm2 command line.
> >   *  set types are supported (type printing and value printing).
> >      The patch correctly identifies:  SET OF CHAR, SET OF ['a'..'z']
> >      etc.
> >   *  long and short (word length) sets are supported.
> >   *  range types are also identified and `ptype' prints them correctly.
> >   *  automatic detection of Modula-2 generated executable is enabled.
> >   *  VAR parameters are printed correctly
> >   *  hexadecimal addresses are written using the Modula-2 syntax.
> >   *  character constants are written using the octal syntax
> >      (in the same way as PIM-[234].)
> 
> Thanks.
> 
> I think some of these changes might need updates in the user's manual.
> Could you please look at the "Modula-2" section and its subsections,
> and see if anything there should be added/removed/modified?

yes sure..

> > +      error ("type not handled in m2_type_print_varspec_prefix()");
> 
> User messages should be in _(), to allow for translations into other
> languages.

ok thanks for these pointers..

> > +      fprintf_filtered(stream, "SET OF <unknown> ");
> 
> "SET OF" probably won't be translated, but "<unknown>" should, so this
> message should be in _() as well.

true, I'll improve the patches and repost,

Gaius

Re: Enhanced language support for Modula-2

[Daniel Jacobowitz]

On Wed, Feb 15, 2006 at 04:19:56PM -0800, Jim Blandy wrote:
> Hi, Gaius.  Thanks for the patch.
> 
> I went back and looked at Waldek's patch from last May, and as I said
> in October, it still looks fine.  However, Waldek does not have
> copyright assignment paperwork on file for changes to GDB, so we need
> to get that process completed before we can put in his patch.
> 
> You, however, do have paperwork on file.  To avoid blocking your patch
> on Waldek's paperwork, could you produce a version of your patch that
> does not assume Waldek's patch is applied?

Hi Jim,

Do you think we need copyright paperwork for Waldek's patch?  I think
it's sufficiently trivial.

-- 
Daniel Jacobowitz
CodeSourcery

Re: Enhanced language support for Modula-2

[Jim Blandy]

On 2/20/06, Daniel Jacobowitz <drow@false.org> wrote:
> Do you think we need copyright paperwork for Waldek's patch?  I think
> it's sufficiently trivial.

Below is what I'm going by, from the Project GNU's 'maintain.texi'. 
It meets the size requirement, and while much of the patch is
repetitions of similar patterns nearby, read_set_type isn't a direct
tweake copy of anything.  I think it's borderline, which to me means
we need paperwork.

@node Legally Significant
@section Legally Significant Changes

If a person contributes more than around 15 lines of code and/or text
that is legally significant for copyright purposes, which means we
need copyright papers for it as described above.

A change of just a few lines (less than 15 or so) is not legally
significant for copyright.  A regular series of repeated changes, such
as renaming a symbol, is not legally significant even if the symbol
has to be renamed in many places.  Keep in mind, however, that a
series of minor changes by the same person can add up to a significant
contribution.  What counts is the total contribution of the person; it
is irrelevant which parts of it were contributed when.

Re: Enhanced language support for Modula-2

[Gaius Mulley]

Hi,

here is a reworking of my patch which includes a new version of the
set reading code in gdb/dwarf2read.c. Also contained is a patch to
gdb/doc/gdb.texinfo reflecting the enhancements to the Modula-2 mode.

regards,
Gaius


--- latest-cvs-gdb/src-cvs/gdb/m2-lang.h	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-lang.h	2006-02-15 10:49:54.000000000 +0000
@@ -27,6 +27,11 @@
 extern void m2_print_type (struct type *, char *, struct ui_file *, int,
 			   int);
 
+extern int m2_is_long_set (struct type *type);
+
 extern int m2_val_print (struct type *, const gdb_byte *, int, CORE_ADDR,
 			 struct ui_file *, int, int, int,
 			 enum val_prettyprint);
+
+extern int get_long_set_bounds (struct type *type, LONGEST *low,
+				LONGEST *high);
--- latest-cvs-gdb/src-cvs/gdb/m2-typeprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-typeprint.c	2006-02-16 12:08:56.000000000 +0000
@@ -1,5 +1,6 @@
 /* Support for printing Modula 2 types for GDB, the GNU debugger.
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    This file is part of GDB.
@@ -20,22 +21,794 @@
    Boston, MA 02110-1301, USA.  */
 
 #include "defs.h"
+#include "gdb_obstack.h"
 #include "bfd.h"		/* Binary File Description */
 #include "symtab.h"
 #include "gdbtypes.h"
 #include "expression.h"
 #include "value.h"
 #include "gdbcore.h"
-#include "target.h"
 #include "m2-lang.h"
+#include "target.h"
+#include "language.h"
+#include "demangle.h"
+#include "c-lang.h"
+#include "typeprint.h"
+#include "cp-abi.h"
+
+#include "gdb_string.h"
 #include <errno.h>
 
+static void m2_type_print_args (struct type *, struct ui_file *);
+
+void m2_type_print_varspec_prefix (struct type *, struct ui_file *, int,
+				   int);
+void m2_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
+				   int show, int passed_a_ptr, int demangled_args);
+
+
+void m2_type_print_base (struct type *type, struct ui_file *stream, int show,
+			 int level);
+
+static void m2_print_bounds (struct type *type,
+			     struct ui_file *stream, int show, int level,
+			     int print_high);
+
+/* Print "const", "volatile", or address space modifiers. */
+static void m2_type_print_modifier (struct type *, struct ui_file *,
+				   int, int);
+
 void
 m2_print_type (struct type *type, char *varstring, struct ui_file *stream,
-	       int show, int level)
+	      int show, int level)
+{
+  enum type_code code;
+  int demangled_args;
+
+  if (show > 0)
+    CHECK_TYPEDEF (type);
+
+  code = TYPE_CODE (type);
+
+  /*
+   *  is it a VAR parameter?
+   */
+  if (code == TYPE_CODE_REF)
+    fputs_filtered ("VAR", stream);
+
+  m2_type_print_varspec_prefix (type, stream, show, 0);
+  m2_type_print_varspec_suffix (type, stream, show, 0, 0);
+  m2_type_print_base (type, stream, show, level);
+}
+
+/* Print any asterisks or open-parentheses needed before the
+   variable name (to describe its type).
+
+   On outermost call, pass 0 for PASSED_A_PTR.
+   On outermost call, SHOW > 0 means should ignore
+   any typename for TYPE and show its details.
+   SHOW is always zero on recursive calls.  */
+
+void
+m2_type_print_varspec_prefix (struct type *type, struct ui_file *stream,
+			     int show, int passed_a_ptr)
+{
+  char *name;
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_PTR:
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_FUNC) {
+	m2_type_print_modifier (type, stream, 1, 0);
+	fprintf_filtered (stream, "POINTER TO ");
+	m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
+      }
+      break;
+
+    case TYPE_CODE_MEMBER:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, "(");
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      fprintf_filtered (stream, " ");
+      name = type_name_no_tag (TYPE_DOMAIN_TYPE (type));
+      if (name)
+	fputs_filtered (name, stream);
+      else
+	m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, 0, passed_a_ptr);
+      fprintf_filtered (stream, "::");
+      break;
+
+    case TYPE_CODE_METHOD:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, "(");
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      if (passed_a_ptr)
+	{
+	  fprintf_filtered (stream, " ");
+	  m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, 0, passed_a_ptr);
+	  fprintf_filtered (stream, "::");
+	}
+      break;
+
+    case TYPE_CODE_REF:
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
+      fprintf_filtered (stream, " ");
+      m2_type_print_modifier (type, stream, 1, 0);
+      break;
+
+    case TYPE_CODE_FUNC:
+      break;
+
+    case TYPE_CODE_ARRAY:
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_STRING:
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_TYPEDEF:
+    case TYPE_CODE_TEMPLATE:
+      /* These types need no prefix.  They are listed here so that
+         gcc -Wall will reveal any types that haven't been handled.  */
+      break;
+    default:
+      error (_("type not handled in m2_type_print_varspec_prefix()"));
+      break;
+    }
+}
+
+/* Print out "const" and "volatile" attributes.
+   TYPE is a pointer to the type being printed out.
+   STREAM is the output destination.
+   NEED_SPACE = 1 indicates an initial white space is needed */
+
+static void
+m2_type_print_modifier (struct type *type, struct ui_file *stream,
+		       int need_pre_space, int need_post_space)
+{
+  int did_print_modifier = 0;
+  const char *address_space_id;
+
+  /* We don't print `const' qualifiers for references --- since all
+     operators affect the thing referenced, not the reference itself,
+     every reference is `const'.  */
+  if (TYPE_CONST (type)
+      && TYPE_CODE (type) != TYPE_CODE_REF)
+    {
+      if (need_pre_space)
+	fprintf_filtered (stream, " ");
+      fprintf_filtered (stream, "const");
+      did_print_modifier = 1;
+    }
+
+  if (TYPE_VOLATILE (type))
+    {
+      if (did_print_modifier || need_pre_space)
+	fprintf_filtered (stream, " ");
+      fprintf_filtered (stream, "volatile");
+      did_print_modifier = 1;
+    }
+
+  address_space_id = address_space_int_to_name (TYPE_INSTANCE_FLAGS (type));
+  if (address_space_id)
+    {
+      if (did_print_modifier || need_pre_space)
+	fprintf_filtered (stream, " ");
+      fprintf_filtered (stream, "@%s", address_space_id);
+      did_print_modifier = 1;
+    }
+
+  if (did_print_modifier && need_post_space)
+    fprintf_filtered (stream, " ");
+}
+
+
+
+
+static void
+m2_type_print_args (struct type *type, struct ui_file *stream)
 {
-  extern void c_print_type (struct type *, char *, struct ui_file *, int,
-			    int);
+  int i;
+  struct field *args;
+
+  fprintf_filtered (stream, "(");
+  args = TYPE_FIELDS (type);
+  if (args != NULL)
+    {
+      int i;
+
+      /* FIXME drow/2002-05-31: Always skips the first argument,
+	 should we be checking for static members?  */
+
+      for (i = 1; i < TYPE_NFIELDS (type); i++)
+	{
+	  c_print_type (args[i].type, "", stream, -1, 0);
+	  if (i != TYPE_NFIELDS (type))
+	    {
+	      fprintf_filtered (stream, ",");
+	      wrap_here ("    ");
+	    }
+	}
+      if (TYPE_VARARGS (type))
+	fprintf_filtered (stream, "...");
+      else if (i == 1
+	       && (current_language->la_language == language_cplus))
+	fprintf_filtered (stream, "void");
+    }
+  else if (current_language->la_language == language_cplus)
+    {
+      fprintf_filtered (stream, "void");
+    }
+
+  fprintf_filtered (stream, ")");
+}
+
+
+
+
+/* Print any array sizes, function arguments or close parentheses
+   needed after the variable name (to describe its type).
+   Args work like m2_type_print_varspec_prefix.  */
+
+void
+m2_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
+			      int show, int passed_a_ptr, int demangled_args)
+{
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      fprintf_filtered (stream, "ARRAY [");
+      if (TYPE_LENGTH (type) >= 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0
+	  && TYPE_ARRAY_UPPER_BOUND_TYPE (type) != BOUND_CANNOT_BE_DETERMINED) {
+	if (TYPE_INDEX_TYPE (type) != 0) {
+	  m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 0);
+	  fprintf_filtered (stream, "..");
+	  m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 1);
+	}
+	else
+	  fprintf_filtered (stream, "%d",
+			    (TYPE_LENGTH (type)
+			     / TYPE_LENGTH (TYPE_TARGET_TYPE (type))));
+      }
+      fprintf_filtered (stream, "] OF ");
+
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      break;
+
+    case TYPE_CODE_MEMBER:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, ")");
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      break;
+
+    case TYPE_CODE_METHOD:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, ")");
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      if (passed_a_ptr)	{
+	m2_type_print_args (type, stream);
+      }
+      break;
+
+    case TYPE_CODE_PTR:
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_FUNC) {
+	fprintf_filtered (stream, "PROCEDURE");
+	break;
+      }
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
+      break;
+
+    case TYPE_CODE_REF:
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
+      break;
+
+    case TYPE_CODE_FUNC:
+      if (!demangled_args)
+	{
+	  int i, len = TYPE_NFIELDS (type);
+
+	  fprintf_filtered (stream, " (");
+	  for (i = 0; i < len; i++)
+	    {
+	      if (i > 0)
+		{
+		  fputs_filtered (", ", stream);
+		  wrap_here ("    ");
+		}
+	      m2_print_type (TYPE_FIELD_TYPE (type, i), "", stream, -1, 0);
+	    }
+	  fprintf_filtered (stream, ")");
+	}
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID) {
+	fprintf_filtered (stream, " : ");
+	m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
+				      passed_a_ptr, 0);
+      }
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_STRING:
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_TYPEDEF:
+    case TYPE_CODE_TEMPLATE:
+      /* These types do not need a suffix.  They are listed so that
+         gcc -Wall will report types that may not have been considered.  */
+      break;
+    default:
+      error (_("type not handled in m2_type_print_varspec_suffix()"));
+      break;
+    }
+}
+
+
+static void
+m2_print_bounds (struct type *type,
+		 struct ui_file *stream, int show, int level,
+		 int print_high)
+{
+  struct type *target = TYPE_TARGET_TYPE (type);
+
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (TYPE_NFIELDS(type) == 0)
+    return;
+
+  if (print_high)
+    print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+  else
+    print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+}
+
+static void
+m2_short_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  fprintf_filtered(stream, "SET [");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 0);
+
+  fprintf_filtered(stream, "..");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 1);
+  fprintf_filtered(stream, "]");
+}
+
+int
+m2_is_long_set (struct type *type)
+{
+  LONGEST previous_high = 0;  /* unnecessary initialization keeps gcc -Wall happy */
+  int len, i;
+  struct type *range;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+
+    /*
+     *  check if all fields of the RECORD are consecutive sets
+     */
+    len = TYPE_NFIELDS (type);
+    for (i = TYPE_N_BASECLASSES (type); i < len; i++) {
+      if (TYPE_FIELD_TYPE (type, i) == NULL)
+	return 0;
+      if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) != TYPE_CODE_SET)
+	return 0;
+      if (TYPE_FIELD_NAME (type, i) != NULL
+	  && (strcmp (TYPE_FIELD_NAME (type, i), "") != 0))
+	return 0;
+      range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+      if ((i > TYPE_N_BASECLASSES (type))
+	  && previous_high + 1 != TYPE_LOW_BOUND (range))
+	return 0;
+      previous_high = TYPE_HIGH_BOUND (range);
+    }
+    return len>0;
+  }
+  return 0;
+}
+
+/*
+ *  m2_get_discrete_bounds - a wrapper for get_discrete_bounds which
+ *                           understands that CHARs might be signed.
+ *                           This should be integrated into gdbtypes.c
+ *                           inside get_discrete_bounds.
+ */
+
+int
+m2_get_discrete_bounds (struct type *type, LONGEST *lowp, LONGEST *highp)
+{
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_CHAR:
+      if (TYPE_LENGTH (type) < sizeof (LONGEST)) {
+	if (!TYPE_UNSIGNED (type))
+	  {
+	    *lowp = -(1 << (TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1));
+	    *highp = -*lowp - 1;
+	    return 0;
+	  }
+      }
+      /* fall through */
+    default:
+      return get_discrete_bounds (type, lowp, highp);
+    }
+}
+
+/*
+ *  m2_is_long_set_of_type - returns TRUE if the long set was declared as SET OF <oftype>
+ *                           of_type is assigned to the subtype.
+ */
+
+int
+m2_is_long_set_of_type (struct type *type, struct type **of_type)
+{
+  int len, i;
+  struct type *range;
+  struct type *target;
+  LONGEST l1, l2;
+  LONGEST h1, h2;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+    target = TYPE_TARGET_TYPE (range);
+    if (target == NULL)
+      target = builtin_type_int;
+
+    l1 = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    h1 = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    *of_type = target;
+    if (m2_get_discrete_bounds (target, &l2, &h2) >= 0)
+      return (l1 == l2 && h1 == h2);
+    error (_("long_set failed to find discrete bounds for its subtype"));
+    return 0;
+  }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static int
+m2_long_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  struct type *index_type;
+  struct type *range_type;
+  struct type *of_type;
+  int i;
+  int len = TYPE_NFIELDS (type);
+  LONGEST low;
+  LONGEST high;
+
+  if (m2_is_long_set (type)) {
+    if (TYPE_TAG_NAME (type) != NULL) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+    else if (TYPE_NAME (type) != NULL) {
+      fputs_filtered (TYPE_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+
+    if (TYPE_TAG_NAME (type) != NULL || TYPE_NAME (type) != NULL)
+      fputs_filtered (" = ", stream);
+
+    if (get_long_set_bounds (type, &low, &high)) {
+      fprintf_filtered(stream, "SET OF ");
+      i = TYPE_N_BASECLASSES (type);
+      if (m2_is_long_set_of_type (type, &of_type))
+	m2_print_type (of_type, "", stream, show - 1, level);
+      else {
+	fprintf_filtered(stream, "[");
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)),
+			 stream, show - 1, level, 0);
+
+	fprintf_filtered(stream, "..");
+
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)),
+			 stream, show - 1, level, 1);
+	fprintf_filtered(stream, "]");
+      }
+    }
+    else
+      fprintf_filtered(stream, "SET OF %s", _("<unknown>"));
+
+    return 1;
+  }
+  return 0;
+}
+
+void
+m2_record_fields (struct type *type, struct ui_file *stream, int show,
+		  int level)
+{
+  /* Print the tag if it exists. 
+   */
+  if (TYPE_TAG_NAME (type) != NULL) {
+    if (strncmp (TYPE_TAG_NAME (type), "$$", 2) != 0) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show > 0)
+	fprintf_filtered (stream, " = ");
+    }
+  }
+  wrap_here ("    ");
+  if (show < 0)
+    {
+      if (TYPE_CODE (type) == DECLARED_TYPE_STRUCT)
+	fprintf_filtered (stream, "RECORD ... END ");
+      else if (TYPE_DECLARED_TYPE (type) == DECLARED_TYPE_UNION)
+	fprintf_filtered (stream, "CASE ... END ");
+    }
+  else if (show > 0)
+    {
+      if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
+	fprintf_filtered (stream, "RECORD\n");
+      else if (TYPE_CODE (type) == TYPE_CODE_UNION)
+	fprintf_filtered (stream, "CASE %s OF\n", _("<variant>"));
+      int i;
+      int len = TYPE_NFIELDS (type);
+
+      for (i = TYPE_N_BASECLASSES (type); i < len; i++)
+	{
+	  QUIT;
+
+	  print_spaces_filtered (level + 4, stream);
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	  fputs_filtered (" : ", stream);
+	  m2_print_type (TYPE_FIELD_TYPE (type, i),
+			 "",
+			 stream, 0, level + 4);
+	  if (TYPE_FIELD_PACKED (type, i))
+	    {
+	      /* It is a bitfield.  This code does not attempt
+		 to look at the bitpos and reconstruct filler,
+		 unnamed fields.  This would lead to misleading
+		 results if the compiler does not put out fields
+		 for such things (I don't know what it does).  */
+	      fprintf_filtered (stream, " : %d",
+				TYPE_FIELD_BITSIZE (type, i));
+	    }
+	  fprintf_filtered (stream, ";\n");
+	}
+      
+      fprintfi_filtered (level, stream, "END ");
+    }
+}
+
+/* Print the name of the type (or the ultimate pointer target,
+   function value or array element), or the description of a
+   structure or union.
+
+   SHOW positive means print details about the type (e.g. enum values),
+   and print structure elements passing SHOW - 1 for show.
+   SHOW negative means just print the type name or struct tag if there is one.
+   If there is no name, print something sensible but concise like
+   "struct {...}".
+   SHOW zero means just print the type name or struct tag if there is one.
+   If there is no name, print something sensible but not as concise like
+   "struct {int x; int y;}".
+
+   LEVEL is the number of spaces to indent by.
+   We increase it for some recursive calls.  */
+
+void
+m2_type_print_base (struct type *type, struct ui_file *stream, int show,
+		    int level)
+{
+  int i;
+  int len, real_len;
+  int lastval;
+  char *mangled_name;
+  char *demangled_name;
+  char *demangled_no_static;
+  enum
+    {
+      s_none, s_public, s_private, s_protected
+    }
+  section_type;
+  int need_access_label = 0;
+  int j, len2;
+
+  QUIT;
+
+  wrap_here ("    ");
+  if (type == NULL)
+    {
+      fputs_filtered (_("<type unknown>"), stream);
+      return;
+    }
+
+  /* When SHOW is zero or less, and there is a valid type name, then always
+     just print the type name directly from the type.  */
+  /* If we have "typedef struct foo {. . .} bar;" do we want to print it
+     as "struct foo" or as "bar"?  Pick the latter, because C++ folk tend
+     to expect things like "class5 *foo" rather than "struct class5 *foo".  */
+
+  if (show <= 0
+      && TYPE_NAME (type) != NULL)
+    {
+      m2_type_print_modifier (type, stream, 0, 1);
+      fputs_filtered (TYPE_NAME (type), stream);
+      return;
+    }
+
+  CHECK_TYPEDEF (type);
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_TYPEDEF:
+    case TYPE_CODE_ARRAY:
+    case TYPE_CODE_PTR:
+    case TYPE_CODE_MEMBER:
+    case TYPE_CODE_REF:
+    case TYPE_CODE_METHOD:
+      m2_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
+      break;
+
+    case TYPE_CODE_FUNC:
+      break;
+
+    case TYPE_CODE_SET:
+      m2_short_set(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_STRUCT:
+      if (m2_long_set (type, stream, show, level))
+	break;
+      m2_type_print_modifier (type, stream, 0, 1);
+      m2_record_fields(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_UNION:
+      m2_type_print_modifier (type, stream, 0, 1);
+      m2_record_fields(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_ENUM:
+      m2_type_print_modifier (type, stream, 0, 1);
+      /* HP C supports sized enums */
+      if (deprecated_hp_som_som_object_present)
+	switch (TYPE_LENGTH (type))
+	  {
+	  case 1:
+	    fputs_filtered ("char ", stream);
+	    break;
+	  case 2:
+	    fputs_filtered ("short ", stream);
+	    break;
+	  default:
+	    break;
+	  }
+      /* Print the tag name if it exists.
+         The aCC compiler emits a spurious 
+         "{unnamed struct}"/"{unnamed union}"/"{unnamed enum}"
+         tag for unnamed struct/union/enum's, which we don't
+         want to print. */
+      if (TYPE_TAG_NAME (type) != NULL &&
+	  strncmp (TYPE_TAG_NAME (type), "{unnamed", 8))
+	{
+	  fputs_filtered (TYPE_TAG_NAME (type), stream);
+	  if (show > 0)
+	    fputs_filtered (" ", stream);
+	}
+
+      wrap_here ("    ");
+      if (show < 0)
+	{
+	  /* If we just printed a tag name, no need to print anything else.  */
+	  if (TYPE_TAG_NAME (type) == NULL)
+	    fprintf_filtered (stream, "(...)");
+	}
+      else if (show > 0 || TYPE_TAG_NAME (type) == NULL)
+	{
+	  fprintf_filtered (stream, "(");
+	  len = TYPE_NFIELDS (type);
+	  lastval = 0;
+	  for (i = 0; i < len; i++)
+	    {
+	      QUIT;
+	      if (i)
+		fprintf_filtered (stream, ", ");
+	      wrap_here ("    ");
+	      fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	      if (lastval != TYPE_FIELD_BITPOS (type, i))
+		{
+		  fprintf_filtered (stream, " = %d", TYPE_FIELD_BITPOS (type, i));
+		  lastval = TYPE_FIELD_BITPOS (type, i);
+		}
+	      lastval++;
+	    }
+	  fprintf_filtered (stream, ")");
+	}
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "void");
+      break;
+
+    case TYPE_CODE_UNDEF:
+      fprintf_filtered (stream, "struct %s", _("<unknown>"));
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, _("<unknown type>"));
+      break;
+
+    case TYPE_CODE_RANGE:
+      if (TYPE_HIGH_BOUND (type) == TYPE_LOW_BOUND (type))
+	m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, show, level);
+      else {
+	struct type *target = TYPE_TARGET_TYPE (type);
+
+	fprintf_filtered (stream, "[");
+	print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+	fprintf_filtered (stream, "..");
+	print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+	fprintf_filtered (stream, "]");
+      }
+      break;
+
+    case TYPE_CODE_TEMPLATE:
+      break;
 
-  c_print_type (type, varstring, stream, show, level);	/* FIXME */
+    default:
+      /* Handle types not explicitly handled by the other cases,
+         such as fundamental types.  For these, just print whatever
+         the type name is, as recorded in the type itself.  If there
+         is no type name, then complain. */
+      if (TYPE_NAME (type) != NULL)
+	{
+	  m2_type_print_modifier (type, stream, 0, 1);
+	  fputs_filtered (TYPE_NAME (type), stream);
+	}
+      else
+	{
+	  /* At least for dump_symtab, it is important that this not be
+	     an error ().  */
+	  fprintf_filtered (stream, "<%s %d>",
+			    _("invalid type code"), TYPE_CODE (type));
+	}
+      break;
+    }
 }
--- latest-cvs-gdb/src-cvs/gdb/dwarf2read.c	2006-02-09 18:18:41.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/dwarf2read.c	2006-02-21 10:14:09.000000000 +0000
@@ -1,7 +1,7 @@
 /* DWARF 2 debugging format support for GDB.
 
-   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-   2004, 2005, 2006
+   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    Adapted by Gary Funck (gary@intrepid.com), Intrepid Technology,
@@ -1073,6 +1073,9 @@
 
 static void dwarf2_clear_marks (struct dwarf2_per_cu_data *);
 
+static void read_set_type (struct die_info *, struct dwarf2_cu *);
+
+
 /* Try to locate the sections we need for DWARF 2 debugging
    information and return true if we have enough to do something.  */
 
@@ -2662,6 +2665,9 @@
     case DW_TAG_subroutine_type:
       read_subroutine_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
@@ -4240,6 +4246,15 @@
     };
 }
 
+/* Extract all information from a DW_TAG_set_type DIE and put it in
+   the DIE's type field. */
+
+static void
+read_set_type (struct die_info *die, struct dwarf2_cu *cu)
+{
+  if (die->type == NULL)
+    die->type = create_set_type ((struct type *) NULL, die_type (die, cu));
+}
 
 /* First cut: install each common block member as a global variable.  */
 
@@ -4728,10 +4743,15 @@
 	  code = TYPE_CODE_FLT;
 	  break;
 	case DW_ATE_signed:
-	case DW_ATE_signed_char:
 	  break;
 	case DW_ATE_unsigned:
-	case DW_ATE_unsigned_char:
+	  type_flags |= TYPE_FLAG_UNSIGNED;
+	  break;
+	case DW_ATE_signed_char:
+	  code = TYPE_CODE_CHAR;
+	  break;
+ 	case DW_ATE_unsigned_char:
+	  code = TYPE_CODE_CHAR;
 	  type_flags |= TYPE_FLAG_UNSIGNED;
 	  break;
 	default:
@@ -6146,6 +6166,10 @@
 {
   switch (lang)
     {
+    case DW_LANG_Ada83:
+    case DW_LANG_Ada95:
+      cu->language = language_ada;
+      break;
     case DW_LANG_C89:
     case DW_LANG_C:
       cu->language = language_c;
@@ -6153,25 +6177,29 @@
     case DW_LANG_C_plus_plus:
       cu->language = language_cplus;
       break;
+    case DW_LANG_Cobol74:
+      cu->language = DW_LANG_Cobol74;
+      break;
+    case DW_LANG_Cobol85:
+      cu->language = DW_LANG_Cobol85;
+      break;
     case DW_LANG_Fortran77:
     case DW_LANG_Fortran90:
     case DW_LANG_Fortran95:
       cu->language = language_fortran;
       break;
-    case DW_LANG_Mips_Assembler:
-      cu->language = language_asm;
-      break;
     case DW_LANG_Java:
       cu->language = language_java;
       break;
-    case DW_LANG_Ada83:
-    case DW_LANG_Ada95:
-      cu->language = language_ada;
+    case DW_LANG_Mips_Assembler:
+      cu->language = language_asm;
       break;
-    case DW_LANG_Cobol74:
-    case DW_LANG_Cobol85:
-    case DW_LANG_Pascal83:
     case DW_LANG_Modula2:
+      cu->language = language_m2;
+      break;
+    case DW_LANG_Pascal83:
+      cu->language = language_pascal;
+      break;
     default:
       cu->language = language_minimal;
       break;
@@ -6958,6 +6986,7 @@
 	case DW_TAG_class_type:
 	case DW_TAG_structure_type:
 	case DW_TAG_union_type:
+	case DW_TAG_set_type:
 	case DW_TAG_enumeration_type:
 	  SYMBOL_CLASS (sym) = LOC_TYPEDEF;
 	  SYMBOL_DOMAIN (sym) = STRUCT_DOMAIN;
@@ -7287,6 +7316,9 @@
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_pointer_type:
       read_tag_pointer_type (die, cu);
       break;
@@ -7337,7 +7369,8 @@
   struct die_info *parent;
 
   if (cu->language != language_cplus
-      && cu->language != language_java)
+      && cu->language != language_java
+      && cu->language != language_pascal)
     return NULL;
 
   parent = die->parent;
--- latest-cvs-gdb/src-cvs/gdb/m2-valprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-valprint.c	2006-02-16 11:48:39.000000000 +0000
@@ -1,7 +1,8 @@
 /* Support for printing Modula 2 values for GDB, the GNU debugger.
 
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998, 2000, 2005 Free
-   Software Foundation, Inc.
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998,
+                 2000, 2005, 2006
+   Free Software Foundation, Inc.
 
    This file is part of GDB.
 
@@ -23,14 +24,513 @@
 #include "defs.h"
 #include "symtab.h"
 #include "gdbtypes.h"
-#include "m2-lang.h"
+#include "expression.h"
+#include "value.h"
+#include "valprint.h"
+#include "language.h"
+#include "typeprint.h"
 #include "c-lang.h"
+#include "m2-lang.h"
+#include "target.h"
+
+
+/* Print function pointer with inferior address ADDRESS onto stdio
+   stream STREAM.  */
+
+static void
+print_function_pointer_address (CORE_ADDR address, struct ui_file *stream)
+{
+  CORE_ADDR func_addr = gdbarch_convert_from_func_ptr_addr (current_gdbarch,
+							    address,
+							    &current_target);
+
+  /* If the function pointer is represented by a description, print the
+     address of the description.  */
+  if (addressprint && func_addr != address)
+    {
+      fputs_filtered ("@", stream);
+      fputs_filtered (paddress (address), stream);
+      fputs_filtered (": ", stream);
+    }
+  print_address_demangle (func_addr, stream, demangle);
+}
+
+/*
+ *  get_long_set_bounds - assigns the bounds of the long set to low and high.
+ */
+
+int
+get_long_set_bounds (struct type *type, LONGEST *low, LONGEST *high)
+{
+  int len, i;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    *low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    *high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    return 1;
+  }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static void
+m2_print_long_set (struct type *type, const gdb_byte *valaddr, int embedded_offset,
+		   CORE_ADDR address, struct ui_file *stream, int format,
+		   enum val_prettyprint pretty)
+{
+  int empty_set        = 1;
+  int element_seen     = 0;
+  LONGEST previous_low = 0;
+  LONGEST previous_high= 0;
+  LONGEST i, low_bound, high_bound;
+  LONGEST field_low, field_high;
+  struct type *range;
+  int len, field;
+  struct type *target;
+  int bitval;
+
+  CHECK_TYPEDEF (type);
+
+  fprintf_filtered (stream, "{");
+  len = TYPE_NFIELDS (type);
+  if (get_long_set_bounds (type, &low_bound, &high_bound)) {
+    field = TYPE_N_BASECLASSES (type);
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+  }
+  else {
+    fprintf_filtered (stream, " %s }", _("<unknown bounds of set>"));
+    return;
+  }
+
+  target = TYPE_TARGET_TYPE (range);
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (get_discrete_bounds (range, &field_low, &field_high) >= 0) {
+    for (i = low_bound; i <= high_bound; i++) {
+      bitval = value_bit_index (TYPE_FIELD_TYPE (type, field),
+				(TYPE_FIELD_BITPOS (type, field) / 8) +
+				valaddr + embedded_offset, i);
+      if (bitval < 0)
+	error (_("bit test is out of range"));
+      else if (bitval > 0) {
+	previous_high = i;
+	if (! element_seen) {
+	  if (! empty_set)
+	    fprintf_filtered (stream, ", ");
+	  print_type_scalar (target, i, stream);
+	  empty_set    = 0;
+	  element_seen = 1;
+	  previous_low = i;
+	}
+      }
+      else {
+	/* bit is not set */
+	if (element_seen) {
+	  if (previous_low+1 < previous_high)
+	    fprintf_filtered (stream, "..");
+	  if (previous_low+1 < previous_high)
+	    print_type_scalar (target, previous_high, stream);
+	  element_seen = 0;
+	}
+      }
+      if (i == field_high) {
+	field++;
+	if (field == len)
+	  break;
+	range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+	if (get_discrete_bounds (range, &field_low, &field_high) < 0)
+	  break;
+	target = TYPE_TARGET_TYPE (range);
+	if (target == NULL)
+	  target = builtin_type_int;
+      }
+    }
+    if (element_seen) {
+      if (previous_low+1 < previous_high) {
+	fprintf_filtered (stream, "..");
+	print_type_scalar (target, previous_high, stream);
+      }
+      element_seen = 0;
+    }
+    fprintf_filtered (stream, "}");
+  }
+}
+
+/* Print data of type TYPE located at VALADDR (within GDB), which came from
+   the inferior at address ADDRESS, onto stdio stream STREAM according to
+   FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
+   target byte order.
+
+   If the data are a string pointer, returns the number of string characters
+   printed.
+
+   If DEREF_REF is nonzero, then dereference references, otherwise just print
+   them like pointers.
+
+   The PRETTY parameter controls prettyprinting.  */
 
 int
 m2_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 	      CORE_ADDR address, struct ui_file *stream, int format,
 	      int deref_ref, int recurse, enum val_prettyprint pretty)
 {
-  return (c_val_print (type, valaddr, 0, address, stream, format, deref_ref,
-		       recurse, pretty));
+  unsigned int i = 0;	/* Number of characters printed */
+  unsigned len;
+  struct type *elttype;
+  unsigned eltlen;
+  int length_pos, length_size, string_pos;
+  int char_size;
+  LONGEST val;
+  CORE_ADDR addr;
+
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
+	{
+	  elttype = check_typedef (TYPE_TARGET_TYPE (type));
+	  eltlen = TYPE_LENGTH (elttype);
+	  len = TYPE_LENGTH (type) / eltlen;
+	  if (prettyprint_arrays)
+	    {
+	      print_spaces_filtered (2 + 2 * recurse, stream);
+	    }
+	  /* For an array of chars, print with string syntax.  */
+	  if (eltlen == 1 &&
+	      ((TYPE_CODE (elttype) == TYPE_CODE_INT)
+	       || ((current_language->la_language == language_m2)
+		   && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
+	      && (format == 0 || format == 's'))
+	    {
+	      /* If requested, look for the first null char and only print
+	         elements up to it.  */
+	      if (stop_print_at_null)
+		{
+		  unsigned int temp_len;
+
+		  /* Look for a NULL char. */
+		  for (temp_len = 0;
+		       (valaddr + embedded_offset)[temp_len]
+		       && temp_len < len && temp_len < print_max;
+		       temp_len++);
+		  len = temp_len;
+		}
+
+	      LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
+	      i = len;
+	    }
+	  else
+	    {
+	      fprintf_filtered (stream, "{");
+	      val_print_array_elements (type, valaddr + embedded_offset, address, stream,
+				     format, deref_ref, recurse, pretty, 0);
+	      fprintf_filtered (stream, "}");
+	    }
+	  break;
+	}
+      /* Array of unspecified length: treat like pointer to first elt.  */
+      addr = address;
+      goto print_unpacked_pointer;
+
+    case TYPE_CODE_PTR:
+      if (format && format != 's')
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+      {
+	addr = unpack_pointer (type, valaddr + embedded_offset);
+	print_unpacked_pointer:
+	elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+	if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
+	  {
+	    /* Try to print what function it points to.  */
+	    print_function_pointer_address (addr, stream);
+	    /* Return value is irrelevant except for string pointers.  */
+	    return (0);
+	  }
+
+	if (addressprint && format != 's')
+	  {
+	    fputs_filtered (paddress (address), stream);
+	  }
+
+	/* For a pointer to char or unsigned char, also print the string
+	   pointed to, unless pointer is null.  */
+
+	if (TYPE_LENGTH (elttype) == 1
+	    && TYPE_CODE (elttype) == TYPE_CODE_INT
+	    && (format == 0 || format == 's')
+	    && addr != 0)
+	  {
+	    i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
+	  }
+
+	/* Return number of characters printed, including the terminating
+	   '\0' if we reached the end.  val_print_string takes care including
+	   the terminating '\0' if necessary.  */
+	return i;
+      }
+      break;
+
+    case TYPE_CODE_MEMBER:
+      error (_("not implemented: member type in m2_val_print"));
+      break;
+
+    case TYPE_CODE_REF:
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+      if (addressprint)
+	{
+	  CORE_ADDR addr
+	    = extract_typed_address (valaddr + embedded_offset, type);
+	  fprintf_filtered (stream, "@");
+	  fputs_filtered (paddress (addr), stream);
+	  if (deref_ref)
+	    fputs_filtered (": ", stream);
+	}
+      /* De-reference the reference.  */
+      if (deref_ref)
+	{
+	  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
+	    {
+	      struct value *deref_val =
+	      value_at
+	      (TYPE_TARGET_TYPE (type),
+	       unpack_pointer (lookup_pointer_type (builtin_type_void),
+			       valaddr + embedded_offset));
+	      common_val_print (deref_val, stream, format, deref_ref,
+				recurse, pretty);
+	    }
+	  else
+	    fputs_filtered ("???", stream);
+	}
+      break;
+
+    case TYPE_CODE_UNION:
+      if (recurse && !unionprint)
+	{
+	  fprintf_filtered (stream, "{...}");
+	  break;
+	}
+      /* Fall through.  */
+    case TYPE_CODE_STRUCT:
+      if (m2_is_long_set (type))
+	m2_print_long_set (type, valaddr, embedded_offset, address, stream, format,
+			   pretty);
+      else
+	cp_print_value_fields (type, type, valaddr, embedded_offset, address, stream, format,
+			       recurse, pretty, NULL, 0);
+      break;
+
+    case TYPE_CODE_ENUM:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      len = TYPE_NFIELDS (type);
+      val = unpack_long (type, valaddr + embedded_offset);
+      for (i = 0; i < len; i++)
+	{
+	  QUIT;
+	  if (val == TYPE_FIELD_BITPOS (type, i))
+	    {
+	      break;
+	    }
+	}
+      if (i < len)
+	{
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	}
+      else
+	{
+	  print_longest (stream, 'd', 0, val);
+	}
+      break;
+
+    case TYPE_CODE_FUNC:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      /* FIXME, we should consider, at least for ANSI C language, eliminating
+         the distinction made between FUNCs and POINTERs to FUNCs.  */
+      fprintf_filtered (stream, "{");
+      type_print (type, "", stream, -1);
+      fprintf_filtered (stream, "} ");
+      /* Try to print what function it points to, and its address.  */
+      print_address_demangle (address, stream, demangle);
+      break;
+
+    case TYPE_CODE_BOOL:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (val == 0)
+	    fputs_filtered ("FALSE", stream);
+	  else if (val == 1)
+	    fputs_filtered ("TRUE", stream);
+	  else
+	    fprintf_filtered (stream, "%ld)", (long int) val);
+	}
+      break;
+
+    case TYPE_CODE_RANGE:
+      if (TYPE_LENGTH (type) == TYPE_LENGTH (TYPE_TARGET_TYPE (type))) {
+	m2_val_print (TYPE_TARGET_TYPE (type), valaddr, embedded_offset,
+		      address, stream, format, deref_ref, recurse, pretty);
+	break;
+      }
+      /* FIXME: create_range_type does not set the unsigned bit in a
+         range type (I think it probably should copy it from the target
+         type), so we won't print values which are too large to
+         fit in a signed integer correctly.  */
+      /* FIXME: Doesn't handle ranges of enums correctly.  (Can't just
+         print with the target type, though, because the size of our type
+         and the target type might differ).  */
+      /* FALLTHROUGH */
+
+    case TYPE_CODE_INT:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val_print_type_code_int (type, valaddr + embedded_offset, stream);
+	}
+      break;
+
+    case TYPE_CODE_CHAR:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (TYPE_UNSIGNED (type))
+	    fprintf_filtered (stream, "%u", (unsigned int) val);
+	  else
+	    fprintf_filtered (stream, "%d", (int) val);
+	  fputs_filtered (" ", stream);
+	  LA_PRINT_CHAR ((unsigned char) val, stream);
+	}
+      break;
+
+    case TYPE_CODE_FLT:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  print_floating (valaddr + embedded_offset, type, stream);
+	}
+      break;
+
+    case TYPE_CODE_METHOD:
+      break;
+
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_SET:
+      elttype = TYPE_INDEX_TYPE (type);
+      CHECK_TYPEDEF (elttype);
+      if (TYPE_STUB (elttype))
+	{
+	  fprintf_filtered (stream, _("<incomplete type>"));
+	  gdb_flush (stream);
+	  break;
+	}
+      else
+	{
+	  struct type *range = elttype;
+	  LONGEST low_bound, high_bound;
+	  int i;
+	  int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
+	  int need_comma = 0;
+
+	  if (is_bitstring)
+	    fputs_filtered ("B'", stream);
+	  else
+	    fputs_filtered ("{", stream);
+
+	  i = get_discrete_bounds (range, &low_bound, &high_bound);
+	maybe_bad_bstring:
+	  if (i < 0)
+	    {
+	      fputs_filtered (_("<error value>"), stream);
+	      goto done;
+	    }
+
+	  for (i = low_bound; i <= high_bound; i++)
+	    {
+	      int element = value_bit_index (type, valaddr + embedded_offset, i);
+	      if (element < 0)
+		{
+		  i = element;
+		  goto maybe_bad_bstring;
+		}
+	      if (is_bitstring)
+		fprintf_filtered (stream, "%d", element);
+	      else if (element)
+		{
+		  if (need_comma)
+		    fputs_filtered (", ", stream);
+		  print_type_scalar (range, i, stream);
+		  need_comma = 1;
+
+		  if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))
+		    {
+		      int j = i;
+		      fputs_filtered ("..", stream);
+		      while (i + 1 <= high_bound
+			     && value_bit_index (type, valaddr + embedded_offset, ++i))
+			j = i;
+		      print_type_scalar (range, j, stream);
+		    }
+		}
+	    }
+	done:
+	  if (is_bitstring)
+	    fputs_filtered ("'", stream);
+	  else
+	    fputs_filtered ("}", stream);
+	}
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "void");
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, _("<error type>"));
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
+         dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
+         and no complete type for struct foo in that file.  */
+      fprintf_filtered (stream, _("<incomplete type>"));
+      break;
+
+    default:
+      error (_("Invalid m2 type code %d in symbol table."), TYPE_CODE (type));
+    }
+  gdb_flush (stream);
+  return (0);
 }
--- latest-cvs-gdb/src-cvs/gdb/doc/gdb.texinfo	2006-02-10 03:54:33.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/doc/gdb.texinfo	2006-02-21 10:10:41.000000000 +0000
@@ -1,6 +1,6 @@
 \input texinfo      @c -*-texinfo-*-
 @c Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1998,
-@c 1999, 2000, 2001, 2002, 2003, 2004, 2005
+@c 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006
 @c Free Software Foundation, Inc.
 @c
 @c %**start of header
@@ -9459,6 +9459,7 @@
 * M2 Operators::                Built-in operators
 * Built-In Func/Proc::          Built-in functions and procedures
 * M2 Constants::                Modula-2 constants
+* M2 Types::                    Modula-2 types
 * M2 Defaults::                 Default settings for Modula-2
 * Deviations::                  Deviations from standard Modula-2
 * M2 Checks::                   Modula-2 type and range checks
@@ -9583,7 +9584,7 @@
 @end table
 
 @quotation
-@emph{Warning:} Sets and their operations are not yet supported, so @value{GDBN}
+@emph{Warning:} Set expressions and their operations are not yet supported, so @value{GDBN}
 treats the use of the operator @code{IN}, or the use of operators
 @code{+}, @code{-}, @code{*}, @code{/}, @code{=}, , @code{<>}, @code{#},
 @code{<=}, and @code{>=} on sets as an error.
@@ -9752,6 +9753,161 @@
 Set constants are not yet supported.
 @end itemize
 
+@cindex Modula-2 types
+@node M2 Types
+@subsubsection Types
+
+Currently @value{GDBN} can print the following data types in Modula-2
+syntax: array types, record types, set types, pointer types,
+procedure types, enumerated types, subrange types and base types.
+Values of these types may also be printed. So for example, if the
+following section of code were compiled,
+
+@example
+VAR
+   s: SET OF CHAR ;
+   r: [20..40] ;
+@end example
+
+@value{GDBN} could be requested to interrogate the type and value of
+@code{r} and @code{s}.
+
+@example
+(gdb) print s
+@{'A'..'C', 'Z'@}
+(gdb) ptype s
+SET OF CHAR
+(gdb) print r
+21
+(gdb) ptype r
+[20..40]
+@end example
+
+Likewise if the source code declared @code{s} as:
+
+@example
+VAR
+   s: SET ['A'..'Z'] ;
+@end example
+
+the user can query the type of @code{s} via:
+
+@example
+(gdb) ptype s
+type = SET ['A'..'Z']
+@end example
+
+Note that at present @value{GDBN} does not support interactive
+manipulation of set expressions. However the debugger does understand
+the declaration of Modula-2 arrays. For example in this code fragment
+the declaration of @code{s} is described.
+
+@example
+VAR
+   s: ARRAY [-10..10] OF CHAR ;
+@end example
+
+and this information is now seen by @value{GDBN}
+
+@example
+(gdb) ptype s
+ARRAY [-10..10] OF CHAR
+@end example
+
+It is advisable to use the following compile flags on the @code{gm2}
+command line @code{-g -gdwarf-2}. Also note that the array handling is
+not yet complete and although the type is printed correctly, the
+expression handling still assumes that all arrays have a lower bound
+of zero and not @code{-10} in the case above. Unbounded arrays are
+also not yet recognised in @value{GDBN}.  Here follows some more type
+related Modula-2 examples:
+
+@example
+TYPE
+   colour = (blue, red, yellow, green) ;
+   t = [blue..yellow] ;
+VAR
+   s: t ;
+BEGIN
+   s := blue ;
+@end example
+
+The @value{GDBN} interaction shows that the correct value and type
+can be obtained.
+
+@example
+(gdb) print s
+$1 = blue
+(gdb) ptype t
+type = [blue..yellow]
+@end example
+
+In this example a Modula-2 array is declared and its contents
+displayed. Observe that the contents are written in the same
+way as their @code{C} counterparts.
+
+@example
+VAR
+   s: ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   s[1] := 1 ;
+@end example
+
+@example
+(gdb) print s
+$1 = @{1, 0, 0, 0, 0@}
+(gdb) ptype s
+type = ARRAY [1..5] OF CARDINAL
+@end example
+
+The Modula-2 language interface to @value{GDBN} also understands
+pointer types as shown in this example:
+
+@example
+VAR
+   s: POINTER TO ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   NEW(s) ;
+   s^[1] := 1 ;
+@end example
+
+and @value{GDBN} can be requested to describe the type of @code{s}.
+
+@example
+(gdb) ptype s
+type = POINTER TO ARRAY [1..5] OF CARDINAL
+@end example
+
+More complex types are also handled by @value{GDBN}, in this example
+we combine array types, record types, pointer types and subrange
+types.
+
+@example
+TYPE
+   foo = RECORD
+            f1: CARDINAL ;
+            f2: CHAR ;
+            f3: myarray ;
+         END ;
+
+   myarray = ARRAY myrange OF CARDINAL ;
+   myrange = [-2..2] ;
+VAR
+   s: POINTER TO ARRAY myrange OF foo ;
+@end example
+
+Once again the user requests that @value{GDBN} describes the type of
+@code{s}.
+
+@example
+(gdb) ptype s
+type = POINTER TO ARRAY [-2..2] OF foo = RECORD
+    f1 : CARDINAL;
+    f2 : CHAR;
+    f3 : ARRAY [-2..2] OF CARDINAL;
+END 
+@end example
+
 @node M2 Defaults
 @subsubsection Modula-2 defaults
 @cindex Modula-2 defaults

Re: Enhanced language support for Modula-2

[Jim Blandy]

On 21 Feb 2006 10:24:46 +0000, Gaius Mulley <gaius@glam.ac.uk> wrote:
> here is a reworking of my patch which includes a new version of the
> set reading code in gdb/dwarf2read.c. Also contained is a patch to
> gdb/doc/gdb.texinfo reflecting the enhancements to the Modula-2 mode.

Okay.  That solves that problem.  :)

I'm a little concerned about the change to dwarf2read.c where you
create a TYPE_CODE_CHAR type for DW_ATE_signed_char and
DW_ATE_unsigned_char.  GDB uses TYPE_CODE_INT for C 'char' types.  I
have vague memories of something going wrong with printing or
evaluation or something if you actually use TYPE_CODE_CHAR, and after
discussion deciding to stick with TYPE_CODE_INT.

But this patch causes no test suite regressions?

Re: Enhanced language support for Modula-2

[Jim Blandy]

On 21 Feb 2006 10:24:46 +0000, Gaius Mulley <gaius@glam.ac.uk> wrote:
> +Currently @value{GDBN} can print the following data types in Modula-2
> +syntax: array types, record types, set types, pointer types,
> +procedure types, enumerated types, subrange types and base types.
> +Values of these types may also be printed. So for example, if the
> +following section of code were compiled,

This is Eli's call, but it's general practice in GNU documentation to
go ahead and use "you" in preference to the passive voice.  I don't
have a reference for this rule, I just have memories of Stallman
correcting this in my own writing.  So the text above could be:

   So for example, if you compile the following section of code:

> +@value{GDBN} could be requested to interrogate the type and value of
> +@code{r} and @code{s}.

Similarly:

  you could request @value{GDBN} to interrogate the type and value of ...

> +the user can query the type of @code{s} via:

"you can query..."

> +Note that at present @value{GDBN} does not support interactive
> +manipulation of set expressions. However the debugger does understand
> +the declaration of Modula-2 arrays. For example in this code fragment
> +the declaration of @code{s} is described.

"For example, this code fragment describes the declaration of @code{s}:"

> +and this information is now seen by @value{GDBN}

"and @value{GDBN} now sees this information"

and so on.

Re: Enhanced language support for Modula-2

[Eli Zaretskii]

> Cc: gdb-patches@sources.redhat.com
> From: Gaius Mulley <gaius@glam.ac.uk>
> Date: 21 Feb 2006 10:24:46 +0000
> 
> here is a reworking of my patch which includes a new version of the
> set reading code in gdb/dwarf2read.c. Also contained is a patch to
> gdb/doc/gdb.texinfo reflecting the enhancements to the Modula-2 mode.

Thanks.  My comments are below.

> +      error (_("type not handled in m2_type_print_varspec_prefix()"));

Please don't append "()" to indicate that you are talking about a
function; just name the function.  "foo()" looks like a call to `foo'
with no arguments, which is not what you want to say.

> +      error (_("type not handled in m2_type_print_varspec_suffix()"));

Same here.

Btw, isn't it better to tell what type was not handled?

> +      fprintf_filtered(stream, "SET OF %s", _("<unknown>"));

It is better to include "SET OF" in the string to be translated:

      fprintf_filtered(stream, "%s", _("SET OF <unknown>"));

This way, the translator will see the whole phrase, and will be able
to translate "unknown" to a correct grammatical form (e.g., wrt
gender).  If you think "SET OF" should not be left verbatim, you can
put an i18n comment there:

    /* i18n: Do not translate the "SET OF" part!  */

These specially formatted comments will be extracted to the message
catalog, so the translators will see them right next to the string
they need to translate.

> +	fprintf_filtered (stream, "CASE %s OF\n", _("<variant>"));

Same here.

> +      fprintf_filtered (stream, "struct %s", _("<unknown>"));

And here.

> +	  fprintf_filtered (stream, "<%s %d>",
> +			    _("invalid type code"), TYPE_CODE (type));

And here.

> --- latest-cvs-gdb/src-cvs/gdb/doc/gdb.texinfo	2006-02-10 03:54:33.000000000 +0000
> +++ latest-cvs-gdb/src-m2/gdb/doc/gdb.texinfo	2006-02-21 10:10:41.000000000 +0000

The documentation patch is approved, but please take care of the
following minor issues:

> +@cindex Modula-2 types
> +@node M2 Types

The @cindex entry should come _after_ the @node, not before it.

> +@subsubsection Types

"Types" is too general a name here: this is just about Module-2 types;
there are quite a few other languages supported by GDB that have
types.  So I suggest to rename to "Modula-2 Types".

> +Values of these types may also be printed. So for example, if the
                                            ^^
Two spaces after each period that ends a sentence, please.

> +@example
> +VAR
> +   s: SET OF CHAR ;
> +   r: [20..40] ;
> +@end example
> +
> +@value{GDBN} could be requested to interrogate the type and value of

This last line is a continuation of the sentence from before the
@example, so please put @noindent before this line, to prevent its
indentation as if it were a new paragraph.

> +@example
> +VAR
> +   s: SET ['A'..'Z'] ;
> +@end example
> +
> +the user can query the type of @code{s} via:

Same here (and elsewhere, there are a few more like this).

> +It is advisable to use the following compile flags on the @code{gm2}
> +command line @code{-g -gdwarf-2}.

First, if there's only one command-line option you want to advise, why
use plural ``flags''?  And second, command-line options should be in
@option, not in @code.

> +(gdb) print s

Please use (@value{GDBP}) instead of a literal (gdb) (it's for the
same reason we use @value{GDBN} instead of a literal GDB.

I also agree with Jim's comments.

Re: Enhanced language support for Modula-2

[Eli Zaretskii]

> Date: Tue, 21 Feb 2006 11:01:11 -0800
> From: "Jim Blandy" <jimb@red-bean.com>
> Cc: gdb-patches@sources.redhat.com
> 
> On 21 Feb 2006 10:24:46 +0000, Gaius Mulley <gaius@glam.ac.uk> wrote:
> > +Currently @value{GDBN} can print the following data types in Modula-2
> > +syntax: array types, record types, set types, pointer types,
> > +procedure types, enumerated types, subrange types and base types.
> > +Values of these types may also be printed. So for example, if the
> > +following section of code were compiled,
> 
> This is Eli's call, but it's general practice in GNU documentation to
> go ahead and use "you" in preference to the passive voice.  I don't
> have a reference for this rule, I just have memories of Stallman
> correcting this in my own writing.

Right.  The reason is that passive-voice sentences frequently are
longer, more complicated and awkward than active voice.  So avoiding
passive makes the text more concise and clear.

Re: Enhanced language support for Modula-2

[Mark Kettenis]

> Date: Tue, 21 Feb 2006 22:46:08 +0200
> From: Eli Zaretskii <eliz@gnu.org>
> 
> Thanks.  My comments are below.
> 
> > +      error (_("type not handled in m2_type_print_varspec_prefix()"));
> 
> Please don't append "()" to indicate that you are talking about a
> function; just name the function.  "foo()" looks like a call to `foo'
> with no arguments, which is not what you want to say.
> 
> > +      error (_("type not handled in m2_type_print_varspec_suffix()"));
> 
> Same here.

Ah, but error messages intended for the user shouldn't mention
function names in the first place.  This should probably be an
internal_error() instead.

Mark

Re: Enhanced language support for Modula-2

[Eli Zaretskii]

> Date: Tue, 21 Feb 2006 21:53:53 +0100 (CET)
> From: Mark Kettenis <mark.kettenis@xs4all.nl>
> CC: gaius@glam.ac.uk, jimb@red-bean.com, gdb-patches@sources.redhat.com
> 
> Ah, but error messages intended for the user shouldn't mention
> function names in the first place.  This should probably be an
> internal_error() instead.

Re: Enhanced language support for Modula-2

[Eli Zaretskii]

> Date: Wed, 22 Feb 2006 06:27:30 +0200
> From: Eli Zaretskii <eliz@gnu.org>
> CC: gaius@glam.ac.uk, jimb@red-bean.com, gdb-patches@sources.redhat.com
> 
> > Date: Tue, 21 Feb 2006 21:53:53 +0100 (CET)
> > From: Mark Kettenis <mark.kettenis@xs4all.nl>
> > CC: gaius@glam.ac.uk, jimb@red-bean.com, gdb-patches@sources.redhat.com
> > 
> > Ah, but error messages intended for the user shouldn't mention
> > function names in the first place.  This should probably be an
> > internal_error() instead.

I meant to say that I agree.

Re: Enhanced language support for Modula-2

[Gaius Mulley]

"Jim Blandy" <jimb@red-bean.com> writes:

> On 21 Feb 2006 10:24:46 +0000, Gaius Mulley <gaius@glam.ac.uk> wrote:
> > here is a reworking of my patch which includes a new version of the
> > set reading code in gdb/dwarf2read.c. Also contained is a patch to
> > gdb/doc/gdb.texinfo reflecting the enhancements to the Modula-2 mode.
> 
> Okay.  That solves that problem.  :)
> 
> I'm a little concerned about the change to dwarf2read.c where you
> create a TYPE_CODE_CHAR type for DW_ATE_signed_char and
> DW_ATE_unsigned_char.  GDB uses TYPE_CODE_INT for C 'char' types.  I
> have vague memories of something going wrong with printing or
> evaluation or something if you actually use TYPE_CODE_CHAR, and after
> discussion deciding to stick with TYPE_CODE_INT.
> 
> But this patch causes no test suite regressions?

Hi,

thanks for all your suggestions/feedback about the patch, I'll
incorporate these changes, polish it and resubmit. Re:
regressions.. hmm, yes it does cause some regression failures, so I'll
retract the TYPE_CODE_CHAR type for DW_ATE_signed_char and
DW_ATE_unsigned_char in dwarf2read.c.

I guess the Modula-2 mode can use a different method. Would it be
allowable for me to extend the

    #define TYPE_FLAG_xxx

sequence (currently bits 0..15 are used).  So for example:

    #define TYPE_FLAG_LANG_CHAR (1 << 16)

and set this flag if we see DW_ATE_signed_char or
DW_ATE_unsigned_char.  Later in the Modula-2 language section this bit
could be tested and the appropriate action taken. Obviously I'd need
to set this bit in stabsread.c as well. This would also allow Pascal
to utilise CHAR rather than see a tiny integer.

Or is there a better/cleaner way?

regards,
Gaius

Re: Enhanced language support for Modula-2

[Jim Blandy]

On 25 Feb 2006 12:31:05 +0000, Gaius Mulley <gaius@glam.ac.uk> wrote:
> I guess the Modula-2 mode can use a different method. Would it be
> allowable for me to extend the
>
>     #define TYPE_FLAG_xxx
>
> sequence (currently bits 0..15 are used).  So for example:
>
>     #define TYPE_FLAG_LANG_CHAR (1 << 16)
>
> and set this flag if we see DW_ATE_signed_char or
> DW_ATE_unsigned_char.  Later in the Modula-2 language section this bit
> could be tested and the appropriate action taken. Obviously I'd need
> to set this bit in stabsread.c as well. This would also allow Pascal
> to utilise CHAR rather than see a tiny integer.

If Modula-2 has a genuinely distinct character type, then I think
TYPE_CODE_CHAR is the right type for you to use.  It's just that it
isn't for C.  So the code in dwarf2read.c needs to choose the type
code for a given DWARF base type based on the language of the
compilation unit that contains the die.  I think you'll need to test
cu->language, and set the type code appropriately in each case.

That may sound icky, but given that DWARF has decided to represent
different languages' types with a unified set of die tags, it seems
the reasonable way to go.  If, over time, read_base_type gets really
complicated due to this sort of thing, then we could always have some
sort of language-specific hook function.  But since GDB uses the same
approach to types that Dwarf does --- a unified set of type codes used
by all the languages --- we only really have to attend to the cases
where GDB's mappings are different from DWARF's, so I think it should
be okay for now.

Re: Enhanced language support for Modula-2

[Daniel Jacobowitz]

On Sat, Feb 25, 2006 at 09:37:05PM -0800, Jim Blandy wrote:
> On 25 Feb 2006 12:31:05 +0000, Gaius Mulley <gaius@glam.ac.uk> wrote:
> > I guess the Modula-2 mode can use a different method. Would it be
> > allowable for me to extend the
> >
> >     #define TYPE_FLAG_xxx
> >
> > sequence (currently bits 0..15 are used).  So for example:
> >
> >     #define TYPE_FLAG_LANG_CHAR (1 << 16)
> >
> > and set this flag if we see DW_ATE_signed_char or
> > DW_ATE_unsigned_char.  Later in the Modula-2 language section this bit
> > could be tested and the appropriate action taken. Obviously I'd need
> > to set this bit in stabsread.c as well. This would also allow Pascal
> > to utilise CHAR rather than see a tiny integer.
> 
> If Modula-2 has a genuinely distinct character type, then I think
> TYPE_CODE_CHAR is the right type for you to use.  It's just that it
> isn't for C.  So the code in dwarf2read.c needs to choose the type
> code for a given DWARF base type based on the language of the
> compilation unit that contains the die.  I think you'll need to test
> cu->language, and set the type code appropriately in each case.

We already use a language hook for read_base_type when the type has no
name.  Maybe we should regardless of whether the type has a name?
I've always been a bit confused by the "fundamental type" code.

-- 
Daniel Jacobowitz
CodeSourcery

Re: Enhanced language support for Modula-2

[Gaius Mulley]

"Jim Blandy" <jimb@red-bean.com> writes:

> If Modula-2 has a genuinely distinct character type, then I think
> TYPE_CODE_CHAR is the right type for you to use.  It's just that it
> isn't for C.  So the code in dwarf2read.c needs to choose the type
> code for a given DWARF base type based on the language of the
> compilation unit that contains the die.  I think you'll need to test
> cu->language, and set the type code appropriately in each case.
> 
> That may sound icky, but given that DWARF has decided to represent
> different languages' types with a unified set of die tags, it seems
> the reasonable way to go.  If, over time, read_base_type gets really
> complicated due to this sort of thing, then we could always have some
> sort of language-specific hook function.  But since GDB uses the same
> approach to types that Dwarf does --- a unified set of type codes used
> by all the languages --- we only really have to attend to the cases
> where GDB's mappings are different from DWARF's, so I think it should
> be okay for now.

Hi,

sure, ok.  Here is the patch again with all issues addressed from the
last set of email responses.  Texinfo mods, dwarf2read.c (CHAR/int
issues) and various error messages converted into internal error
messages etc.  The results of the regression tests are also given,
note that the "# of unexpected failures" varies from run to run.  I've
seen the m2-patched version do slightly better than the cvs version
and also slightly worse..  Anyway overall I believe the patch does no
harm..

regards,
Gaius



CVS make check-gdb

# of expected passes            11021
# of unexpected failures        19
# of unexpected successes       1
# of expected failures          45
# of unknown successes          6
# of known failures             51
# of untested testcases         6
# of unsupported tests          13

CVS + patch make check-gdb

# of expected passes            11024
# of unexpected failures        17
# of unexpected successes       1
# of expected failures          45
# of unknown successes          6
# of known failures             50
# of untested testcases         6
# of unsupported tests          13


--- latest-cvs-gdb/src-cvs/gdb/m2-lang.h	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-lang.h	2006-02-15 10:49:54.000000000 +0000
@@ -27,6 +27,11 @@
 extern void m2_print_type (struct type *, char *, struct ui_file *, int,
 			   int);
 
+extern int m2_is_long_set (struct type *type);
+
 extern int m2_val_print (struct type *, const gdb_byte *, int, CORE_ADDR,
 			 struct ui_file *, int, int, int,
 			 enum val_prettyprint);
+
+extern int get_long_set_bounds (struct type *type, LONGEST *low,
+				LONGEST *high);
--- latest-cvs-gdb/src-cvs/gdb/m2-typeprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-typeprint.c	2006-02-27 23:21:59.000000000 +0000
@@ -1,5 +1,6 @@
 /* Support for printing Modula 2 types for GDB, the GNU debugger.
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    This file is part of GDB.
@@ -20,22 +21,799 @@
    Boston, MA 02110-1301, USA.  */
 
 #include "defs.h"
+#include "gdb_obstack.h"
 #include "bfd.h"		/* Binary File Description */
 #include "symtab.h"
 #include "gdbtypes.h"
 #include "expression.h"
 #include "value.h"
 #include "gdbcore.h"
-#include "target.h"
 #include "m2-lang.h"
+#include "target.h"
+#include "language.h"
+#include "demangle.h"
+#include "c-lang.h"
+#include "typeprint.h"
+#include "cp-abi.h"
+
+#include "gdb_string.h"
 #include <errno.h>
 
+static void m2_type_print_args (struct type *, struct ui_file *);
+
+void m2_type_print_varspec_prefix (struct type *, struct ui_file *, int,
+				   int);
+void m2_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
+				   int show, int passed_a_ptr, int demangled_args);
+
+
+void m2_type_print_base (struct type *type, struct ui_file *stream, int show,
+			 int level);
+
+static void m2_print_bounds (struct type *type,
+			     struct ui_file *stream, int show, int level,
+			     int print_high);
+
+/* Print "const", "volatile", or address space modifiers. */
+static void m2_type_print_modifier (struct type *, struct ui_file *,
+				   int, int);
+
 void
 m2_print_type (struct type *type, char *varstring, struct ui_file *stream,
-	       int show, int level)
+	      int show, int level)
+{
+  enum type_code code;
+  int demangled_args;
+
+  if (show > 0)
+    CHECK_TYPEDEF (type);
+
+  code = TYPE_CODE (type);
+
+  /*
+   *  is it a VAR parameter?
+   */
+  if (code == TYPE_CODE_REF)
+    fputs_filtered ("VAR", stream);
+
+  m2_type_print_varspec_prefix (type, stream, show, 0);
+  m2_type_print_varspec_suffix (type, stream, show, 0, 0);
+  m2_type_print_base (type, stream, show, level);
+}
+
+/* Print any asterisks or open-parentheses needed before the
+   variable name (to describe its type).
+
+   On outermost call, pass 0 for PASSED_A_PTR.
+   On outermost call, SHOW > 0 means should ignore
+   any typename for TYPE and show its details.
+   SHOW is always zero on recursive calls.  */
+
+void
+m2_type_print_varspec_prefix (struct type *type, struct ui_file *stream,
+			     int show, int passed_a_ptr)
+{
+  char *name;
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_PTR:
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_FUNC) {
+	m2_type_print_modifier (type, stream, 1, 0);
+	fprintf_filtered (stream, "POINTER TO ");
+	m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
+      }
+      break;
+
+    case TYPE_CODE_MEMBER:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, "(");
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      fprintf_filtered (stream, " ");
+      name = type_name_no_tag (TYPE_DOMAIN_TYPE (type));
+      if (name)
+	fputs_filtered (name, stream);
+      else
+	m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, 0, passed_a_ptr);
+      fprintf_filtered (stream, "::");
+      break;
+
+    case TYPE_CODE_METHOD:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, "(");
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      if (passed_a_ptr)
+	{
+	  fprintf_filtered (stream, " ");
+	  m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, 0, passed_a_ptr);
+	  fprintf_filtered (stream, "::");
+	}
+      break;
+
+    case TYPE_CODE_REF:
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
+      fprintf_filtered (stream, " ");
+      m2_type_print_modifier (type, stream, 1, 0);
+      break;
+
+    case TYPE_CODE_FUNC:
+      break;
+
+    case TYPE_CODE_ARRAY:
+      m2_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_STRING:
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_TYPEDEF:
+    case TYPE_CODE_TEMPLATE:
+      /* These types need no prefix.  They are listed here so that
+         gcc -Wall will reveal any types that haven't been handled.  */
+      break;
+    default:
+      internal_error (__FILE__, __LINE__,
+		      _("type not handled in m2_type_print_varspec_prefix"));
+      break;
+    }
+}
+
+/* Print out "const" and "volatile" attributes.
+   TYPE is a pointer to the type being printed out.
+   STREAM is the output destination.
+   NEED_SPACE = 1 indicates an initial white space is needed */
+
+static void
+m2_type_print_modifier (struct type *type, struct ui_file *stream,
+		       int need_pre_space, int need_post_space)
+{
+  int did_print_modifier = 0;
+  const char *address_space_id;
+
+  /* We don't print `const' qualifiers for references --- since all
+     operators affect the thing referenced, not the reference itself,
+     every reference is `const'.  */
+  if (TYPE_CONST (type)
+      && TYPE_CODE (type) != TYPE_CODE_REF)
+    {
+      if (need_pre_space)
+	fprintf_filtered (stream, " ");
+      fprintf_filtered (stream, "const");
+      did_print_modifier = 1;
+    }
+
+  if (TYPE_VOLATILE (type))
+    {
+      if (did_print_modifier || need_pre_space)
+	fprintf_filtered (stream, " ");
+      fprintf_filtered (stream, "volatile");
+      did_print_modifier = 1;
+    }
+
+  address_space_id = address_space_int_to_name (TYPE_INSTANCE_FLAGS (type));
+  if (address_space_id)
+    {
+      if (did_print_modifier || need_pre_space)
+	fprintf_filtered (stream, " ");
+      fprintf_filtered (stream, "@%s", address_space_id);
+      did_print_modifier = 1;
+    }
+
+  if (did_print_modifier && need_post_space)
+    fprintf_filtered (stream, " ");
+}
+
+
+
+
+static void
+m2_type_print_args (struct type *type, struct ui_file *stream)
 {
-  extern void c_print_type (struct type *, char *, struct ui_file *, int,
-			    int);
+  int i;
+  struct field *args;
+
+  fprintf_filtered (stream, "(");
+  args = TYPE_FIELDS (type);
+  if (args != NULL)
+    {
+      int i;
+
+      /* FIXME drow/2002-05-31: Always skips the first argument,
+	 should we be checking for static members?  */
+
+      for (i = 1; i < TYPE_NFIELDS (type); i++)
+	{
+	  c_print_type (args[i].type, "", stream, -1, 0);
+	  if (i != TYPE_NFIELDS (type))
+	    {
+	      fprintf_filtered (stream, ",");
+	      wrap_here ("    ");
+	    }
+	}
+      if (TYPE_VARARGS (type))
+	fprintf_filtered (stream, "...");
+      else if (i == 1
+	       && (current_language->la_language == language_cplus))
+	fprintf_filtered (stream, "void");
+    }
+  else if (current_language->la_language == language_cplus)
+    {
+      fprintf_filtered (stream, "void");
+    }
+
+  fprintf_filtered (stream, ")");
+}
+
+
+
+
+/* Print any array sizes, function arguments or close parentheses
+   needed after the variable name (to describe its type).
+   Args work like m2_type_print_varspec_prefix.  */
+
+void
+m2_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
+			      int show, int passed_a_ptr, int demangled_args)
+{
+  if (type == 0)
+    return;
+
+  if (TYPE_NAME (type) && show <= 0)
+    return;
+
+  QUIT;
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      fprintf_filtered (stream, "ARRAY [");
+      if (TYPE_LENGTH (type) >= 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0
+	  && TYPE_ARRAY_UPPER_BOUND_TYPE (type) != BOUND_CANNOT_BE_DETERMINED) {
+	if (TYPE_INDEX_TYPE (type) != 0) {
+	  m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 0);
+	  fprintf_filtered (stream, "..");
+	  m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 1);
+	}
+	else
+	  fprintf_filtered (stream, "%d",
+			    (TYPE_LENGTH (type)
+			     / TYPE_LENGTH (TYPE_TARGET_TYPE (type))));
+      }
+      fprintf_filtered (stream, "] OF ");
+
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      break;
+
+    case TYPE_CODE_MEMBER:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, ")");
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      break;
+
+    case TYPE_CODE_METHOD:
+      if (passed_a_ptr)
+	fprintf_filtered (stream, ")");
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+      if (passed_a_ptr)	{
+	m2_type_print_args (type, stream);
+      }
+      break;
+
+    case TYPE_CODE_PTR:
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_FUNC) {
+	fprintf_filtered (stream, "PROCEDURE");
+	break;
+      }
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
+      break;
+
+    case TYPE_CODE_REF:
+      m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
+      break;
+
+    case TYPE_CODE_FUNC:
+      if (!demangled_args)
+	{
+	  int i, len = TYPE_NFIELDS (type);
+
+	  fprintf_filtered (stream, " (");
+	  for (i = 0; i < len; i++)
+	    {
+	      if (i > 0)
+		{
+		  fputs_filtered (", ", stream);
+		  wrap_here ("    ");
+		}
+	      m2_print_type (TYPE_FIELD_TYPE (type, i), "", stream, -1, 0);
+	    }
+	  fprintf_filtered (stream, ")");
+	}
+      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID) {
+	fprintf_filtered (stream, " : ");
+	m2_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
+				      passed_a_ptr, 0);
+      }
+      break;
+
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_STRUCT:
+    case TYPE_CODE_UNION:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_CHAR:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_SET:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_STRING:
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_COMPLEX:
+    case TYPE_CODE_TYPEDEF:
+    case TYPE_CODE_TEMPLATE:
+      /* These types do not need a suffix.  They are listed so that
+         gcc -Wall will report types that may not have been considered.  */
+      break;
+    default:
+      internal_error (__FILE__, __LINE__,
+		      _("type not handled in m2_type_print_varspec_suffix"));
+      break;
+    }
+}
+
+
+static void
+m2_print_bounds (struct type *type,
+		 struct ui_file *stream, int show, int level,
+		 int print_high)
+{
+  struct type *target = TYPE_TARGET_TYPE (type);
+
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (TYPE_NFIELDS(type) == 0)
+    return;
+
+  if (print_high)
+    print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+  else
+    print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+}
+
+static void
+m2_short_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  fprintf_filtered(stream, "SET [");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 0);
+
+  fprintf_filtered(stream, "..");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 1);
+  fprintf_filtered(stream, "]");
+}
+
+int
+m2_is_long_set (struct type *type)
+{
+  LONGEST previous_high = 0;  /* unnecessary initialization keeps gcc -Wall happy */
+  int len, i;
+  struct type *range;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+
+    /*
+     *  check if all fields of the RECORD are consecutive sets
+     */
+    len = TYPE_NFIELDS (type);
+    for (i = TYPE_N_BASECLASSES (type); i < len; i++) {
+      if (TYPE_FIELD_TYPE (type, i) == NULL)
+	return 0;
+      if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) != TYPE_CODE_SET)
+	return 0;
+      if (TYPE_FIELD_NAME (type, i) != NULL
+	  && (strcmp (TYPE_FIELD_NAME (type, i), "") != 0))
+	return 0;
+      range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+      if ((i > TYPE_N_BASECLASSES (type))
+	  && previous_high + 1 != TYPE_LOW_BOUND (range))
+	return 0;
+      previous_high = TYPE_HIGH_BOUND (range);
+    }
+    return len>0;
+  }
+  return 0;
+}
+
+/*
+ *  m2_get_discrete_bounds - a wrapper for get_discrete_bounds which
+ *                           understands that CHARs might be signed.
+ *                           This should be integrated into gdbtypes.c
+ *                           inside get_discrete_bounds.
+ */
+
+int
+m2_get_discrete_bounds (struct type *type, LONGEST *lowp, LONGEST *highp)
+{
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_CHAR:
+      if (TYPE_LENGTH (type) < sizeof (LONGEST)) {
+	if (!TYPE_UNSIGNED (type))
+	  {
+	    *lowp = -(1 << (TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1));
+	    *highp = -*lowp - 1;
+	    return 0;
+	  }
+      }
+      /* fall through */
+    default:
+      return get_discrete_bounds (type, lowp, highp);
+    }
+}
+
+/*
+ *  m2_is_long_set_of_type - returns TRUE if the long set was declared as SET OF <oftype>
+ *                           of_type is assigned to the subtype.
+ */
+
+int
+m2_is_long_set_of_type (struct type *type, struct type **of_type)
+{
+  int len, i;
+  struct type *range;
+  struct type *target;
+  LONGEST l1, l2;
+  LONGEST h1, h2;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+    target = TYPE_TARGET_TYPE (range);
+    if (target == NULL)
+      target = builtin_type_int;
+
+    l1 = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    h1 = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    *of_type = target;
+    if (m2_get_discrete_bounds (target, &l2, &h2) >= 0)
+      return (l1 == l2 && h1 == h2);
+    error (_("long_set failed to find discrete bounds for its subtype"));
+    return 0;
+  }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static int
+m2_long_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  struct type *index_type;
+  struct type *range_type;
+  struct type *of_type;
+  int i;
+  int len = TYPE_NFIELDS (type);
+  LONGEST low;
+  LONGEST high;
+
+  if (m2_is_long_set (type)) {
+    if (TYPE_TAG_NAME (type) != NULL) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+    else if (TYPE_NAME (type) != NULL) {
+      fputs_filtered (TYPE_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+
+    if (TYPE_TAG_NAME (type) != NULL || TYPE_NAME (type) != NULL)
+      fputs_filtered (" = ", stream);
+
+    if (get_long_set_bounds (type, &low, &high)) {
+      fprintf_filtered(stream, "SET OF ");
+      i = TYPE_N_BASECLASSES (type);
+      if (m2_is_long_set_of_type (type, &of_type))
+	m2_print_type (of_type, "", stream, show - 1, level);
+      else {
+	fprintf_filtered(stream, "[");
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)),
+			 stream, show - 1, level, 0);
+
+	fprintf_filtered(stream, "..");
+
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)),
+			 stream, show - 1, level, 1);
+	fprintf_filtered(stream, "]");
+      }
+    }
+    else
+      /* i18n: Do not translate the "SET OF" part! */
+      fprintf_filtered(stream, _("SET OF <unknown>"));
+
+    return 1;
+  }
+  return 0;
+}
+
+void
+m2_record_fields (struct type *type, struct ui_file *stream, int show,
+		  int level)
+{
+  /* Print the tag if it exists. 
+   */
+  if (TYPE_TAG_NAME (type) != NULL) {
+    if (strncmp (TYPE_TAG_NAME (type), "$$", 2) != 0) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show > 0)
+	fprintf_filtered (stream, " = ");
+    }
+  }
+  wrap_here ("    ");
+  if (show < 0)
+    {
+      if (TYPE_CODE (type) == DECLARED_TYPE_STRUCT)
+	fprintf_filtered (stream, "RECORD ... END ");
+      else if (TYPE_DECLARED_TYPE (type) == DECLARED_TYPE_UNION)
+	fprintf_filtered (stream, "CASE ... END ");
+    }
+  else if (show > 0)
+    {
+      if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
+	fprintf_filtered (stream, "RECORD\n");
+      else if (TYPE_CODE (type) == TYPE_CODE_UNION)
+	/* i18n: Do not translate "CASE" and "OF" */
+	fprintf_filtered (stream, _("CASE <variant> OF\n"));
+      int i;
+      int len = TYPE_NFIELDS (type);
+
+      for (i = TYPE_N_BASECLASSES (type); i < len; i++)
+	{
+	  QUIT;
+
+	  print_spaces_filtered (level + 4, stream);
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	  fputs_filtered (" : ", stream);
+	  m2_print_type (TYPE_FIELD_TYPE (type, i),
+			 "",
+			 stream, 0, level + 4);
+	  if (TYPE_FIELD_PACKED (type, i))
+	    {
+	      /* It is a bitfield.  This code does not attempt
+		 to look at the bitpos and reconstruct filler,
+		 unnamed fields.  This would lead to misleading
+		 results if the compiler does not put out fields
+		 for such things (I don't know what it does).  */
+	      fprintf_filtered (stream, " : %d",
+				TYPE_FIELD_BITSIZE (type, i));
+	    }
+	  fprintf_filtered (stream, ";\n");
+	}
+      
+      fprintfi_filtered (level, stream, "END ");
+    }
+}
+
+/* Print the name of the type (or the ultimate pointer target,
+   function value or array element), or the description of a
+   structure or union.
+
+   SHOW positive means print details about the type (e.g. enum values),
+   and print structure elements passing SHOW - 1 for show.
+   SHOW negative means just print the type name or struct tag if there is one.
+   If there is no name, print something sensible but concise like
+   "struct {...}".
+   SHOW zero means just print the type name or struct tag if there is one.
+   If there is no name, print something sensible but not as concise like
+   "struct {int x; int y;}".
+
+   LEVEL is the number of spaces to indent by.
+   We increase it for some recursive calls.  */
+
+void
+m2_type_print_base (struct type *type, struct ui_file *stream, int show,
+		    int level)
+{
+  int i;
+  int len, real_len;
+  int lastval;
+  char *mangled_name;
+  char *demangled_name;
+  char *demangled_no_static;
+  enum
+    {
+      s_none, s_public, s_private, s_protected
+    }
+  section_type;
+  int need_access_label = 0;
+  int j, len2;
+
+  QUIT;
+
+  wrap_here ("    ");
+  if (type == NULL)
+    {
+      fputs_filtered (_("<type unknown>"), stream);
+      return;
+    }
+
+  /* When SHOW is zero or less, and there is a valid type name, then always
+     just print the type name directly from the type.  */
+  /* If we have "typedef struct foo {. . .} bar;" do we want to print it
+     as "struct foo" or as "bar"?  Pick the latter, because C++ folk tend
+     to expect things like "class5 *foo" rather than "struct class5 *foo".  */
+
+  if (show <= 0
+      && TYPE_NAME (type) != NULL)
+    {
+      m2_type_print_modifier (type, stream, 0, 1);
+      fputs_filtered (TYPE_NAME (type), stream);
+      return;
+    }
+
+  CHECK_TYPEDEF (type);
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_TYPEDEF:
+    case TYPE_CODE_ARRAY:
+    case TYPE_CODE_PTR:
+    case TYPE_CODE_MEMBER:
+    case TYPE_CODE_REF:
+    case TYPE_CODE_METHOD:
+      m2_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
+      break;
+
+    case TYPE_CODE_FUNC:
+      break;
+
+    case TYPE_CODE_SET:
+      m2_short_set(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_STRUCT:
+      if (m2_long_set (type, stream, show, level))
+	break;
+      m2_type_print_modifier (type, stream, 0, 1);
+      m2_record_fields(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_UNION:
+      m2_type_print_modifier (type, stream, 0, 1);
+      m2_record_fields(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_ENUM:
+      m2_type_print_modifier (type, stream, 0, 1);
+      /* HP C supports sized enums */
+      if (deprecated_hp_som_som_object_present)
+	switch (TYPE_LENGTH (type))
+	  {
+	  case 1:
+	    fputs_filtered ("char ", stream);
+	    break;
+	  case 2:
+	    fputs_filtered ("short ", stream);
+	    break;
+	  default:
+	    break;
+	  }
+      /* Print the tag name if it exists.
+         The aCC compiler emits a spurious 
+         "{unnamed struct}"/"{unnamed union}"/"{unnamed enum}"
+         tag for unnamed struct/union/enum's, which we don't
+         want to print. */
+      if (TYPE_TAG_NAME (type) != NULL &&
+	  strncmp (TYPE_TAG_NAME (type), "{unnamed", 8))
+	{
+	  fputs_filtered (TYPE_TAG_NAME (type), stream);
+	  if (show > 0)
+	    fputs_filtered (" ", stream);
+	}
+
+      wrap_here ("    ");
+      if (show < 0)
+	{
+	  /* If we just printed a tag name, no need to print anything else.  */
+	  if (TYPE_TAG_NAME (type) == NULL)
+	    fprintf_filtered (stream, "(...)");
+	}
+      else if (show > 0 || TYPE_TAG_NAME (type) == NULL)
+	{
+	  fprintf_filtered (stream, "(");
+	  len = TYPE_NFIELDS (type);
+	  lastval = 0;
+	  for (i = 0; i < len; i++)
+	    {
+	      QUIT;
+	      if (i)
+		fprintf_filtered (stream, ", ");
+	      wrap_here ("    ");
+	      fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	      if (lastval != TYPE_FIELD_BITPOS (type, i))
+		{
+		  fprintf_filtered (stream, " = %d", TYPE_FIELD_BITPOS (type, i));
+		  lastval = TYPE_FIELD_BITPOS (type, i);
+		}
+	      lastval++;
+	    }
+	  fprintf_filtered (stream, ")");
+	}
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "void");
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* i18n: Do not translate the "struct" part! */
+      fprintf_filtered (stream, _("struct <unknown>"));
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, _("<unknown type>"));
+      break;
+
+    case TYPE_CODE_RANGE:
+      if (TYPE_HIGH_BOUND (type) == TYPE_LOW_BOUND (type))
+	m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, show, level);
+      else {
+	struct type *target = TYPE_TARGET_TYPE (type);
+
+	fprintf_filtered (stream, "[");
+	print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+	fprintf_filtered (stream, "..");
+	print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+	fprintf_filtered (stream, "]");
+      }
+      break;
+
+    case TYPE_CODE_TEMPLATE:
+      break;
 
-  c_print_type (type, varstring, stream, show, level);	/* FIXME */
+    default:
+      /* Handle types not explicitly handled by the other cases,
+         such as fundamental types.  For these, just print whatever
+         the type name is, as recorded in the type itself.  If there
+         is no type name, then complain. */
+      if (TYPE_NAME (type) != NULL)
+	{
+	  m2_type_print_modifier (type, stream, 0, 1);
+	  fputs_filtered (TYPE_NAME (type), stream);
+	}
+      else
+	{
+	  /* At least for dump_symtab, it is important that this not be
+	     an error ().  */
+	  fprintf_filtered (stream, "<%s %d>",
+			    _("invalid type code"), TYPE_CODE (type));
+	}
+      break;
+    }
 }
--- latest-cvs-gdb/src-cvs/gdb/dwarf2read.c	2006-02-09 18:18:41.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/dwarf2read.c	2006-02-27 23:55:12.000000000 +0000
@@ -1,7 +1,7 @@
 /* DWARF 2 debugging format support for GDB.
 
-   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-   2004, 2005, 2006
+   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    Adapted by Gary Funck (gary@intrepid.com), Intrepid Technology,
@@ -1073,6 +1073,9 @@
 
 static void dwarf2_clear_marks (struct dwarf2_per_cu_data *);
 
+static void read_set_type (struct die_info *, struct dwarf2_cu *);
+
+
 /* Try to locate the sections we need for DWARF 2 debugging
    information and return true if we have enough to do something.  */
 
@@ -2662,6 +2665,9 @@
     case DW_TAG_subroutine_type:
       read_subroutine_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
@@ -4240,6 +4246,15 @@
     };
 }
 
+/* Extract all information from a DW_TAG_set_type DIE and put it in
+   the DIE's type field. */
+
+static void
+read_set_type (struct die_info *die, struct dwarf2_cu *cu)
+{
+  if (die->type == NULL)
+    die->type = create_set_type ((struct type *) NULL, die_type (die, cu));
+}
 
 /* First cut: install each common block member as a global variable.  */
 
@@ -4728,10 +4743,17 @@
 	  code = TYPE_CODE_FLT;
 	  break;
 	case DW_ATE_signed:
-	case DW_ATE_signed_char:
 	  break;
 	case DW_ATE_unsigned:
-	case DW_ATE_unsigned_char:
+	  type_flags |= TYPE_FLAG_UNSIGNED;
+	  break;
+	case DW_ATE_signed_char:
+	  if (cu->language == language_m2)
+	    code = TYPE_CODE_CHAR;
+	  break;
+ 	case DW_ATE_unsigned_char:
+	  if (cu->language == language_m2)
+	    code = TYPE_CODE_CHAR;
 	  type_flags |= TYPE_FLAG_UNSIGNED;
 	  break;
 	default:
@@ -6146,6 +6168,10 @@
 {
   switch (lang)
     {
+    case DW_LANG_Ada83:
+    case DW_LANG_Ada95:
+      cu->language = language_ada;
+      break;
     case DW_LANG_C89:
     case DW_LANG_C:
       cu->language = language_c;
@@ -6153,25 +6179,29 @@
     case DW_LANG_C_plus_plus:
       cu->language = language_cplus;
       break;
+    case DW_LANG_Cobol74:
+      cu->language = DW_LANG_Cobol74;
+      break;
+    case DW_LANG_Cobol85:
+      cu->language = DW_LANG_Cobol85;
+      break;
     case DW_LANG_Fortran77:
     case DW_LANG_Fortran90:
     case DW_LANG_Fortran95:
       cu->language = language_fortran;
       break;
-    case DW_LANG_Mips_Assembler:
-      cu->language = language_asm;
-      break;
     case DW_LANG_Java:
       cu->language = language_java;
       break;
-    case DW_LANG_Ada83:
-    case DW_LANG_Ada95:
-      cu->language = language_ada;
+    case DW_LANG_Mips_Assembler:
+      cu->language = language_asm;
       break;
-    case DW_LANG_Cobol74:
-    case DW_LANG_Cobol85:
-    case DW_LANG_Pascal83:
     case DW_LANG_Modula2:
+      cu->language = language_m2;
+      break;
+    case DW_LANG_Pascal83:
+      cu->language = language_pascal;
+      break;
     default:
       cu->language = language_minimal;
       break;
@@ -6958,6 +6988,7 @@
 	case DW_TAG_class_type:
 	case DW_TAG_structure_type:
 	case DW_TAG_union_type:
+	case DW_TAG_set_type:
 	case DW_TAG_enumeration_type:
 	  SYMBOL_CLASS (sym) = LOC_TYPEDEF;
 	  SYMBOL_DOMAIN (sym) = STRUCT_DOMAIN;
@@ -7287,6 +7318,9 @@
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_pointer_type:
       read_tag_pointer_type (die, cu);
       break;
@@ -7337,7 +7371,8 @@
   struct die_info *parent;
 
   if (cu->language != language_cplus
-      && cu->language != language_java)
+      && cu->language != language_java
+      && cu->language != language_pascal)
     return NULL;
 
   parent = die->parent;
--- latest-cvs-gdb/src-cvs/gdb/m2-valprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-valprint.c	2006-02-16 11:48:39.000000000 +0000
@@ -1,7 +1,8 @@
 /* Support for printing Modula 2 values for GDB, the GNU debugger.
 
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998, 2000, 2005 Free
-   Software Foundation, Inc.
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998,
+                 2000, 2005, 2006
+   Free Software Foundation, Inc.
 
    This file is part of GDB.
 
@@ -23,14 +24,513 @@
 #include "defs.h"
 #include "symtab.h"
 #include "gdbtypes.h"
-#include "m2-lang.h"
+#include "expression.h"
+#include "value.h"
+#include "valprint.h"
+#include "language.h"
+#include "typeprint.h"
 #include "c-lang.h"
+#include "m2-lang.h"
+#include "target.h"
+
+
+/* Print function pointer with inferior address ADDRESS onto stdio
+   stream STREAM.  */
+
+static void
+print_function_pointer_address (CORE_ADDR address, struct ui_file *stream)
+{
+  CORE_ADDR func_addr = gdbarch_convert_from_func_ptr_addr (current_gdbarch,
+							    address,
+							    &current_target);
+
+  /* If the function pointer is represented by a description, print the
+     address of the description.  */
+  if (addressprint && func_addr != address)
+    {
+      fputs_filtered ("@", stream);
+      fputs_filtered (paddress (address), stream);
+      fputs_filtered (": ", stream);
+    }
+  print_address_demangle (func_addr, stream, demangle);
+}
+
+/*
+ *  get_long_set_bounds - assigns the bounds of the long set to low and high.
+ */
+
+int
+get_long_set_bounds (struct type *type, LONGEST *low, LONGEST *high)
+{
+  int len, i;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    *low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    *high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    return 1;
+  }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static void
+m2_print_long_set (struct type *type, const gdb_byte *valaddr, int embedded_offset,
+		   CORE_ADDR address, struct ui_file *stream, int format,
+		   enum val_prettyprint pretty)
+{
+  int empty_set        = 1;
+  int element_seen     = 0;
+  LONGEST previous_low = 0;
+  LONGEST previous_high= 0;
+  LONGEST i, low_bound, high_bound;
+  LONGEST field_low, field_high;
+  struct type *range;
+  int len, field;
+  struct type *target;
+  int bitval;
+
+  CHECK_TYPEDEF (type);
+
+  fprintf_filtered (stream, "{");
+  len = TYPE_NFIELDS (type);
+  if (get_long_set_bounds (type, &low_bound, &high_bound)) {
+    field = TYPE_N_BASECLASSES (type);
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+  }
+  else {
+    fprintf_filtered (stream, " %s }", _("<unknown bounds of set>"));
+    return;
+  }
+
+  target = TYPE_TARGET_TYPE (range);
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (get_discrete_bounds (range, &field_low, &field_high) >= 0) {
+    for (i = low_bound; i <= high_bound; i++) {
+      bitval = value_bit_index (TYPE_FIELD_TYPE (type, field),
+				(TYPE_FIELD_BITPOS (type, field) / 8) +
+				valaddr + embedded_offset, i);
+      if (bitval < 0)
+	error (_("bit test is out of range"));
+      else if (bitval > 0) {
+	previous_high = i;
+	if (! element_seen) {
+	  if (! empty_set)
+	    fprintf_filtered (stream, ", ");
+	  print_type_scalar (target, i, stream);
+	  empty_set    = 0;
+	  element_seen = 1;
+	  previous_low = i;
+	}
+      }
+      else {
+	/* bit is not set */
+	if (element_seen) {
+	  if (previous_low+1 < previous_high)
+	    fprintf_filtered (stream, "..");
+	  if (previous_low+1 < previous_high)
+	    print_type_scalar (target, previous_high, stream);
+	  element_seen = 0;
+	}
+      }
+      if (i == field_high) {
+	field++;
+	if (field == len)
+	  break;
+	range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+	if (get_discrete_bounds (range, &field_low, &field_high) < 0)
+	  break;
+	target = TYPE_TARGET_TYPE (range);
+	if (target == NULL)
+	  target = builtin_type_int;
+      }
+    }
+    if (element_seen) {
+      if (previous_low+1 < previous_high) {
+	fprintf_filtered (stream, "..");
+	print_type_scalar (target, previous_high, stream);
+      }
+      element_seen = 0;
+    }
+    fprintf_filtered (stream, "}");
+  }
+}
+
+/* Print data of type TYPE located at VALADDR (within GDB), which came from
+   the inferior at address ADDRESS, onto stdio stream STREAM according to
+   FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
+   target byte order.
+
+   If the data are a string pointer, returns the number of string characters
+   printed.
+
+   If DEREF_REF is nonzero, then dereference references, otherwise just print
+   them like pointers.
+
+   The PRETTY parameter controls prettyprinting.  */
 
 int
 m2_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 	      CORE_ADDR address, struct ui_file *stream, int format,
 	      int deref_ref, int recurse, enum val_prettyprint pretty)
 {
-  return (c_val_print (type, valaddr, 0, address, stream, format, deref_ref,
-		       recurse, pretty));
+  unsigned int i = 0;	/* Number of characters printed */
+  unsigned len;
+  struct type *elttype;
+  unsigned eltlen;
+  int length_pos, length_size, string_pos;
+  int char_size;
+  LONGEST val;
+  CORE_ADDR addr;
+
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
+	{
+	  elttype = check_typedef (TYPE_TARGET_TYPE (type));
+	  eltlen = TYPE_LENGTH (elttype);
+	  len = TYPE_LENGTH (type) / eltlen;
+	  if (prettyprint_arrays)
+	    {
+	      print_spaces_filtered (2 + 2 * recurse, stream);
+	    }
+	  /* For an array of chars, print with string syntax.  */
+	  if (eltlen == 1 &&
+	      ((TYPE_CODE (elttype) == TYPE_CODE_INT)
+	       || ((current_language->la_language == language_m2)
+		   && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
+	      && (format == 0 || format == 's'))
+	    {
+	      /* If requested, look for the first null char and only print
+	         elements up to it.  */
+	      if (stop_print_at_null)
+		{
+		  unsigned int temp_len;
+
+		  /* Look for a NULL char. */
+		  for (temp_len = 0;
+		       (valaddr + embedded_offset)[temp_len]
+		       && temp_len < len && temp_len < print_max;
+		       temp_len++);
+		  len = temp_len;
+		}
+
+	      LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
+	      i = len;
+	    }
+	  else
+	    {
+	      fprintf_filtered (stream, "{");
+	      val_print_array_elements (type, valaddr + embedded_offset, address, stream,
+				     format, deref_ref, recurse, pretty, 0);
+	      fprintf_filtered (stream, "}");
+	    }
+	  break;
+	}
+      /* Array of unspecified length: treat like pointer to first elt.  */
+      addr = address;
+      goto print_unpacked_pointer;
+
+    case TYPE_CODE_PTR:
+      if (format && format != 's')
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+      {
+	addr = unpack_pointer (type, valaddr + embedded_offset);
+	print_unpacked_pointer:
+	elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+	if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
+	  {
+	    /* Try to print what function it points to.  */
+	    print_function_pointer_address (addr, stream);
+	    /* Return value is irrelevant except for string pointers.  */
+	    return (0);
+	  }
+
+	if (addressprint && format != 's')
+	  {
+	    fputs_filtered (paddress (address), stream);
+	  }
+
+	/* For a pointer to char or unsigned char, also print the string
+	   pointed to, unless pointer is null.  */
+
+	if (TYPE_LENGTH (elttype) == 1
+	    && TYPE_CODE (elttype) == TYPE_CODE_INT
+	    && (format == 0 || format == 's')
+	    && addr != 0)
+	  {
+	    i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
+	  }
+
+	/* Return number of characters printed, including the terminating
+	   '\0' if we reached the end.  val_print_string takes care including
+	   the terminating '\0' if necessary.  */
+	return i;
+      }
+      break;
+
+    case TYPE_CODE_MEMBER:
+      error (_("not implemented: member type in m2_val_print"));
+      break;
+
+    case TYPE_CODE_REF:
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+      if (addressprint)
+	{
+	  CORE_ADDR addr
+	    = extract_typed_address (valaddr + embedded_offset, type);
+	  fprintf_filtered (stream, "@");
+	  fputs_filtered (paddress (addr), stream);
+	  if (deref_ref)
+	    fputs_filtered (": ", stream);
+	}
+      /* De-reference the reference.  */
+      if (deref_ref)
+	{
+	  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
+	    {
+	      struct value *deref_val =
+	      value_at
+	      (TYPE_TARGET_TYPE (type),
+	       unpack_pointer (lookup_pointer_type (builtin_type_void),
+			       valaddr + embedded_offset));
+	      common_val_print (deref_val, stream, format, deref_ref,
+				recurse, pretty);
+	    }
+	  else
+	    fputs_filtered ("???", stream);
+	}
+      break;
+
+    case TYPE_CODE_UNION:
+      if (recurse && !unionprint)
+	{
+	  fprintf_filtered (stream, "{...}");
+	  break;
+	}
+      /* Fall through.  */
+    case TYPE_CODE_STRUCT:
+      if (m2_is_long_set (type))
+	m2_print_long_set (type, valaddr, embedded_offset, address, stream, format,
+			   pretty);
+      else
+	cp_print_value_fields (type, type, valaddr, embedded_offset, address, stream, format,
+			       recurse, pretty, NULL, 0);
+      break;
+
+    case TYPE_CODE_ENUM:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      len = TYPE_NFIELDS (type);
+      val = unpack_long (type, valaddr + embedded_offset);
+      for (i = 0; i < len; i++)
+	{
+	  QUIT;
+	  if (val == TYPE_FIELD_BITPOS (type, i))
+	    {
+	      break;
+	    }
+	}
+      if (i < len)
+	{
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	}
+      else
+	{
+	  print_longest (stream, 'd', 0, val);
+	}
+      break;
+
+    case TYPE_CODE_FUNC:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      /* FIXME, we should consider, at least for ANSI C language, eliminating
+         the distinction made between FUNCs and POINTERs to FUNCs.  */
+      fprintf_filtered (stream, "{");
+      type_print (type, "", stream, -1);
+      fprintf_filtered (stream, "} ");
+      /* Try to print what function it points to, and its address.  */
+      print_address_demangle (address, stream, demangle);
+      break;
+
+    case TYPE_CODE_BOOL:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (val == 0)
+	    fputs_filtered ("FALSE", stream);
+	  else if (val == 1)
+	    fputs_filtered ("TRUE", stream);
+	  else
+	    fprintf_filtered (stream, "%ld)", (long int) val);
+	}
+      break;
+
+    case TYPE_CODE_RANGE:
+      if (TYPE_LENGTH (type) == TYPE_LENGTH (TYPE_TARGET_TYPE (type))) {
+	m2_val_print (TYPE_TARGET_TYPE (type), valaddr, embedded_offset,
+		      address, stream, format, deref_ref, recurse, pretty);
+	break;
+      }
+      /* FIXME: create_range_type does not set the unsigned bit in a
+         range type (I think it probably should copy it from the target
+         type), so we won't print values which are too large to
+         fit in a signed integer correctly.  */
+      /* FIXME: Doesn't handle ranges of enums correctly.  (Can't just
+         print with the target type, though, because the size of our type
+         and the target type might differ).  */
+      /* FALLTHROUGH */
+
+    case TYPE_CODE_INT:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val_print_type_code_int (type, valaddr + embedded_offset, stream);
+	}
+      break;
+
+    case TYPE_CODE_CHAR:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (TYPE_UNSIGNED (type))
+	    fprintf_filtered (stream, "%u", (unsigned int) val);
+	  else
+	    fprintf_filtered (stream, "%d", (int) val);
+	  fputs_filtered (" ", stream);
+	  LA_PRINT_CHAR ((unsigned char) val, stream);
+	}
+      break;
+
+    case TYPE_CODE_FLT:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  print_floating (valaddr + embedded_offset, type, stream);
+	}
+      break;
+
+    case TYPE_CODE_METHOD:
+      break;
+
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_SET:
+      elttype = TYPE_INDEX_TYPE (type);
+      CHECK_TYPEDEF (elttype);
+      if (TYPE_STUB (elttype))
+	{
+	  fprintf_filtered (stream, _("<incomplete type>"));
+	  gdb_flush (stream);
+	  break;
+	}
+      else
+	{
+	  struct type *range = elttype;
+	  LONGEST low_bound, high_bound;
+	  int i;
+	  int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
+	  int need_comma = 0;
+
+	  if (is_bitstring)
+	    fputs_filtered ("B'", stream);
+	  else
+	    fputs_filtered ("{", stream);
+
+	  i = get_discrete_bounds (range, &low_bound, &high_bound);
+	maybe_bad_bstring:
+	  if (i < 0)
+	    {
+	      fputs_filtered (_("<error value>"), stream);
+	      goto done;
+	    }
+
+	  for (i = low_bound; i <= high_bound; i++)
+	    {
+	      int element = value_bit_index (type, valaddr + embedded_offset, i);
+	      if (element < 0)
+		{
+		  i = element;
+		  goto maybe_bad_bstring;
+		}
+	      if (is_bitstring)
+		fprintf_filtered (stream, "%d", element);
+	      else if (element)
+		{
+		  if (need_comma)
+		    fputs_filtered (", ", stream);
+		  print_type_scalar (range, i, stream);
+		  need_comma = 1;
+
+		  if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))
+		    {
+		      int j = i;
+		      fputs_filtered ("..", stream);
+		      while (i + 1 <= high_bound
+			     && value_bit_index (type, valaddr + embedded_offset, ++i))
+			j = i;
+		      print_type_scalar (range, j, stream);
+		    }
+		}
+	    }
+	done:
+	  if (is_bitstring)
+	    fputs_filtered ("'", stream);
+	  else
+	    fputs_filtered ("}", stream);
+	}
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "void");
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, _("<error type>"));
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
+         dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
+         and no complete type for struct foo in that file.  */
+      fprintf_filtered (stream, _("<incomplete type>"));
+      break;
+
+    default:
+      error (_("Invalid m2 type code %d in symbol table."), TYPE_CODE (type));
+    }
+  gdb_flush (stream);
+  return (0);
 }
--- latest-cvs-gdb/src-cvs/gdb/doc/gdb.texinfo	2006-02-10 03:54:33.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/doc/gdb.texinfo	2006-02-27 23:44:38.000000000 +0000
@@ -1,6 +1,6 @@
 \input texinfo      @c -*-texinfo-*-
 @c Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1998,
-@c 1999, 2000, 2001, 2002, 2003, 2004, 2005
+@c 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006
 @c Free Software Foundation, Inc.
 @c
 @c %**start of header
@@ -9459,6 +9459,7 @@
 * M2 Operators::                Built-in operators
 * Built-In Func/Proc::          Built-in functions and procedures
 * M2 Constants::                Modula-2 constants
+* M2 Types::                    Modula-2 types
 * M2 Defaults::                 Default settings for Modula-2
 * Deviations::                  Deviations from standard Modula-2
 * M2 Checks::                   Modula-2 type and range checks
@@ -9583,7 +9584,7 @@
 @end table
 
 @quotation
-@emph{Warning:} Sets and their operations are not yet supported, so @value{GDBN}
+@emph{Warning:} Set expressions and their operations are not yet supported, so @value{GDBN}
 treats the use of the operator @code{IN}, or the use of operators
 @code{+}, @code{-}, @code{*}, @code{/}, @code{=}, , @code{<>}, @code{#},
 @code{<=}, and @code{>=} on sets as an error.
@@ -9752,6 +9753,165 @@
 Set constants are not yet supported.
 @end itemize
 
+@node M2 Types
+@subsubsection Modula-2 Types
+@cindex Modula-2 types
+
+Currently @value{GDBN} can print the following data types in Modula-2
+syntax: array types, record types, set types, pointer types, procedure
+types, enumerated types, subrange types and base types.  Values of
+these types may also be printed.  So for example, if you compile the
+following section of code:
+
+@example
+VAR
+   s: SET OF CHAR ;
+   r: [20..40] ;
+@end example
+
+@noindent
+you could request @value{GDBN} to interrogate the type and value of
+@code{r} and @code{s}.
+
+@example
+(@value{GDBP}) print s
+@{'A'..'C', 'Z'@}
+(@value{GDBP}) ptype s
+SET OF CHAR
+(@value{GDBP}) print r
+21
+(@value{GDBP}) ptype r
+[20..40]
+@end example
+
+@noindent
+Likewise if the source code declared @code{s} as:
+
+@example
+VAR
+   s: SET ['A'..'Z'] ;
+@end example
+
+@noindent
+you can query the type of @code{s} via:
+
+@example
+(@value{GDBP}) ptype s
+type = SET ['A'..'Z']
+@end example
+
+Note that at present @value{GDBN} does not support interactive
+manipulation of set expressions.  However the debugger does understand
+the declaration of Modula-2 arrays.  For example, this code fragment
+describes the declaration of @code{s}.
+
+@example
+VAR
+   s: ARRAY [-10..10] OF CHAR ;
+@end example
+
+@noindent
+and @value{GDBN} now sees this information.
+
+@example
+(@value{GDBP}) ptype s
+ARRAY [-10..10] OF CHAR
+@end example
+
+It is advisable to use the following compile flags on the @code{gm2}
+command line @option{-gdwarf-2}.  Also note that the array handling is
+not yet complete and although the type is printed correctly, the
+expression handling still assumes that all arrays have a lower bound
+of zero and not @code{-10} in the case above.  Unbounded arrays are
+also not yet recognised in @value{GDBN}.  Here follows some more type
+related Modula-2 examples:
+
+@example
+TYPE
+   colour = (blue, red, yellow, green) ;
+   t = [blue..yellow] ;
+VAR
+   s: t ;
+BEGIN
+   s := blue ;
+@end example
+
+The @value{GDBN} interaction shows that the correct value and type
+can be obtained.
+
+@example
+(@value{GDBP}) print s
+$1 = blue
+(@value{GDBP}) ptype t
+type = [blue..yellow]
+@end example
+
+In this example a Modula-2 array is declared and its contents
+displayed.  Observe that the contents are written in the same
+way as their @code{C} counterparts.
+
+@example
+VAR
+   s: ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   s[1] := 1 ;
+@end example
+
+@example
+(@value{GDBP}) print s
+$1 = @{1, 0, 0, 0, 0@}
+(@value{GDBP}) ptype s
+type = ARRAY [1..5] OF CARDINAL
+@end example
+
+The Modula-2 language interface to @value{GDBN} also understands
+pointer types as shown in this example:
+
+@example
+VAR
+   s: POINTER TO ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   NEW(s) ;
+   s^[1] := 1 ;
+@end example
+
+@noindent
+and you can request that @value{GDBN} describes the type of @code{s}.
+
+@example
+(@value{GDBP}) ptype s
+type = POINTER TO ARRAY [1..5] OF CARDINAL
+@end example
+
+More complex types are also handled by @value{GDBN}, in this example
+we combine array types, record types, pointer types and subrange
+types.
+
+@example
+TYPE
+   foo = RECORD
+            f1: CARDINAL ;
+            f2: CHAR ;
+            f3: myarray ;
+         END ;
+
+   myarray = ARRAY myrange OF CARDINAL ;
+   myrange = [-2..2] ;
+VAR
+   s: POINTER TO ARRAY myrange OF foo ;
+@end example
+
+Once again you can ask @value{GDBN} to describe the type of @code{s}.
+
+@example
+(@value{GDBP}) ptype s
+type = POINTER TO ARRAY [-2..2] OF foo = RECORD
+    f1 : CARDINAL;
+    f2 : CHAR;
+    f3 : ARRAY [-2..2] OF CARDINAL;
+END 
+@end example
+
 @node M2 Defaults
 @subsubsection Modula-2 defaults
 @cindex Modula-2 defaults

Re: Enhanced language support for Modula-2

[Jim Blandy]

On 28 Feb 2006 01:47:51 +0000, Gaius Mulley <gaius@glam.ac.uk> wrote:
> sure, ok.  Here is the patch again with all issues addressed from the
> last set of email responses.

Hi, Gaius.  Thanks for the revisions.

- It's true that there are a few regression failures that are
intermittent; these are an annoyance that we haven't gotten around to
fixing for a long time.  The way I generally look for regressions is
to run the test suite before and after, and compare the two gdb.sum
files using diff -u.  I ignore differences in the thread tests, or in
the signal-handling tests in the annotation test scripts.  If you find
other differences and you're not sure if they're regressions or not,
post them here.

- You need to post a ChangeLog entry along with your patch.

I have some futher comments mixed in with the patch below.

> --- latest-cvs-gdb/src-cvs/gdb/m2-typeprint.c   2005-12-17 22:34:01.000000000 +0000
> +++ latest-cvs-gdb/src-m2/gdb/m2-typeprint.c    2006-02-27 23:21:59.000000000 +0000
...
> +    case TYPE_CODE_ENUM:
> +      m2_type_print_modifier (type, stream, 0, 1);
> +      /* HP C supports sized enums */
> +      if (deprecated_hp_som_som_object_present)

Adding new references to deprecated variables or functions is frowned
on.  These are bits of interface that we've decided we'd like to get
rid of over time; every new use is another case that someone trying to
remove the variable/function needs to consider and understand.

Also, this code looks like it's cut-and-paste from c-typeprint.c; does
HP C (also known as aCC) generate Modula-2 code?  Can't all this just
go away?

In general, I'm surprised at the structure of the type printing code. 
All this varspec prefix and varspec suffix crud is there to deal with
C's weird pseudo-algebraic type syntax, where the parse tree is the
reverse of the natural type tree.  Surely Modula-2 doesn't imitate
that --- does it?  Couldn't Modula's types be printed with a
straightforward tree walk?  Apologies if you've explained this before.

> --- latest-cvs-gdb/src-cvs/gdb/dwarf2read.c     2006-02-09 18:18:41.000000000 +0000
> +++ latest-cvs-gdb/src-m2/gdb/dwarf2read.c      2006-02-27 23:55:12.000000000 +0000
> @@ -4728,10 +4743,17 @@
>           code = TYPE_CODE_FLT;
>           break;
>         case DW_ATE_signed:
> -       case DW_ATE_signed_char:
>           break;
>         case DW_ATE_unsigned:
> -       case DW_ATE_unsigned_char:
> +         type_flags |= TYPE_FLAG_UNSIGNED;
> +         break;
> +       case DW_ATE_signed_char:
> +         if (cu->language == language_m2)
> +           code = TYPE_CODE_CHAR;
> +         break;
> +       case DW_ATE_unsigned_char:
> +         if (cu->language == language_m2)
> +           code = TYPE_CODE_CHAR;
>           type_flags |= TYPE_FLAG_UNSIGNED;
>           break;
>         default:

This is what I had in mind --- thanks.

> @@ -6146,6 +6168,10 @@
>  {
>    switch (lang)
>      {
> +    case DW_LANG_Ada83:
> +    case DW_LANG_Ada95:
> +      cu->language = language_ada;
> +      break;
>      case DW_LANG_C89:
>      case DW_LANG_C:
>        cu->language = language_c;

If you want to rearrange things, please submit that as a separate
patch.  If Modula-2 patch simply improves the Modula-2 support, and
nothing else, that makes it easier to review.

> @@ -6153,25 +6179,29 @@
>      case DW_LANG_C_plus_plus:
>        cu->language = language_cplus;
>        break;
> +    case DW_LANG_Cobol74:
> +      cu->language = DW_LANG_Cobol74;
> +      break;
> +    case DW_LANG_Cobol85:
> +      cu->language = DW_LANG_Cobol85;
> +      break;

Was this code here before?  I'm sorry I didn't catch it the first
time.  You can't use DWARF language constants as values for
cu->language; that's GDB's internal 'enum language'.  They're
completely different enums.

> @@ -7337,7 +7371,8 @@
>    struct die_info *parent;
>
>    if (cu->language != language_cplus
> -      && cu->language != language_java)
> +      && cu->language != language_java
> +      && cu->language != language_pascal)

Pascal?  Does this belong here?

> --- latest-cvs-gdb/src-cvs/gdb/doc/gdb.texinfo  2006-02-10 03:54:33.000000000 +0000
> +++ latest-cvs-gdb/src-m2/gdb/doc/gdb.texinfo   2006-02-27 23:44:38.000000000 +0000
> +Currently @value{GDBN} can print the following data types in Modula-2
> +syntax: array types, record types, set types, pointer types, procedure
> +types, enumerated types, subrange types and base types.  Values of
> +these types may also be printed.

Here's another use of the passive voice: "@value{GDBN} can also print
values of these types."

> +It is advisable to use the following compile flags on the @code{gm2}
> +command line @option{-gdwarf-2}.

Eli pointed this out before.  I think you mean, "We recommend that you
pass the @option{-gdwarf-2} option to @code{gm2} when compiling code
you intend to debug with @value{GDBN}.

  Also note that the array handling is
> +not yet complete and although the type is printed correctly, the
> +expression handling still assumes that all arrays have a lower bound
> +of zero and not @code{-10} in the case above.  Unbounded arrays are
> +also not yet recognised in @value{GDBN}.  Here follows some more type

"Here follow"

> +related Modula-2 examples:
> +
> +@example
> +TYPE
> +   colour = (blue, red, yellow, green) ;
> +   t = [blue..yellow] ;
> +VAR
> +   s: t ;
> +BEGIN
> +   s := blue ;
> +@end example
> +
> +The @value{GDBN} interaction shows that the correct value and type
> +can be obtained.

Eli has approved this, so what I say here is just a suggestion:

The way this is written gives me the impression that GDB used to
handle this poorly, but now handles it correctly.  While that's great,
the GDB manual isn't the place to describe the progression of bug
fixes; it should simply describe the way GDB works now, as for a
reader encountering GDB for the first time.  (You can describe
important bug fixes in gdb/NEWS.)  Should this example of type
printing simply be appended to the preceding series?

The notes about using -gdwarf-2 could go to the end of the page, or
perhaps be moved to @node Compilation, along with similar advice for
other languages.

> +In this example a Modula-2 array is declared and its contents
> +displayed.  Observe that the contents are written in the same
> +way as their @code{C} counterparts.

More use of the passive voice.

Passive voice sentences have the form "X is Y-ed by Z", with the "by
Z" part often omitted.  You can rephrase these, almost mechanically,
as "Z Y-s X."  When you've omitted Z in the original, you have to make
a Z up for use in the rephrased sentence.

> +More complex types are also handled by @value{GDBN}, in this example
> +we combine array types, record types, pointer types and subrange
> +types.

This is another use of the passive voice.  Also, that first comma
should be a period, and "in this example" should be the start of a new
sentence.

Re: Enhanced language support for Modula-2

[Gaius Mulley]

"Jim Blandy" <jimb@red-bean.com> writes:

> - You need to post a ChangeLog entry along with your patch.

> I have some futher comments mixed in with the patch below.

ok, will do..

> Adding new references to deprecated variables or functions is frowned
> on.  These are bits of interface that we've decided we'd like to get
> rid of over time; every new use is another case that someone trying to
> remove the variable/function needs to consider and understand.

ok,

> Also, this code looks like it's cut-and-paste from c-typeprint.c; does
> HP C (also known as aCC) generate Modula-2 code?  Can't all this just
> go away?

yes I think it can..

> In general, I'm surprised at the structure of the type printing code. 
> All this varspec prefix and varspec suffix crud is there to deal with
> C's weird pseudo-algebraic type syntax, where the parse tree is the
> reverse of the natural type tree.  Surely Modula-2 doesn't imitate
> that --- does it?  Couldn't Modula's types be printed with a
> straightforward tree walk?  Apologies if you've explained this
> before.

the tree walk approach would be much cleaner - and much shorter - I'll
re-implement m2-typeprint.c accordingly.  I originally kept it (cut and
paste) the same as c-typeprint.c, to preserve any debugging
information which Modula-2 does not use, which would allow users to

set lang m2
print s

and see language differences with maybe non m2 constructs written in
C.  I now think this idea is ugly :-) and probably serves little
purpose and would cause confusion anyhow. Now that dwarf2read.c takes
a different approach w.r.t CHAR and char the mixed language approach
makes even less sense.

> 
> > @@ -6153,25 +6179,29 @@
> >      case DW_LANG_C_plus_plus:
> >        cu->language = language_cplus;
> >        break;
> > +    case DW_LANG_Cobol74:
> > +      cu->language = DW_LANG_Cobol74;
> > +      break;
> > +    case DW_LANG_Cobol85:
> > +      cu->language = DW_LANG_Cobol85;
> > +      break;
> 
> Was this code here before?  I'm sorry I didn't catch it the first
> time.  You can't use DWARF language constants as values for
> cu->language; that's GDB's internal 'enum language'.  They're
> completely different enums.

oops terribly sorry, awful mistake..

Thanks for the suggestions about gdb.texinfo and the guidance in
general, - I'll work on all these issues and resubmit in a week or
two.

regards,
Gaius

Re: Enhanced language support for Modula-2

[Jim Blandy]

On 02 Mar 2006 08:54:29 +0000, Gaius Mulley <gaius@glam.ac.uk> wrote:
> Thanks for the suggestions about gdb.texinfo and the guidance in
> general, - I'll work on all these issues and resubmit in a week or
> two.

Great --- I'll look forward to it.  Thanks for your work on the
Modula-2 support!

Re: Enhanced language support for Modula-2

[Gaius Mulley]

Jim Blandy <jimb@codesourcery.com> writes:

> Joel Brobecker <brobecker@adacore.com> writes:
> > Even though you won't need to re-send the new patch, could you send
> > a small message confirming that the patch has been checked in after
> > you receive commit access? This is the last change I'm waiting for
> > before creating the 6.5 branch for the next GDB release.
> 
> Oh, yes: it's generally useful to post a "Committed" message after
> committing an approved patch.

ok thanks, will do,

regards,
Gaius

Re: Enhanced language support for Modula-2

[Gaius Mulley]

Joel Brobecker <brobecker@adacore.com> writes:

> Gaius,
> 
> Even though you won't need to re-send the new patch, could you send
> a small message confirming that the patch has been checked in after
> you receive commit access? This is the last change I'm waiting for
> before creating the 6.5 branch for the next GDB release.
> 
> Thank you,
> -- 
> Joel

Hi Joel,

sure will do.. hopefully later today..

regards,
Gaius

Re: Enhanced language support for Modula-2

[Jim Blandy]

Joel Brobecker <brobecker@adacore.com> writes:
> Even though you won't need to re-send the new patch, could you send
> a small message confirming that the patch has been checked in after
> you receive commit access? This is the last change I'm waiting for
> before creating the 6.5 branch for the next GDB release.

Oh, yes: it's generally useful to post a "Committed" message after
committing an approved patch.

Re: Enhanced language support for Modula-2

[Joel Brobecker]

Gaius,

Even though you won't need to re-send the new patch, could you send
a small message confirming that the patch has been checked in after
you receive commit access? This is the last change I'm waiting for
before creating the 6.5 branch for the next GDB release.

Thank you,
-- 
Joel

Re: Enhanced language support for Modula-2

[Gaius Mulley]

Jim Blandy <jimb@codesourcery.com> writes:

> > also enclosed is a proposed set of ChangeLog entries:
> 
> Looks great!

thanks..

> Two points to fix when you commit; don't bother re-posting the patch
> for review:
> 
> - There's still an overly long line in m2-valprint.c, in the
>   TYPE_CODE_STRUCT case.

ok I'll fix it..

> - Similarly, there's a separate ChangeLog for the doc directory; the
>   entry for your change to gdb.texinfo should go in gdb/doc/ChangeLog,
>   not gdb/ChangeLog.  And generally, we put section names in parens
>   after the filename, as we do for functions in C files.  Like so:
> 
>       * gdb.texinfo (M2 Types): New section.

ok.

> I see that you have a copyright assignment on file.  Do you have
> commit access to GDB?  If not, we'll have to get you set up with that
> first.

no I don't have commit access. Commit access would be great, thanks.

> If you do, then make a commit to gdb/MAINTAINERS, adding yourself to
> "Write After Approval", with an appropriate ChangeLog entry.  Then go
> ahead and commit the rest of the patch.

sure, will do.

regards,
Gaius

Re: Enhanced language support for Modula-2

[Jim Blandy]

Gaius Mulley <gaius@glam.ac.uk> writes:
> Jim Blandy <jimb@codesourcery.com> writes:
>
>> Have you written ChangeLog entries for this?  Follow the format the
>> other entries use.
>> 
>> In GDB code, each curly brace gets a line to itself.  I see a few
>> sharing a line with an 'if' or 'else' in m2-valprint.c and
>> m2-typeprint.c.
>
> Hi Jim and Eli,
>
> sure ok, have done..
>
>> Also, all GNU code should fit in eighty columns.
>
> ok, now fixed..
>
>> I see some indentation problems in m2_val_print.  If you're using GNU
>> Emacs, just hit M-C-q before the function's opening brace, and it'll
>> take care of it.
>
> yes I use emacs for most things.. but I hadn't come across this short
> cut though.. very useful and I believe all is now fixed..
>
>
>
> also enclosed is a proposed set of ChangeLog entries:

Looks great!

Two points to fix when you commit; don't bother re-posting the patch
for review:

- There's still an overly long line in m2-valprint.c, in the
  TYPE_CODE_STRUCT case.

- Similarly, there's a separate ChangeLog for the doc directory; the
  entry for your change to gdb.texinfo should go in gdb/doc/ChangeLog,
  not gdb/ChangeLog.  And generally, we put section names in parens
  after the filename, as we do for functions in C files.  Like so:

      * gdb.texinfo (M2 Types): New section.

I see that you have a copyright assignment on file.  Do you have
commit access to GDB?  If not, we'll have to get you set up with that
first.

If you do, then make a commit to gdb/MAINTAINERS, adding yourself to
"Write After Approval", with an appropriate ChangeLog entry.  Then go
ahead and commit the rest of the patch.

Re: Enhanced language support for Modula-2

[Gaius Mulley]

[-- Attachment #1: Type: text/plain, Size: 686 bytes --]

Jim Blandy <jimb@codesourcery.com> writes:

> Have you written ChangeLog entries for this?  Follow the format the
> other entries use.
> 
> In GDB code, each curly brace gets a line to itself.  I see a few
> sharing a line with an 'if' or 'else' in m2-valprint.c and
> m2-typeprint.c.

Hi Jim and Eli,

sure ok, have done..

> Also, all GNU code should fit in eighty columns.

ok, now fixed..

> I see some indentation problems in m2_val_print.  If you're using GNU
> Emacs, just hit M-C-q before the function's opening brace, and it'll
> take care of it.

yes I use emacs for most things.. but I hadn't come across this short
cut though.. very useful and I believe all is now fixed..


[-- Attachment #2: enhanced Modula-2 mode for gdb --]
[-- Type: application/octet-stream, Size: 40349 bytes --]

--- latest-cvs-gdb/src-cvs/gdb/m2-lang.h	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-lang.h	2006-05-09 21:15:57.000000000 +0100
@@ -27,6 +27,11 @@
 extern void m2_print_type (struct type *, char *, struct ui_file *, int,
 			   int);
 
+extern int m2_is_long_set (struct type *type);
+
 extern int m2_val_print (struct type *, const gdb_byte *, int, CORE_ADDR,
 			 struct ui_file *, int, int, int,
 			 enum val_prettyprint);
+
+extern int get_long_set_bounds (struct type *type, LONGEST *low,
+				LONGEST *high);
--- latest-cvs-gdb/src-cvs/gdb/m2-typeprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-typeprint.c	2006-05-09 22:45:54.000000000 +0100
@@ -1,5 +1,6 @@
 /* Support for printing Modula 2 types for GDB, the GNU debugger.
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    This file is part of GDB.
@@ -20,22 +21,554 @@
    Boston, MA 02110-1301, USA.  */
 
 #include "defs.h"
+#include "gdb_obstack.h"
 #include "bfd.h"		/* Binary File Description */
 #include "symtab.h"
 #include "gdbtypes.h"
 #include "expression.h"
 #include "value.h"
 #include "gdbcore.h"
-#include "target.h"
 #include "m2-lang.h"
+#include "target.h"
+#include "language.h"
+#include "demangle.h"
+#include "c-lang.h"
+#include "typeprint.h"
+#include "cp-abi.h"
+
+#include "gdb_string.h"
 #include <errno.h>
 
+static void m2_print_bounds (struct type *type,
+			     struct ui_file *stream, int show, int level,
+			     int print_high);
+
+static void m2_typedef (struct type *, struct ui_file *, int, int);
+static void m2_array (struct type *, struct ui_file *, int, int);
+static void m2_pointer (struct type *, struct ui_file *, int, int);
+static void m2_ref (struct type *, struct ui_file *, int, int);
+static void m2_procedure (struct type *, struct ui_file *, int, int);
+static void m2_union (struct type *, struct ui_file *);
+static void m2_enum (struct type *, struct ui_file *, int, int);
+static void m2_range (struct type *, struct ui_file *, int, int);
+static void m2_type_name (struct type *type, struct ui_file *stream);
+static void m2_short_set (struct type *type, struct ui_file *stream,
+			  int show, int level);
+static int m2_long_set (struct type *type, struct ui_file *stream,
+			int show, int level);
+static void m2_record_fields (struct type *type, struct ui_file *stream,
+			      int show, int level);
+static void m2_unknown (const char *s, struct type *type,
+			struct ui_file *stream, int show, int level);
+
+int m2_is_long_set (struct type *type);
+int m2_is_long_set_of_type (struct type *type, struct type **of_type);
+
+
 void
 m2_print_type (struct type *type, char *varstring, struct ui_file *stream,
 	       int show, int level)
 {
-  extern void c_print_type (struct type *, char *, struct ui_file *, int,
-			    int);
+  enum type_code code;
+  int demangled_args;
+
+  CHECK_TYPEDEF (type);
+  code = TYPE_CODE (type);
+
+  QUIT;
+
+  wrap_here ("    ");
+  if (type == NULL)
+    {
+      fputs_filtered (_("<type unknown>"), stream);
+      return;
+    }
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_SET:
+      m2_short_set(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_STRUCT:
+      if (m2_long_set (type, stream, show, level))
+	break;
+      m2_record_fields (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_TYPEDEF:
+      m2_typedef (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_ARRAY:
+      m2_array (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_PTR:
+      m2_pointer (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_REF:
+      m2_ref (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_MEMBER:
+      m2_unknown (_("member"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_METHOD:
+      m2_unknown (_("method"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_FUNC:
+      m2_procedure (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_UNION:
+      m2_union (type, stream);
+      break;
+
+    case TYPE_CODE_ENUM:
+      m2_enum (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_VOID:
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* i18n: Do not translate the "struct" part! */
+      m2_unknown (_("undef"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_ERROR:
+      m2_unknown (_("error"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_RANGE:
+      m2_range (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_TEMPLATE:
+      break;
+
+    default:
+      m2_type_name (type, stream);
+      break;
+    }
+}
+
+/*
+ *  m2_type_name - if a, type, has a name then print it.
+ */
+
+void
+m2_type_name (struct type *type, struct ui_file *stream)
+{
+  if (TYPE_NAME (type) != NULL)
+    fputs_filtered (TYPE_NAME (type), stream);
+}
+
+/*
+ *  m2_range - displays a Modula-2 subrange type.
+ */
+
+void
+m2_range (struct type *type, struct ui_file *stream, int show,
+	  int level)
+{
+  if (TYPE_HIGH_BOUND (type) == TYPE_LOW_BOUND (type))
+    m2_print_type (TYPE_DOMAIN_TYPE (type), "", stream, show, level);
+  else
+    {
+      struct type *target = TYPE_TARGET_TYPE (type);
+
+      fprintf_filtered (stream, "[");
+      print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+      fprintf_filtered (stream, "..");
+      print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+      fprintf_filtered (stream, "]");
+    }
+}
+
+static void
+m2_typedef (struct type *type, struct ui_file *stream, int show,
+	    int level)
+{
+  if (TYPE_NAME (type) != NULL)
+    {
+      fputs_filtered (TYPE_NAME (type), stream);
+      fputs_filtered (" = ", stream);
+    }
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+/*
+ *  m2_array - prints out a Modula-2 ARRAY ... OF type
+ */
+
+static void m2_array (struct type *type, struct ui_file *stream,
+		      int show, int level)
+{
+  fprintf_filtered (stream, "ARRAY [");
+  if (TYPE_LENGTH (type) >= 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0
+      && TYPE_ARRAY_UPPER_BOUND_TYPE (type) != BOUND_CANNOT_BE_DETERMINED)
+    {
+      if (TYPE_INDEX_TYPE (type) != 0)
+	{
+	  m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 0);
+	  fprintf_filtered (stream, "..");
+	  m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 1);
+	}
+      else
+	fprintf_filtered (stream, "%d",
+			  (TYPE_LENGTH (type)
+			   / TYPE_LENGTH (TYPE_TARGET_TYPE (type))));
+    }
+  fprintf_filtered (stream, "] OF ");
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+static void
+m2_pointer (struct type *type, struct ui_file *stream, int show,
+	    int level)
+{
+  if (TYPE_CONST (type))
+    fprintf_filtered (stream, "[...] : ");
+  else
+    fprintf_filtered (stream, "POINTER TO ");
+
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+static void
+m2_ref (struct type *type, struct ui_file *stream, int show,
+	int level)
+{
+  fprintf_filtered (stream, "VAR");
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+static void
+m2_unknown (const char *s, struct type *type, struct ui_file *stream,
+	    int show, int level)
+{
+  fprintf_filtered (stream, "%s %s", s, _("is unknown"));
+}
+
+static void m2_union (struct type *type, struct ui_file *stream)
+{
+  fprintf_filtered (stream, "union");
+}
+
+static void
+m2_procedure (struct type *type, struct ui_file *stream,
+	      int show, int level)
+{
+  fprintf_filtered (stream, "PROCEDURE ");
+  m2_type_name (type, stream);
+  if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
+    {
+      int i, len = TYPE_NFIELDS (type);
+
+      fprintf_filtered (stream, " (");
+      for (i = 0; i < len; i++)
+	{
+	  if (i > 0)
+	    {
+	      fputs_filtered (", ", stream);
+	      wrap_here ("    ");
+	    }
+	  m2_print_type (TYPE_FIELD_TYPE (type, i), "", stream, -1, 0);
+	}
+      if (TYPE_TARGET_TYPE (type) != NULL)
+	{
+	  fprintf_filtered (stream, " : ");
+	  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, 0, 0);
+	}
+    }
+}
+
+static void
+m2_print_bounds (struct type *type,
+		 struct ui_file *stream, int show, int level,
+		 int print_high)
+{
+  struct type *target = TYPE_TARGET_TYPE (type);
+
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (TYPE_NFIELDS(type) == 0)
+    return;
+
+  if (print_high)
+    print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+  else
+    print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+}
+
+static void
+m2_short_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  fprintf_filtered(stream, "SET [");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 0);
+
+  fprintf_filtered(stream, "..");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 1);
+  fprintf_filtered(stream, "]");
+}
+
+int
+m2_is_long_set (struct type *type)
+{
+  LONGEST previous_high = 0;  /* unnecessary initialization
+				 keeps gcc -Wall happy */
+  int len, i;
+  struct type *range;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
+    {
+
+      /*
+       *  check if all fields of the RECORD are consecutive sets
+       */
+      len = TYPE_NFIELDS (type);
+      for (i = TYPE_N_BASECLASSES (type); i < len; i++)
+	{
+	  if (TYPE_FIELD_TYPE (type, i) == NULL)
+	    return 0;
+	  if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) != TYPE_CODE_SET)
+	    return 0;
+	  if (TYPE_FIELD_NAME (type, i) != NULL
+	      && (strcmp (TYPE_FIELD_NAME (type, i), "") != 0))
+	    return 0;
+	  range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+	  if ((i > TYPE_N_BASECLASSES (type))
+	      && previous_high + 1 != TYPE_LOW_BOUND (range))
+	    return 0;
+	  previous_high = TYPE_HIGH_BOUND (range);
+	}
+      return len>0;
+    }
+  return 0;
+}
+
+/*
+ *  m2_get_discrete_bounds - a wrapper for get_discrete_bounds which
+ *                           understands that CHARs might be signed.
+ *                           This should be integrated into gdbtypes.c
+ *                           inside get_discrete_bounds.
+ */
+
+int
+m2_get_discrete_bounds (struct type *type, LONGEST *lowp, LONGEST *highp)
+{
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_CHAR:
+      if (TYPE_LENGTH (type) < sizeof (LONGEST))
+	{
+	  if (!TYPE_UNSIGNED (type))
+	    {
+	      *lowp = -(1 << (TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1));
+	      *highp = -*lowp - 1;
+	      return 0;
+	    }
+	}
+      /* fall through */
+    default:
+      return get_discrete_bounds (type, lowp, highp);
+    }
+}
+
+/*
+ *  m2_is_long_set_of_type - returns TRUE if the long set was declared as
+ *                           SET OF <oftype> of_type is assigned to the
+ *                           subtype.
+ */
+
+int
+m2_is_long_set_of_type (struct type *type, struct type **of_type)
+{
+  int len, i;
+  struct type *range;
+  struct type *target;
+  LONGEST l1, l2;
+  LONGEST h1, h2;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
+    {
+      len = TYPE_NFIELDS (type);
+      i = TYPE_N_BASECLASSES (type);
+      if (len == 0)
+	return 0;
+      range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+      target = TYPE_TARGET_TYPE (range);
+      if (target == NULL)
+	target = builtin_type_int;
+
+      l1 = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+      h1 = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+      *of_type = target;
+      if (m2_get_discrete_bounds (target, &l2, &h2) >= 0)
+	return (l1 == l2 && h1 == h2);
+      error (_("long_set failed to find discrete bounds for its subtype"));
+      return 0;
+    }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static int
+m2_long_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  struct type *index_type;
+  struct type *range_type;
+  struct type *of_type;
+  int i;
+  int len = TYPE_NFIELDS (type);
+  LONGEST low;
+  LONGEST high;
+
+  if (m2_is_long_set (type))
+    {
+      if (TYPE_TAG_NAME (type) != NULL)
+	{
+	  fputs_filtered (TYPE_TAG_NAME (type), stream);
+	  if (show == 0)
+	    return 1;
+	}
+      else if (TYPE_NAME (type) != NULL)
+	{
+	  fputs_filtered (TYPE_NAME (type), stream);
+	  if (show == 0)
+	    return 1;
+	}
+
+      if (TYPE_TAG_NAME (type) != NULL || TYPE_NAME (type) != NULL)
+	fputs_filtered (" = ", stream);
+
+      if (get_long_set_bounds (type, &low, &high))
+	{
+	  fprintf_filtered(stream, "SET OF ");
+	  i = TYPE_N_BASECLASSES (type);
+	  if (m2_is_long_set_of_type (type, &of_type))
+	    m2_print_type (of_type, "", stream, show - 1, level);
+	  else
+	    {
+	      fprintf_filtered(stream, "[");
+	      m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)),
+			       stream, show - 1, level, 0);
+
+	      fprintf_filtered(stream, "..");
+
+	      m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)),
+			       stream, show - 1, level, 1);
+	      fprintf_filtered(stream, "]");
+	    }
+	}
+      else
+	/* i18n: Do not translate the "SET OF" part! */
+	fprintf_filtered(stream, _("SET OF <unknown>"));
+
+      return 1;
+    }
+  return 0;
+}
+
+void
+m2_record_fields (struct type *type, struct ui_file *stream, int show,
+		  int level)
+{
+  /* Print the tag if it exists. 
+   */
+  if (TYPE_TAG_NAME (type) != NULL)
+    {
+      if (strncmp (TYPE_TAG_NAME (type), "$$", 2) != 0)
+	{
+	  fputs_filtered (TYPE_TAG_NAME (type), stream);
+	  if (show > 0)
+	    fprintf_filtered (stream, " = ");
+	}
+    }
+  wrap_here ("    ");
+  if (show < 0)
+    {
+      if (TYPE_CODE (type) == DECLARED_TYPE_STRUCT)
+	fprintf_filtered (stream, "RECORD ... END ");
+      else if (TYPE_DECLARED_TYPE (type) == DECLARED_TYPE_UNION)
+	fprintf_filtered (stream, "CASE ... END ");
+    }
+  else if (show > 0)
+    {
+      if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
+	fprintf_filtered (stream, "RECORD\n");
+      else if (TYPE_CODE (type) == TYPE_CODE_UNION)
+	/* i18n: Do not translate "CASE" and "OF" */
+	fprintf_filtered (stream, _("CASE <variant> OF\n"));
+      int i;
+      int len = TYPE_NFIELDS (type);
+
+      for (i = TYPE_N_BASECLASSES (type); i < len; i++)
+	{
+	  QUIT;
+
+	  print_spaces_filtered (level + 4, stream);
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	  fputs_filtered (" : ", stream);
+	  m2_print_type (TYPE_FIELD_TYPE (type, i),
+			 "",
+			 stream, 0, level + 4);
+	  if (TYPE_FIELD_PACKED (type, i))
+	    {
+	      /* It is a bitfield.  This code does not attempt
+		 to look at the bitpos and reconstruct filler,
+		 unnamed fields.  This would lead to misleading
+		 results if the compiler does not put out fields
+		 for such things (I don't know what it does).  */
+	      fprintf_filtered (stream, " : %d",
+				TYPE_FIELD_BITSIZE (type, i));
+	    }
+	  fprintf_filtered (stream, ";\n");
+	}
+      
+      fprintfi_filtered (level, stream, "END ");
+    }
+}
+
+void
+m2_enum (struct type *type, struct ui_file *stream, int show, int level)
+{
+  int lastval, i, len;
 
-  c_print_type (type, varstring, stream, show, level);	/* FIXME */
+  if (show < 0)
+    {
+      /* If we just printed a tag name, no need to print anything else.  */
+      if (TYPE_TAG_NAME (type) == NULL)
+	fprintf_filtered (stream, "(...)");
+    }
+  else if (show > 0 || TYPE_TAG_NAME (type) == NULL)
+    {
+      fprintf_filtered (stream, "(");
+      len = TYPE_NFIELDS (type);
+      lastval = 0;
+      for (i = 0; i < len; i++)
+	{
+	  QUIT;
+	  if (i > 0)
+	    fprintf_filtered (stream, ", ");
+	  wrap_here ("    ");
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	  if (lastval != TYPE_FIELD_BITPOS (type, i))
+	    {
+	      fprintf_filtered (stream, " = %d", TYPE_FIELD_BITPOS (type, i));
+	      lastval = TYPE_FIELD_BITPOS (type, i);
+	    }
+	  lastval++;
+	}
+      fprintf_filtered (stream, ")");
+    }
 }
--- latest-cvs-gdb/src-cvs/gdb/dwarf2read.c	2006-05-06 01:14:03.000000000 +0100
+++ latest-cvs-gdb/src-m2/gdb/dwarf2read.c	2006-05-09 21:15:57.000000000 +0100
@@ -1,7 +1,7 @@
 /* DWARF 2 debugging format support for GDB.
 
-   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-   2004, 2005, 2006
+   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    Adapted by Gary Funck (gary@intrepid.com), Intrepid Technology,
@@ -1073,6 +1073,9 @@
 
 static void dwarf2_clear_marks (struct dwarf2_per_cu_data *);
 
+static void read_set_type (struct die_info *, struct dwarf2_cu *);
+
+
 /* Try to locate the sections we need for DWARF 2 debugging
    information and return true if we have enough to do something.  */
 
@@ -2662,6 +2665,9 @@
     case DW_TAG_subroutine_type:
       read_subroutine_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
@@ -4240,6 +4246,15 @@
     };
 }
 
+/* Extract all information from a DW_TAG_set_type DIE and put it in
+   the DIE's type field. */
+
+static void
+read_set_type (struct die_info *die, struct dwarf2_cu *cu)
+{
+  if (die->type == NULL)
+    die->type = create_set_type ((struct type *) NULL, die_type (die, cu));
+}
 
 /* First cut: install each common block member as a global variable.  */
 
@@ -4728,10 +4743,17 @@
 	  code = TYPE_CODE_FLT;
 	  break;
 	case DW_ATE_signed:
-	case DW_ATE_signed_char:
 	  break;
 	case DW_ATE_unsigned:
-	case DW_ATE_unsigned_char:
+	  type_flags |= TYPE_FLAG_UNSIGNED;
+	  break;
+	case DW_ATE_signed_char:
+	  if (cu->language == language_m2)
+	    code = TYPE_CODE_CHAR;
+	  break;
+ 	case DW_ATE_unsigned_char:
+	  if (cu->language == language_m2)
+	    code = TYPE_CODE_CHAR;
 	  type_flags |= TYPE_FLAG_UNSIGNED;
 	  break;
 	default:
@@ -6168,10 +6190,12 @@
     case DW_LANG_Ada95:
       cu->language = language_ada;
       break;
+    case DW_LANG_Modula2:
+      cu->language = language_m2;
+      break;
     case DW_LANG_Cobol74:
     case DW_LANG_Cobol85:
     case DW_LANG_Pascal83:
-    case DW_LANG_Modula2:
     default:
       cu->language = language_minimal;
       break;
@@ -6961,6 +6985,7 @@
 	case DW_TAG_class_type:
 	case DW_TAG_structure_type:
 	case DW_TAG_union_type:
+	case DW_TAG_set_type:
 	case DW_TAG_enumeration_type:
 	  SYMBOL_CLASS (sym) = LOC_TYPEDEF;
 	  SYMBOL_DOMAIN (sym) = STRUCT_DOMAIN;
@@ -7290,6 +7315,9 @@
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_pointer_type:
       read_tag_pointer_type (die, cu);
       break;
--- latest-cvs-gdb/src-cvs/gdb/m2-valprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-valprint.c	2006-05-09 22:50:38.000000000 +0100
@@ -1,7 +1,8 @@
 /* Support for printing Modula 2 values for GDB, the GNU debugger.
 
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998, 2000, 2005 Free
-   Software Foundation, Inc.
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998,
+                 2000, 2005, 2006
+   Free Software Foundation, Inc.
 
    This file is part of GDB.
 
@@ -23,14 +24,561 @@
 #include "defs.h"
 #include "symtab.h"
 #include "gdbtypes.h"
-#include "m2-lang.h"
+#include "expression.h"
+#include "value.h"
+#include "valprint.h"
+#include "language.h"
+#include "typeprint.h"
 #include "c-lang.h"
+#include "m2-lang.h"
+#include "target.h"
+
+int print_unpacked_pointer (struct type *type,
+			    CORE_ADDR address, CORE_ADDR addr,
+			    int format, struct ui_file *stream);
+
+
+/* Print function pointer with inferior address ADDRESS onto stdio
+   stream STREAM.  */
+
+static void
+print_function_pointer_address (CORE_ADDR address, struct ui_file *stream)
+{
+  CORE_ADDR func_addr = gdbarch_convert_from_func_ptr_addr (current_gdbarch,
+							    address,
+							    &current_target);
+
+  /* If the function pointer is represented by a description, print the
+     address of the description.  */
+  if (addressprint && func_addr != address)
+    {
+      fputs_filtered ("@", stream);
+      fputs_filtered (paddress (address), stream);
+      fputs_filtered (": ", stream);
+    }
+  print_address_demangle (func_addr, stream, demangle);
+}
+
+/*
+ *  get_long_set_bounds - assigns the bounds of the long set to low and high.
+ */
+
+int
+get_long_set_bounds (struct type *type, LONGEST *low, LONGEST *high)
+{
+  int len, i;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
+    {
+      len = TYPE_NFIELDS (type);
+      i = TYPE_N_BASECLASSES (type);
+      if (len == 0)
+	return 0;
+      *low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+      *high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type,
+								 len-1)));
+      return 1;
+    }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static void
+m2_print_long_set (struct type *type, const gdb_byte *valaddr,
+		   int embedded_offset, CORE_ADDR address,
+		   struct ui_file *stream, int format,
+		   enum val_prettyprint pretty)
+{
+  int empty_set        = 1;
+  int element_seen     = 0;
+  LONGEST previous_low = 0;
+  LONGEST previous_high= 0;
+  LONGEST i, low_bound, high_bound;
+  LONGEST field_low, field_high;
+  struct type *range;
+  int len, field;
+  struct type *target;
+  int bitval;
+
+  CHECK_TYPEDEF (type);
+
+  fprintf_filtered (stream, "{");
+  len = TYPE_NFIELDS (type);
+  if (get_long_set_bounds (type, &low_bound, &high_bound))
+    {
+      field = TYPE_N_BASECLASSES (type);
+      range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+    }
+  else
+    {
+      fprintf_filtered (stream, " %s }", _("<unknown bounds of set>"));
+      return;
+    }
+
+  target = TYPE_TARGET_TYPE (range);
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (get_discrete_bounds (range, &field_low, &field_high) >= 0)
+    {
+      for (i = low_bound; i <= high_bound; i++)
+	{
+	  bitval = value_bit_index (TYPE_FIELD_TYPE (type, field),
+				    (TYPE_FIELD_BITPOS (type, field) / 8) +
+				    valaddr + embedded_offset, i);
+	  if (bitval < 0)
+	    error (_("bit test is out of range"));
+	  else if (bitval > 0)
+	    {
+	      previous_high = i;
+	      if (! element_seen)
+		{
+		  if (! empty_set)
+		    fprintf_filtered (stream, ", ");
+		  print_type_scalar (target, i, stream);
+		  empty_set    = 0;
+		  element_seen = 1;
+		  previous_low = i;
+		}
+	    }
+	  else
+	    {
+	      /* bit is not set */
+	      if (element_seen)
+		{
+		  if (previous_low+1 < previous_high)
+		    fprintf_filtered (stream, "..");
+		  if (previous_low+1 < previous_high)
+		    print_type_scalar (target, previous_high, stream);
+		  element_seen = 0;
+		}
+	    }
+	  if (i == field_high)
+	    {
+	      field++;
+	      if (field == len)
+		break;
+	      range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+	      if (get_discrete_bounds (range, &field_low, &field_high) < 0)
+		break;
+	      target = TYPE_TARGET_TYPE (range);
+	      if (target == NULL)
+		target = builtin_type_int;
+	    }
+	}
+      if (element_seen)
+	{
+	  if (previous_low+1 < previous_high)
+	    {
+	      fprintf_filtered (stream, "..");
+	      print_type_scalar (target, previous_high, stream);
+	    }
+	  element_seen = 0;
+	}
+      fprintf_filtered (stream, "}");
+    }
+}
+
+int
+print_unpacked_pointer (struct type *type,
+			CORE_ADDR address, CORE_ADDR addr,
+			int format, struct ui_file *stream)
+{
+  struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+  if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
+    {
+      /* Try to print what function it points to.  */
+      print_function_pointer_address (addr, stream);
+      /* Return value is irrelevant except for string pointers.  */
+      return 0;
+    }
+
+  if (addressprint && format != 's')
+    fputs_filtered (paddress (address), stream);
+
+  /* For a pointer to char or unsigned char, also print the string
+     pointed to, unless pointer is null.  */
+
+  if (TYPE_LENGTH (elttype) == 1
+      && TYPE_CODE (elttype) == TYPE_CODE_INT
+      && (format == 0 || format == 's')
+      && addr != 0)
+      return val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
+  
+  return 0;
+}
+
+static void
+print_variable_at_address (struct type *type, const gdb_byte *valaddr,
+			   struct ui_file *stream, int format,
+			   int deref_ref, int recurse,
+			   enum val_prettyprint pretty)
+{
+  CORE_ADDR addr = unpack_pointer (type, valaddr);
+  struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+  fprintf_filtered (stream, "[");
+  fputs_filtered (paddress (addr), stream);
+  fprintf_filtered (stream, "] : ");
+  
+  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
+    {
+      struct value *deref_val =
+	value_at
+	(TYPE_TARGET_TYPE (type),
+	 unpack_pointer (lookup_pointer_type (builtin_type_void),
+			 valaddr));
+      common_val_print (deref_val, stream, format, deref_ref,
+			recurse, pretty);
+    }
+  else
+    fputs_filtered ("???", stream);
+}
+
+/* Print data of type TYPE located at VALADDR (within GDB), which came from
+   the inferior at address ADDRESS, onto stdio stream STREAM according to
+   FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
+   target byte order.
+
+   If the data are a string pointer, returns the number of string characters
+   printed.
+
+   If DEREF_REF is nonzero, then dereference references, otherwise just print
+   them like pointers.
+
+   The PRETTY parameter controls prettyprinting.  */
 
 int
 m2_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 	      CORE_ADDR address, struct ui_file *stream, int format,
 	      int deref_ref, int recurse, enum val_prettyprint pretty)
 {
-  return (c_val_print (type, valaddr, 0, address, stream, format, deref_ref,
-		       recurse, pretty));
+  unsigned int i = 0;	/* Number of characters printed */
+  unsigned len;
+  struct type *elttype;
+  unsigned eltlen;
+  int length_pos, length_size, string_pos;
+  int char_size;
+  LONGEST val;
+  CORE_ADDR addr;
+
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
+	{
+	  elttype = check_typedef (TYPE_TARGET_TYPE (type));
+	  eltlen = TYPE_LENGTH (elttype);
+	  len = TYPE_LENGTH (type) / eltlen;
+	  if (prettyprint_arrays)
+	    print_spaces_filtered (2 + 2 * recurse, stream);
+	  /* For an array of chars, print with string syntax.  */
+	  if (eltlen == 1 &&
+	      ((TYPE_CODE (elttype) == TYPE_CODE_INT)
+	       || ((current_language->la_language == language_m2)
+		   && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
+	      && (format == 0 || format == 's'))
+	    {
+	      /* If requested, look for the first null char and only print
+	         elements up to it.  */
+	      if (stop_print_at_null)
+		{
+		  unsigned int temp_len;
+
+		  /* Look for a NULL char. */
+		  for (temp_len = 0;
+		       (valaddr + embedded_offset)[temp_len]
+			 && temp_len < len && temp_len < print_max;
+		       temp_len++);
+		  len = temp_len;
+		}
+
+	      LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
+	      i = len;
+	    }
+	  else
+	    {
+	      fprintf_filtered (stream, "{");
+	      val_print_array_elements (type, valaddr + embedded_offset,
+					address, stream, format, deref_ref,
+					recurse, pretty, 0);
+	      fprintf_filtered (stream, "}");
+	    }
+	  break;
+	}
+      /* Array of unspecified length: treat like pointer to first elt.  */
+      print_unpacked_pointer (type, address, address, format, stream);
+      break;
+
+    case TYPE_CODE_PTR:
+      if (TYPE_CONST (type))
+	print_variable_at_address (type, valaddr + embedded_offset,
+				   stream, format, deref_ref, recurse,
+				   pretty);
+      else if (format && format != 's')
+	print_scalar_formatted (valaddr + embedded_offset, type, format,
+				0, stream);
+      else
+	{
+	  addr = unpack_pointer (type, valaddr + embedded_offset);
+	  print_unpacked_pointer (type, addr, address, format, stream);
+	}
+      break;
+
+    case TYPE_CODE_MEMBER:
+      error (_("not implemented: member type in m2_val_print"));
+      break;
+
+    case TYPE_CODE_REF:
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+      if (addressprint)
+	{
+	  CORE_ADDR addr
+	    = extract_typed_address (valaddr + embedded_offset, type);
+	  fprintf_filtered (stream, "@");
+	  fputs_filtered (paddress (addr), stream);
+	  if (deref_ref)
+	    fputs_filtered (": ", stream);
+	}
+      /* De-reference the reference.  */
+      if (deref_ref)
+	{
+	  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
+	    {
+	      struct value *deref_val =
+		value_at
+		(TYPE_TARGET_TYPE (type),
+		 unpack_pointer (lookup_pointer_type (builtin_type_void),
+				 valaddr + embedded_offset));
+	      common_val_print (deref_val, stream, format, deref_ref,
+				recurse, pretty);
+	    }
+	  else
+	    fputs_filtered ("???", stream);
+	}
+      break;
+
+    case TYPE_CODE_UNION:
+      if (recurse && !unionprint)
+	{
+	  fprintf_filtered (stream, "{...}");
+	  break;
+	}
+      /* Fall through.  */
+    case TYPE_CODE_STRUCT:
+      if (m2_is_long_set (type))
+	m2_print_long_set (type, valaddr, embedded_offset, address,
+			   stream, format, pretty);
+      else
+	cp_print_value_fields (type, type, valaddr, embedded_offset, address, stream, format,
+			       recurse, pretty, NULL, 0);
+      break;
+
+    case TYPE_CODE_ENUM:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type,
+				  format, 0, stream);
+	  break;
+	}
+      len = TYPE_NFIELDS (type);
+      val = unpack_long (type, valaddr + embedded_offset);
+      for (i = 0; i < len; i++)
+	{
+	  QUIT;
+	  if (val == TYPE_FIELD_BITPOS (type, i))
+	    {
+	      break;
+	    }
+	}
+      if (i < len)
+	{
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	}
+      else
+	{
+	  print_longest (stream, 'd', 0, val);
+	}
+      break;
+
+    case TYPE_CODE_FUNC:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type,
+				  format, 0, stream);
+	  break;
+	}
+      /* FIXME, we should consider, at least for ANSI C language, eliminating
+         the distinction made between FUNCs and POINTERs to FUNCs.  */
+      fprintf_filtered (stream, "{");
+      type_print (type, "", stream, -1);
+      fprintf_filtered (stream, "} ");
+      /* Try to print what function it points to, and its address.  */
+      print_address_demangle (address, stream, demangle);
+      break;
+
+    case TYPE_CODE_BOOL:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr + embedded_offset, type,
+				format, 0, stream);
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (val == 0)
+	    fputs_filtered ("FALSE", stream);
+	  else if (val == 1)
+	    fputs_filtered ("TRUE", stream);
+	  else
+	    fprintf_filtered (stream, "%ld)", (long int) val);
+	}
+      break;
+
+    case TYPE_CODE_RANGE:
+      if (TYPE_LENGTH (type) == TYPE_LENGTH (TYPE_TARGET_TYPE (type)))
+	{
+	  m2_val_print (TYPE_TARGET_TYPE (type), valaddr, embedded_offset,
+			address, stream, format, deref_ref, recurse, pretty);
+	  break;
+	}
+      /* FIXME: create_range_type does not set the unsigned bit in a
+         range type (I think it probably should copy it from the target
+         type), so we won't print values which are too large to
+         fit in a signed integer correctly.  */
+      /* FIXME: Doesn't handle ranges of enums correctly.  (Can't just
+         print with the target type, though, because the size of our type
+         and the target type might differ).  */
+      /* FALLTHROUGH */
+
+    case TYPE_CODE_INT:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr + embedded_offset, type, format,
+				0, stream);
+      else
+	val_print_type_code_int (type, valaddr + embedded_offset, stream);
+      break;
+
+    case TYPE_CODE_CHAR:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr + embedded_offset, type,
+				format, 0, stream);
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (TYPE_UNSIGNED (type))
+	    fprintf_filtered (stream, "%u", (unsigned int) val);
+	  else
+	    fprintf_filtered (stream, "%d", (int) val);
+	  fputs_filtered (" ", stream);
+	  LA_PRINT_CHAR ((unsigned char) val, stream);
+	}
+      break;
+
+    case TYPE_CODE_FLT:
+      if (format)
+	print_scalar_formatted (valaddr + embedded_offset, type,
+				format, 0, stream);
+      else
+	print_floating (valaddr + embedded_offset, type, stream);
+      break;
+
+    case TYPE_CODE_METHOD:
+      break;
+
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_SET:
+      elttype = TYPE_INDEX_TYPE (type);
+      CHECK_TYPEDEF (elttype);
+      if (TYPE_STUB (elttype))
+	{
+	  fprintf_filtered (stream, _("<incomplete type>"));
+	  gdb_flush (stream);
+	  break;
+	}
+      else
+	{
+	  struct type *range = elttype;
+	  LONGEST low_bound, high_bound;
+	  int i;
+	  int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
+	  int need_comma = 0;
+
+	  if (is_bitstring)
+	    fputs_filtered ("B'", stream);
+	  else
+	    fputs_filtered ("{", stream);
+
+	  i = get_discrete_bounds (range, &low_bound, &high_bound);
+	maybe_bad_bstring:
+	  if (i < 0)
+	    {
+	      fputs_filtered (_("<error value>"), stream);
+	      goto done;
+	    }
+
+	  for (i = low_bound; i <= high_bound; i++)
+	    {
+	      int element = value_bit_index (type, valaddr + embedded_offset,
+					     i);
+	      if (element < 0)
+		{
+		  i = element;
+		  goto maybe_bad_bstring;
+		}
+	      if (is_bitstring)
+		fprintf_filtered (stream, "%d", element);
+	      else if (element)
+		{
+		  if (need_comma)
+		    fputs_filtered (", ", stream);
+		  print_type_scalar (range, i, stream);
+		  need_comma = 1;
+
+		  if (i + 1 <= high_bound
+		      && value_bit_index (type, valaddr + embedded_offset,
+					  ++i))
+		    {
+		      int j = i;
+		      fputs_filtered ("..", stream);
+		      while (i + 1 <= high_bound
+			     && value_bit_index (type,
+						 valaddr + embedded_offset,
+						 ++i))
+			j = i;
+		      print_type_scalar (range, j, stream);
+		    }
+		}
+	    }
+	done:
+	  if (is_bitstring)
+	    fputs_filtered ("'", stream);
+	  else
+	    fputs_filtered ("}", stream);
+	}
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "void");
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, _("<error type>"));
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
+         dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
+         and no complete type for struct foo in that file.  */
+      fprintf_filtered (stream, _("<incomplete type>"));
+      break;
+
+    default:
+      error (_("Invalid m2 type code %d in symbol table."), TYPE_CODE (type));
+    }
+  gdb_flush (stream);
+  return (0);
 }
--- latest-cvs-gdb/src-cvs/gdb/doc/gdb.texinfo	2006-05-05 23:48:14.000000000 +0100
+++ latest-cvs-gdb/src-m2/gdb/doc/gdb.texinfo	2006-05-09 21:15:57.000000000 +0100
@@ -9471,6 +9471,7 @@
 * M2 Operators::                Built-in operators
 * Built-In Func/Proc::          Built-in functions and procedures
 * M2 Constants::                Modula-2 constants
+* M2 Types::                    Modula-2 types
 * M2 Defaults::                 Default settings for Modula-2
 * Deviations::                  Deviations from standard Modula-2
 * M2 Checks::                   Modula-2 type and range checks
@@ -9595,7 +9596,7 @@
 @end table
 
 @quotation
-@emph{Warning:} Sets and their operations are not yet supported, so @value{GDBN}
+@emph{Warning:} Set expressions and their operations are not yet supported, so @value{GDBN}
 treats the use of the operator @code{IN}, or the use of operators
 @code{+}, @code{-}, @code{*}, @code{/}, @code{=}, , @code{<>}, @code{#},
 @code{<=}, and @code{>=} on sets as an error.
@@ -9764,6 +9765,170 @@
 Set constants are not yet supported.
 @end itemize
 
+@node M2 Types
+@subsubsection Modula-2 Types
+@cindex Modula-2 types
+
+Currently @value{GDBN} can print the following data types in Modula-2
+syntax: array types, record types, set types, pointer types, procedure
+types, enumerated types, subrange types and base types.  You can also
+print the contents of variables declared using these type.
+This section gives a number of simple source code examples together with
+sample @value{GDBN} sessions.
+
+The first example contains the following section of code:
+
+@smallexample
+VAR
+   s: SET OF CHAR ;
+   r: [20..40] ;
+@end smallexample
+
+@noindent
+and you can request @value{GDBN} to interrogate the type and value of
+@code{r} and @code{s}.
+
+@smallexample
+(@value{GDBP}) print s
+@{'A'..'C', 'Z'@}
+(@value{GDBP}) ptype s
+SET OF CHAR
+(@value{GDBP}) print r
+21
+(@value{GDBP}) ptype r
+[20..40]
+@end smallexample
+
+@noindent
+Likewise if your source code declares @code{s} as:
+
+@smallexample
+VAR
+   s: SET ['A'..'Z'] ;
+@end smallexample
+
+@noindent
+then you may query the type of @code{s} by:
+
+@smallexample
+(@value{GDBP}) ptype s
+type = SET ['A'..'Z']
+@end smallexample
+
+@noindent
+Note that at present you cannot interactively manipulate set
+expressions using the debugger.
+
+The following example shows how you might declare an array in Modula-2
+and how you can interact with @value{GDBN} to print its type and contents:
+
+@smallexample
+VAR
+   s: ARRAY [-10..10] OF CHAR ;
+@end smallexample
+
+@smallexample
+(@value{GDBP}) ptype s
+ARRAY [-10..10] OF CHAR
+@end smallexample
+
+Note that the array handling is not yet complete and although the type
+is printed correctly, expression handling still assumes that all
+arrays have a lower bound of zero and not @code{-10} as in the example
+above.  Unbounded arrays are also not yet recognized in @value{GDBN}.
+
+Here are some more type related Modula-2 examples:
+
+@smallexample
+TYPE
+   colour = (blue, red, yellow, green) ;
+   t = [blue..yellow] ;
+VAR
+   s: t ;
+BEGIN
+   s := blue ;
+@end smallexample
+
+@noindent
+The @value{GDBN} interaction shows how you can query the data type
+and value of a variable.
+
+@smallexample
+(@value{GDBP}) print s
+$1 = blue
+(@value{GDBP}) ptype t
+type = [blue..yellow]
+@end smallexample
+
+@noindent
+In this example a Modula-2 array is declared and its contents
+displayed.  Observe that the contents are written in the same way as
+their @code{C} counterparts.
+
+@smallexample
+VAR
+   s: ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   s[1] := 1 ;
+@end smallexample
+
+@smallexample
+(@value{GDBP}) print s
+$1 = @{1, 0, 0, 0, 0@}
+(@value{GDBP}) ptype s
+type = ARRAY [1..5] OF CARDINAL
+@end smallexample
+
+The Modula-2 language interface to @value{GDBN} also understands
+pointer types as shown in this example:
+
+@smallexample
+VAR
+   s: POINTER TO ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   NEW(s) ;
+   s^[1] := 1 ;
+@end smallexample
+
+@noindent
+and you can request that @value{GDBN} describes the type of @code{s}.
+
+@smallexample
+(@value{GDBP}) ptype s
+type = POINTER TO ARRAY [1..5] OF CARDINAL
+@end smallexample
+
+@value{GDBN} handles compound types as we can see in this example.
+Here we combine array types, record types, pointer types and subrange
+types:
+
+@smallexample
+TYPE
+   foo = RECORD
+            f1: CARDINAL ;
+            f2: CHAR ;
+            f3: myarray ;
+         END ;
+
+   myarray = ARRAY myrange OF CARDINAL ;
+   myrange = [-2..2] ;
+VAR
+   s: POINTER TO ARRAY myrange OF foo ;
+@end smallexample
+
+@noindent
+and you can ask @value{GDBN} to describe the type of @code{s} as shown
+below.
+
+@smallexample
+(@value{GDBP}) ptype s
+type = POINTER TO ARRAY [-2..2] OF foo = RECORD
+    f1 : CARDINAL;
+    f2 : CHAR;
+    f3 : ARRAY [-2..2] OF CARDINAL;
+END 
+@end smallexample
+
 @node M2 Defaults
 @subsubsection Modula-2 defaults
 @cindex Modula-2 defaults

[-- Attachment #3: Type: text/plain, Size: 56 bytes --]


also enclosed is a proposed set of ChangeLog entries:


[-- Attachment #4: ChangeLog entries --]
[-- Type: application/octet-stream, Size: 1394 bytes --]

2006-05-09  Gaius Mulley <gaius@glam.ac.uk>

	* gdb/m2-lang.h: added function extern prototypes for m2_is_long_set and
	get_long_set_bounds.
	* gm2/m2-typeprint.c: This file has been completely
	replaced to reflect the Modula-2 syntax rather than call the
	c_print_type function.
	(m2_print_type): walk the Modula-2 type tree.
	(m2_type_name): added.
	(m2_range): added.
	(m2_typedef): added.
	(m2_array): added.
	(m2_pointer): added.
	(m2_ref): added.
	(m2_unknown): added.
	(m2_union): added.
	(m2_procedure): added.
	(m2_print_bounds): added.
	(m2_short_set): added.
	(m2_is_long_set): added.
	(m2_get_discrete_bounds): added.
	(m2_is_long_set_of_type): added.
	(m2_long_set): added.
	(m2_record_fields): added.
	(m2_enum): added.
	* gdb/dwarf2read.c: added ability to detect the language Modula-2
	and handle SET and CHAR types.
	(read_set_type): added.
	(process_die): call read_set_type.
	(read_base_type): modifed signed/unsigned char handling for Modula-2.
	(set_cu_language): added Modula-2 case clause.
	* gdb/m2-valprint.c: complete replacement so that Modula-2 values are
	printed rather than call the C language routines.
	(print_function_pointer_address): added.
	(get_long_set_bounds): added.
	(m2_print_long_set): added.
	(print_unpacked_pointer): added.
	(print_variable_at_address): added.
	(m2_val_print): replaced.
	* gdb/doc/gdb.texinfo: added a section on Modula-2 Types.

[-- Attachment #5: Type: text/plain, Size: 16 bytes --]


regards,
Gaius

Re: Enhanced language support for Modula-2

[Eli Zaretskii]

> From: Gaius Mulley <gaius@glam.ac.uk>
> Date: 08 May 2006 14:55:08 +0100
> 
> thanks for the feedback and here is the revised patch - which fixes
> the documentation:
> 
>     @example -> @smallexample
>     @end example -> @end smallexample
>     and uses the American spelling of `recogni[sz]ed'.
> 
> and the code change removes the function m2_type_print_base and
> substitutes the call to it by a call to m2_print_type instead.

The documentation part is okay with me.  Thanks.

Re: Enhanced language support for Modula-2

[Jim Blandy]

Gaius Mulley <gaius@glam.ac.uk> writes:
> "Jim Blandy" <jimb@red-bean.com> writes:
>
>> The revised patch looks fine.  The only question I have is, what's up
>> with m2_type_print_base?  Is that the way it's supposed to be?
>
> Hi,
>
> thanks for the feedback and here is the revised patch - which fixes
> the documentation:
>
>     @example -> @smallexample
>     @end example -> @end smallexample
>     and uses the American spelling of `recogni[sz]ed'.
>
> and the code change removes the function m2_type_print_base and
> substitutes the call to it by a call to m2_print_type instead.

Okay, just some fine-toothed comb stuff:

Have you written ChangeLog entries for this?  Follow the format the
other entries use.

In GDB code, each curly brace gets a line to itself.  I see a few
sharing a line with an 'if' or 'else' in m2-valprint.c and
m2-typeprint.c.

Also, all GNU code should fit in eighty columns.

I see some indentation problems in m2_val_print.  If you're using GNU
Emacs, just hit M-C-q before the function's opening brace, and it'll
take care of it.

Re: Enhanced language support for Modula-2

[Gaius Mulley]

[-- Attachment #1: Type: text/plain, Size: 525 bytes --]

"Jim Blandy" <jimb@red-bean.com> writes:

> The revised patch looks fine.  The only question I have is, what's up
> with m2_type_print_base?  Is that the way it's supposed to be?

Hi,

thanks for the feedback and here is the revised patch - which fixes
the documentation:

    @example -> @smallexample
    @end example -> @end smallexample
    and uses the American spelling of `recogni[sz]ed'.

and the code change removes the function m2_type_print_base and
substitutes the call to it by a call to m2_print_type instead.


[-- Attachment #2: Modula-2 enhancement patch --]
[-- Type: application/octet-stream, Size: 39998 bytes --]

--- latest-cvs-gdb/src-cvs/gdb/m2-lang.h	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-lang.h	2006-04-20 12:18:17.000000000 +0100
@@ -27,6 +27,11 @@
 extern void m2_print_type (struct type *, char *, struct ui_file *, int,
 			   int);
 
+extern int m2_is_long_set (struct type *type);
+
 extern int m2_val_print (struct type *, const gdb_byte *, int, CORE_ADDR,
 			 struct ui_file *, int, int, int,
 			 enum val_prettyprint);
+
+extern int get_long_set_bounds (struct type *type, LONGEST *low,
+				LONGEST *high);
--- latest-cvs-gdb/src-cvs/gdb/m2-typeprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-typeprint.c	2006-05-08 14:57:10.000000000 +0100
@@ -1,5 +1,6 @@
 /* Support for printing Modula 2 types for GDB, the GNU debugger.
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    This file is part of GDB.
@@ -20,22 +21,533 @@
    Boston, MA 02110-1301, USA.  */
 
 #include "defs.h"
+#include "gdb_obstack.h"
 #include "bfd.h"		/* Binary File Description */
 #include "symtab.h"
 #include "gdbtypes.h"
 #include "expression.h"
 #include "value.h"
 #include "gdbcore.h"
-#include "target.h"
 #include "m2-lang.h"
+#include "target.h"
+#include "language.h"
+#include "demangle.h"
+#include "c-lang.h"
+#include "typeprint.h"
+#include "cp-abi.h"
+
+#include "gdb_string.h"
 #include <errno.h>
 
+static void m2_print_bounds (struct type *type,
+			     struct ui_file *stream, int show, int level,
+			     int print_high);
+
+static void m2_typedef (struct type *, struct ui_file *, int, int);
+static void m2_array (struct type *, struct ui_file *, int, int);
+static void m2_pointer (struct type *, struct ui_file *, int, int);
+static void m2_ref (struct type *, struct ui_file *, int, int);
+static void m2_procedure (struct type *, struct ui_file *, int, int);
+static void m2_union (struct type *, struct ui_file *);
+static void m2_enum (struct type *, struct ui_file *, int, int);
+static void m2_range (struct type *, struct ui_file *, int, int);
+static void m2_type_name (struct type *type, struct ui_file *stream);
+static void m2_short_set (struct type *type, struct ui_file *stream, int show, int level);
+static int m2_long_set (struct type *type, struct ui_file *stream, int show, int level);
+static void m2_record_fields (struct type *type, struct ui_file *stream, int show, int level);
+static void m2_unknown (const char *s, struct type *type, struct ui_file *stream, int show, int level);
+
+int m2_is_long_set (struct type *type);
+int m2_is_long_set_of_type (struct type *type, struct type **of_type);
+
+
 void
 m2_print_type (struct type *type, char *varstring, struct ui_file *stream,
 	       int show, int level)
 {
-  extern void c_print_type (struct type *, char *, struct ui_file *, int,
-			    int);
+  enum type_code code;
+  int demangled_args;
+
+  CHECK_TYPEDEF (type);
+  code = TYPE_CODE (type);
+
+  QUIT;
+
+  wrap_here ("    ");
+  if (type == NULL)
+    {
+      fputs_filtered (_("<type unknown>"), stream);
+      return;
+    }
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_SET:
+      m2_short_set(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_STRUCT:
+      if (m2_long_set (type, stream, show, level))
+	break;
+      m2_record_fields (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_TYPEDEF:
+      m2_typedef (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_ARRAY:
+      m2_array (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_PTR:
+      m2_pointer (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_REF:
+      m2_ref (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_MEMBER:
+      m2_unknown (_("member"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_METHOD:
+      m2_unknown (_("method"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_FUNC:
+      m2_procedure (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_UNION:
+      m2_union (type, stream);
+      break;
+
+    case TYPE_CODE_ENUM:
+      m2_enum (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_VOID:
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* i18n: Do not translate the "struct" part! */
+      m2_unknown (_("undef"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_ERROR:
+      m2_unknown (_("error"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_RANGE:
+      m2_range (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_TEMPLATE:
+      break;
+
+    default:
+      m2_type_name (type, stream);
+      break;
+    }
+}
+
+/*
+ *  m2_type_name - if a, type, has a name then print it.
+ */
+
+void
+m2_type_name (struct type *type, struct ui_file *stream)
+{
+  if (TYPE_NAME (type) != NULL)
+    fputs_filtered (TYPE_NAME (type), stream);
+}
+
+/*
+ *  m2_range - displays a Modula-2 subrange type.
+ */
+
+void
+m2_range (struct type *type, struct ui_file *stream, int show,
+	  int level)
+{
+  if (TYPE_HIGH_BOUND (type) == TYPE_LOW_BOUND (type))
+    m2_print_type (TYPE_DOMAIN_TYPE (type), "", stream, show, level);
+  else {
+    struct type *target = TYPE_TARGET_TYPE (type);
+
+    fprintf_filtered (stream, "[");
+    print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+    fprintf_filtered (stream, "..");
+    print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+    fprintf_filtered (stream, "]");
+  }
+}
+
+static void
+m2_typedef (struct type *type, struct ui_file *stream, int show,
+	    int level)
+{
+  if (TYPE_NAME (type) != NULL) {
+    fputs_filtered (TYPE_NAME (type), stream);
+    fputs_filtered (" = ", stream);
+  }
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+/*
+ *  m2_array - prints out a Modula-2 ARRAY ... OF type
+ */
+
+static void m2_array (struct type *type, struct ui_file *stream,
+		      int show, int level)
+{
+  fprintf_filtered (stream, "ARRAY [");
+  if (TYPE_LENGTH (type) >= 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0
+      && TYPE_ARRAY_UPPER_BOUND_TYPE (type) != BOUND_CANNOT_BE_DETERMINED) {
+    if (TYPE_INDEX_TYPE (type) != 0) {
+      m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 0);
+      fprintf_filtered (stream, "..");
+      m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 1);
+    }
+    else
+      fprintf_filtered (stream, "%d",
+			(TYPE_LENGTH (type)
+			 / TYPE_LENGTH (TYPE_TARGET_TYPE (type))));
+  }
+  fprintf_filtered (stream, "] OF ");
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+static void
+m2_pointer (struct type *type, struct ui_file *stream, int show,
+	    int level)
+{
+  if (TYPE_CONST (type))
+    fprintf_filtered (stream, "[...] : ");
+  else
+    fprintf_filtered (stream, "POINTER TO ");
+
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+static void
+m2_ref (struct type *type, struct ui_file *stream, int show,
+	int level)
+{
+  fprintf_filtered (stream, "VAR");
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+static void
+m2_unknown (const char *s, struct type *type, struct ui_file *stream,
+	    int show, int level)
+{
+  fprintf_filtered (stream, "%s %s", s, _("is unknown"));
+}
+
+static void m2_union (struct type *type, struct ui_file *stream)
+{
+  fprintf_filtered (stream, "union");
+}
+
+static void
+m2_procedure (struct type *type, struct ui_file *stream,
+	      int show, int level)
+{
+  fprintf_filtered (stream, "PROCEDURE ");
+  m2_type_name (type, stream);
+  if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
+    {
+      int i, len = TYPE_NFIELDS (type);
+
+      fprintf_filtered (stream, " (");
+      for (i = 0; i < len; i++)
+	{
+	  if (i > 0)
+	    {
+	      fputs_filtered (", ", stream);
+	      wrap_here ("    ");
+	    }
+	  m2_print_type (TYPE_FIELD_TYPE (type, i), "", stream, -1, 0);
+	}
+      if (TYPE_TARGET_TYPE (type) != NULL)
+	{
+	  fprintf_filtered (stream, " : ");
+	  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, 0, 0);
+	}
+    }
+}
+
+static void
+m2_print_bounds (struct type *type,
+		 struct ui_file *stream, int show, int level,
+		 int print_high)
+{
+  struct type *target = TYPE_TARGET_TYPE (type);
+
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (TYPE_NFIELDS(type) == 0)
+    return;
+
+  if (print_high)
+    print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+  else
+    print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+}
+
+static void
+m2_short_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  fprintf_filtered(stream, "SET [");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 0);
+
+  fprintf_filtered(stream, "..");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 1);
+  fprintf_filtered(stream, "]");
+}
+
+int
+m2_is_long_set (struct type *type)
+{
+  LONGEST previous_high = 0;  /* unnecessary initialization keeps gcc -Wall happy */
+  int len, i;
+  struct type *range;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+
+    /*
+     *  check if all fields of the RECORD are consecutive sets
+     */
+    len = TYPE_NFIELDS (type);
+    for (i = TYPE_N_BASECLASSES (type); i < len; i++) {
+      if (TYPE_FIELD_TYPE (type, i) == NULL)
+	return 0;
+      if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) != TYPE_CODE_SET)
+	return 0;
+      if (TYPE_FIELD_NAME (type, i) != NULL
+	  && (strcmp (TYPE_FIELD_NAME (type, i), "") != 0))
+	return 0;
+      range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+      if ((i > TYPE_N_BASECLASSES (type))
+	  && previous_high + 1 != TYPE_LOW_BOUND (range))
+	return 0;
+      previous_high = TYPE_HIGH_BOUND (range);
+    }
+    return len>0;
+  }
+  return 0;
+}
+
+/*
+ *  m2_get_discrete_bounds - a wrapper for get_discrete_bounds which
+ *                           understands that CHARs might be signed.
+ *                           This should be integrated into gdbtypes.c
+ *                           inside get_discrete_bounds.
+ */
+
+int
+m2_get_discrete_bounds (struct type *type, LONGEST *lowp, LONGEST *highp)
+{
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_CHAR:
+      if (TYPE_LENGTH (type) < sizeof (LONGEST)) {
+	if (!TYPE_UNSIGNED (type))
+	  {
+	    *lowp = -(1 << (TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1));
+	    *highp = -*lowp - 1;
+	    return 0;
+	  }
+      }
+      /* fall through */
+    default:
+      return get_discrete_bounds (type, lowp, highp);
+    }
+}
+
+/*
+ *  m2_is_long_set_of_type - returns TRUE if the long set was declared as SET OF <oftype>
+ *                           of_type is assigned to the subtype.
+ */
+
+int
+m2_is_long_set_of_type (struct type *type, struct type **of_type)
+{
+  int len, i;
+  struct type *range;
+  struct type *target;
+  LONGEST l1, l2;
+  LONGEST h1, h2;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+    target = TYPE_TARGET_TYPE (range);
+    if (target == NULL)
+      target = builtin_type_int;
+
+    l1 = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    h1 = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    *of_type = target;
+    if (m2_get_discrete_bounds (target, &l2, &h2) >= 0)
+      return (l1 == l2 && h1 == h2);
+    error (_("long_set failed to find discrete bounds for its subtype"));
+    return 0;
+  }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static int
+m2_long_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  struct type *index_type;
+  struct type *range_type;
+  struct type *of_type;
+  int i;
+  int len = TYPE_NFIELDS (type);
+  LONGEST low;
+  LONGEST high;
+
+  if (m2_is_long_set (type)) {
+    if (TYPE_TAG_NAME (type) != NULL) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+    else if (TYPE_NAME (type) != NULL) {
+      fputs_filtered (TYPE_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+
+    if (TYPE_TAG_NAME (type) != NULL || TYPE_NAME (type) != NULL)
+      fputs_filtered (" = ", stream);
+
+    if (get_long_set_bounds (type, &low, &high)) {
+      fprintf_filtered(stream, "SET OF ");
+      i = TYPE_N_BASECLASSES (type);
+      if (m2_is_long_set_of_type (type, &of_type))
+	m2_print_type (of_type, "", stream, show - 1, level);
+      else {
+	fprintf_filtered(stream, "[");
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)),
+			 stream, show - 1, level, 0);
+
+	fprintf_filtered(stream, "..");
+
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)),
+			 stream, show - 1, level, 1);
+	fprintf_filtered(stream, "]");
+      }
+    }
+    else
+      /* i18n: Do not translate the "SET OF" part! */
+      fprintf_filtered(stream, _("SET OF <unknown>"));
+
+    return 1;
+  }
+  return 0;
+}
+
+void
+m2_record_fields (struct type *type, struct ui_file *stream, int show,
+		  int level)
+{
+  /* Print the tag if it exists. 
+   */
+  if (TYPE_TAG_NAME (type) != NULL) {
+    if (strncmp (TYPE_TAG_NAME (type), "$$", 2) != 0) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show > 0)
+	fprintf_filtered (stream, " = ");
+    }
+  }
+  wrap_here ("    ");
+  if (show < 0)
+    {
+      if (TYPE_CODE (type) == DECLARED_TYPE_STRUCT)
+	fprintf_filtered (stream, "RECORD ... END ");
+      else if (TYPE_DECLARED_TYPE (type) == DECLARED_TYPE_UNION)
+	fprintf_filtered (stream, "CASE ... END ");
+    }
+  else if (show > 0)
+    {
+      if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
+	fprintf_filtered (stream, "RECORD\n");
+      else if (TYPE_CODE (type) == TYPE_CODE_UNION)
+	/* i18n: Do not translate "CASE" and "OF" */
+	fprintf_filtered (stream, _("CASE <variant> OF\n"));
+      int i;
+      int len = TYPE_NFIELDS (type);
+
+      for (i = TYPE_N_BASECLASSES (type); i < len; i++)
+	{
+	  QUIT;
+
+	  print_spaces_filtered (level + 4, stream);
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	  fputs_filtered (" : ", stream);
+	  m2_print_type (TYPE_FIELD_TYPE (type, i),
+			 "",
+			 stream, 0, level + 4);
+	  if (TYPE_FIELD_PACKED (type, i))
+	    {
+	      /* It is a bitfield.  This code does not attempt
+		 to look at the bitpos and reconstruct filler,
+		 unnamed fields.  This would lead to misleading
+		 results if the compiler does not put out fields
+		 for such things (I don't know what it does).  */
+	      fprintf_filtered (stream, " : %d",
+				TYPE_FIELD_BITSIZE (type, i));
+	    }
+	  fprintf_filtered (stream, ";\n");
+	}
+      
+      fprintfi_filtered (level, stream, "END ");
+    }
+}
+
+void
+m2_enum (struct type *type, struct ui_file *stream, int show, int level)
+{
+  int lastval, i, len;
 
-  c_print_type (type, varstring, stream, show, level);	/* FIXME */
+  if (show < 0)
+    {
+      /* If we just printed a tag name, no need to print anything else.  */
+      if (TYPE_TAG_NAME (type) == NULL)
+	fprintf_filtered (stream, "(...)");
+    }
+  else if (show > 0 || TYPE_TAG_NAME (type) == NULL)
+    {
+      fprintf_filtered (stream, "(");
+      len = TYPE_NFIELDS (type);
+      lastval = 0;
+      for (i = 0; i < len; i++)
+	{
+	  QUIT;
+	  if (i > 0)
+	    fprintf_filtered (stream, ", ");
+	  wrap_here ("    ");
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	  if (lastval != TYPE_FIELD_BITPOS (type, i))
+	    {
+	      fprintf_filtered (stream, " = %d", TYPE_FIELD_BITPOS (type, i));
+	      lastval = TYPE_FIELD_BITPOS (type, i);
+	    }
+	  lastval++;
+	}
+      fprintf_filtered (stream, ")");
+    }
 }
--- latest-cvs-gdb/src-cvs/gdb/dwarf2read.c	2006-02-09 18:18:41.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/dwarf2read.c	2006-04-20 12:18:17.000000000 +0100
@@ -1,7 +1,7 @@
 /* DWARF 2 debugging format support for GDB.
 
-   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-   2004, 2005, 2006
+   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    Adapted by Gary Funck (gary@intrepid.com), Intrepid Technology,
@@ -1073,6 +1073,9 @@
 
 static void dwarf2_clear_marks (struct dwarf2_per_cu_data *);
 
+static void read_set_type (struct die_info *, struct dwarf2_cu *);
+
+
 /* Try to locate the sections we need for DWARF 2 debugging
    information and return true if we have enough to do something.  */
 
@@ -2662,6 +2665,9 @@
     case DW_TAG_subroutine_type:
       read_subroutine_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
@@ -4240,6 +4246,15 @@
     };
 }
 
+/* Extract all information from a DW_TAG_set_type DIE and put it in
+   the DIE's type field. */
+
+static void
+read_set_type (struct die_info *die, struct dwarf2_cu *cu)
+{
+  if (die->type == NULL)
+    die->type = create_set_type ((struct type *) NULL, die_type (die, cu));
+}
 
 /* First cut: install each common block member as a global variable.  */
 
@@ -4728,10 +4743,17 @@
 	  code = TYPE_CODE_FLT;
 	  break;
 	case DW_ATE_signed:
-	case DW_ATE_signed_char:
 	  break;
 	case DW_ATE_unsigned:
-	case DW_ATE_unsigned_char:
+	  type_flags |= TYPE_FLAG_UNSIGNED;
+	  break;
+	case DW_ATE_signed_char:
+	  if (cu->language == language_m2)
+	    code = TYPE_CODE_CHAR;
+	  break;
+ 	case DW_ATE_unsigned_char:
+	  if (cu->language == language_m2)
+	    code = TYPE_CODE_CHAR;
 	  type_flags |= TYPE_FLAG_UNSIGNED;
 	  break;
 	default:
@@ -6168,10 +6190,12 @@
     case DW_LANG_Ada95:
       cu->language = language_ada;
       break;
+    case DW_LANG_Modula2:
+      cu->language = language_m2;
+      break;
     case DW_LANG_Cobol74:
     case DW_LANG_Cobol85:
     case DW_LANG_Pascal83:
-    case DW_LANG_Modula2:
     default:
       cu->language = language_minimal;
       break;
@@ -6958,6 +6982,7 @@
 	case DW_TAG_class_type:
 	case DW_TAG_structure_type:
 	case DW_TAG_union_type:
+	case DW_TAG_set_type:
 	case DW_TAG_enumeration_type:
 	  SYMBOL_CLASS (sym) = LOC_TYPEDEF;
 	  SYMBOL_DOMAIN (sym) = STRUCT_DOMAIN;
@@ -7287,6 +7312,9 @@
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_pointer_type:
       read_tag_pointer_type (die, cu);
       break;
--- latest-cvs-gdb/src-cvs/gdb/m2-valprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-valprint.c	2006-04-20 12:18:17.000000000 +0100
@@ -1,7 +1,8 @@
 /* Support for printing Modula 2 values for GDB, the GNU debugger.
 
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998, 2000, 2005 Free
-   Software Foundation, Inc.
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998,
+                 2000, 2005, 2006
+   Free Software Foundation, Inc.
 
    This file is part of GDB.
 
@@ -23,14 +24,542 @@
 #include "defs.h"
 #include "symtab.h"
 #include "gdbtypes.h"
-#include "m2-lang.h"
+#include "expression.h"
+#include "value.h"
+#include "valprint.h"
+#include "language.h"
+#include "typeprint.h"
 #include "c-lang.h"
+#include "m2-lang.h"
+#include "target.h"
+
+int print_unpacked_pointer (struct type *type,
+			    CORE_ADDR address, CORE_ADDR addr,
+			    int format, struct ui_file *stream);
+
+
+/* Print function pointer with inferior address ADDRESS onto stdio
+   stream STREAM.  */
+
+static void
+print_function_pointer_address (CORE_ADDR address, struct ui_file *stream)
+{
+  CORE_ADDR func_addr = gdbarch_convert_from_func_ptr_addr (current_gdbarch,
+							    address,
+							    &current_target);
+
+  /* If the function pointer is represented by a description, print the
+     address of the description.  */
+  if (addressprint && func_addr != address)
+    {
+      fputs_filtered ("@", stream);
+      fputs_filtered (paddress (address), stream);
+      fputs_filtered (": ", stream);
+    }
+  print_address_demangle (func_addr, stream, demangle);
+}
+
+/*
+ *  get_long_set_bounds - assigns the bounds of the long set to low and high.
+ */
+
+int
+get_long_set_bounds (struct type *type, LONGEST *low, LONGEST *high)
+{
+  int len, i;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    *low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    *high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    return 1;
+  }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static void
+m2_print_long_set (struct type *type, const gdb_byte *valaddr, int embedded_offset,
+		   CORE_ADDR address, struct ui_file *stream, int format,
+		   enum val_prettyprint pretty)
+{
+  int empty_set        = 1;
+  int element_seen     = 0;
+  LONGEST previous_low = 0;
+  LONGEST previous_high= 0;
+  LONGEST i, low_bound, high_bound;
+  LONGEST field_low, field_high;
+  struct type *range;
+  int len, field;
+  struct type *target;
+  int bitval;
+
+  CHECK_TYPEDEF (type);
+
+  fprintf_filtered (stream, "{");
+  len = TYPE_NFIELDS (type);
+  if (get_long_set_bounds (type, &low_bound, &high_bound)) {
+    field = TYPE_N_BASECLASSES (type);
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+  }
+  else {
+    fprintf_filtered (stream, " %s }", _("<unknown bounds of set>"));
+    return;
+  }
+
+  target = TYPE_TARGET_TYPE (range);
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (get_discrete_bounds (range, &field_low, &field_high) >= 0) {
+    for (i = low_bound; i <= high_bound; i++) {
+      bitval = value_bit_index (TYPE_FIELD_TYPE (type, field),
+				(TYPE_FIELD_BITPOS (type, field) / 8) +
+				valaddr + embedded_offset, i);
+      if (bitval < 0)
+	error (_("bit test is out of range"));
+      else if (bitval > 0) {
+	previous_high = i;
+	if (! element_seen) {
+	  if (! empty_set)
+	    fprintf_filtered (stream, ", ");
+	  print_type_scalar (target, i, stream);
+	  empty_set    = 0;
+	  element_seen = 1;
+	  previous_low = i;
+	}
+      }
+      else {
+	/* bit is not set */
+	if (element_seen) {
+	  if (previous_low+1 < previous_high)
+	    fprintf_filtered (stream, "..");
+	  if (previous_low+1 < previous_high)
+	    print_type_scalar (target, previous_high, stream);
+	  element_seen = 0;
+	}
+      }
+      if (i == field_high) {
+	field++;
+	if (field == len)
+	  break;
+	range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+	if (get_discrete_bounds (range, &field_low, &field_high) < 0)
+	  break;
+	target = TYPE_TARGET_TYPE (range);
+	if (target == NULL)
+	  target = builtin_type_int;
+      }
+    }
+    if (element_seen) {
+      if (previous_low+1 < previous_high) {
+	fprintf_filtered (stream, "..");
+	print_type_scalar (target, previous_high, stream);
+      }
+      element_seen = 0;
+    }
+    fprintf_filtered (stream, "}");
+  }
+}
+
+int
+print_unpacked_pointer (struct type *type,
+			CORE_ADDR address, CORE_ADDR addr,
+			int format, struct ui_file *stream)
+{
+  struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+  if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
+    {
+      /* Try to print what function it points to.  */
+      print_function_pointer_address (addr, stream);
+      /* Return value is irrelevant except for string pointers.  */
+      return 0;
+    }
+
+  if (addressprint && format != 's')
+    fputs_filtered (paddress (address), stream);
+
+  /* For a pointer to char or unsigned char, also print the string
+     pointed to, unless pointer is null.  */
+
+  if (TYPE_LENGTH (elttype) == 1
+      && TYPE_CODE (elttype) == TYPE_CODE_INT
+      && (format == 0 || format == 's')
+      && addr != 0)
+      return val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
+  
+  return 0;
+}
+
+static void
+print_variable_at_address (struct type *type, const gdb_byte *valaddr,
+			   struct ui_file *stream, int format,
+			   int deref_ref, int recurse, enum val_prettyprint pretty)
+{
+  CORE_ADDR addr = unpack_pointer (type, valaddr);
+  struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+  fprintf_filtered (stream, "[");
+  fputs_filtered (paddress (addr), stream);
+  fprintf_filtered (stream, "] : ");
+  
+  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
+    {
+      struct value *deref_val =
+	value_at
+	(TYPE_TARGET_TYPE (type),
+	 unpack_pointer (lookup_pointer_type (builtin_type_void),
+			 valaddr));
+      common_val_print (deref_val, stream, format, deref_ref,
+			recurse, pretty);
+    }
+  else
+    fputs_filtered ("???", stream);
+}
+
+/* Print data of type TYPE located at VALADDR (within GDB), which came from
+   the inferior at address ADDRESS, onto stdio stream STREAM according to
+   FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
+   target byte order.
+
+   If the data are a string pointer, returns the number of string characters
+   printed.
+
+   If DEREF_REF is nonzero, then dereference references, otherwise just print
+   them like pointers.
+
+   The PRETTY parameter controls prettyprinting.  */
 
 int
 m2_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 	      CORE_ADDR address, struct ui_file *stream, int format,
 	      int deref_ref, int recurse, enum val_prettyprint pretty)
 {
-  return (c_val_print (type, valaddr, 0, address, stream, format, deref_ref,
-		       recurse, pretty));
+  unsigned int i = 0;	/* Number of characters printed */
+  unsigned len;
+  struct type *elttype;
+  unsigned eltlen;
+  int length_pos, length_size, string_pos;
+  int char_size;
+  LONGEST val;
+  CORE_ADDR addr;
+
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
+	{
+	  elttype = check_typedef (TYPE_TARGET_TYPE (type));
+	  eltlen = TYPE_LENGTH (elttype);
+	  len = TYPE_LENGTH (type) / eltlen;
+	  if (prettyprint_arrays)
+	    {
+	      print_spaces_filtered (2 + 2 * recurse, stream);
+	    }
+	  /* For an array of chars, print with string syntax.  */
+	  if (eltlen == 1 &&
+	      ((TYPE_CODE (elttype) == TYPE_CODE_INT)
+	       || ((current_language->la_language == language_m2)
+		   && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
+	      && (format == 0 || format == 's'))
+	    {
+	      /* If requested, look for the first null char and only print
+	         elements up to it.  */
+	      if (stop_print_at_null)
+		{
+		  unsigned int temp_len;
+
+		  /* Look for a NULL char. */
+		  for (temp_len = 0;
+		       (valaddr + embedded_offset)[temp_len]
+		       && temp_len < len && temp_len < print_max;
+		       temp_len++);
+		  len = temp_len;
+		}
+
+	      LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
+	      i = len;
+	    }
+	  else
+	    {
+	      fprintf_filtered (stream, "{");
+	      val_print_array_elements (type, valaddr + embedded_offset, address, stream,
+					format, deref_ref, recurse, pretty, 0);
+	      fprintf_filtered (stream, "}");
+	    }
+	  break;
+	}
+      /* Array of unspecified length: treat like pointer to first elt.  */
+      print_unpacked_pointer (type, address, address, format, stream);
+      break;
+
+    case TYPE_CODE_PTR:
+      if (TYPE_CONST (type))
+	print_variable_at_address (type, valaddr + embedded_offset, stream, format,
+				   deref_ref, recurse, pretty);
+      else if (format && format != 's')
+	print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+      else {
+	addr = unpack_pointer (type, valaddr + embedded_offset);
+	print_unpacked_pointer (type, addr, address, format, stream);
+      }
+      break;
+
+    case TYPE_CODE_MEMBER:
+      error (_("not implemented: member type in m2_val_print"));
+      break;
+
+    case TYPE_CODE_REF:
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+      if (addressprint)
+	{
+	  CORE_ADDR addr
+	    = extract_typed_address (valaddr + embedded_offset, type);
+	  fprintf_filtered (stream, "@");
+	  fputs_filtered (paddress (addr), stream);
+	  if (deref_ref)
+	    fputs_filtered (": ", stream);
+	}
+      /* De-reference the reference.  */
+      if (deref_ref)
+	{
+	  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
+	    {
+	      struct value *deref_val =
+	      value_at
+	      (TYPE_TARGET_TYPE (type),
+	       unpack_pointer (lookup_pointer_type (builtin_type_void),
+			       valaddr + embedded_offset));
+	      common_val_print (deref_val, stream, format, deref_ref,
+				recurse, pretty);
+	    }
+	  else
+	    fputs_filtered ("???", stream);
+	}
+      break;
+
+    case TYPE_CODE_UNION:
+      if (recurse && !unionprint)
+	{
+	  fprintf_filtered (stream, "{...}");
+	  break;
+	}
+      /* Fall through.  */
+    case TYPE_CODE_STRUCT:
+      if (m2_is_long_set (type))
+	m2_print_long_set (type, valaddr, embedded_offset, address, stream, format,
+			   pretty);
+      else
+	cp_print_value_fields (type, type, valaddr, embedded_offset, address, stream, format,
+			       recurse, pretty, NULL, 0);
+      break;
+
+    case TYPE_CODE_ENUM:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      len = TYPE_NFIELDS (type);
+      val = unpack_long (type, valaddr + embedded_offset);
+      for (i = 0; i < len; i++)
+	{
+	  QUIT;
+	  if (val == TYPE_FIELD_BITPOS (type, i))
+	    {
+	      break;
+	    }
+	}
+      if (i < len)
+	{
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	}
+      else
+	{
+	  print_longest (stream, 'd', 0, val);
+	}
+      break;
+
+    case TYPE_CODE_FUNC:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      /* FIXME, we should consider, at least for ANSI C language, eliminating
+         the distinction made between FUNCs and POINTERs to FUNCs.  */
+      fprintf_filtered (stream, "{");
+      type_print (type, "", stream, -1);
+      fprintf_filtered (stream, "} ");
+      /* Try to print what function it points to, and its address.  */
+      print_address_demangle (address, stream, demangle);
+      break;
+
+    case TYPE_CODE_BOOL:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (val == 0)
+	    fputs_filtered ("FALSE", stream);
+	  else if (val == 1)
+	    fputs_filtered ("TRUE", stream);
+	  else
+	    fprintf_filtered (stream, "%ld)", (long int) val);
+	}
+      break;
+
+    case TYPE_CODE_RANGE:
+      if (TYPE_LENGTH (type) == TYPE_LENGTH (TYPE_TARGET_TYPE (type))) {
+	m2_val_print (TYPE_TARGET_TYPE (type), valaddr, embedded_offset,
+		      address, stream, format, deref_ref, recurse, pretty);
+	break;
+      }
+      /* FIXME: create_range_type does not set the unsigned bit in a
+         range type (I think it probably should copy it from the target
+         type), so we won't print values which are too large to
+         fit in a signed integer correctly.  */
+      /* FIXME: Doesn't handle ranges of enums correctly.  (Can't just
+         print with the target type, though, because the size of our type
+         and the target type might differ).  */
+      /* FALLTHROUGH */
+
+    case TYPE_CODE_INT:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val_print_type_code_int (type, valaddr + embedded_offset, stream);
+	}
+      break;
+
+    case TYPE_CODE_CHAR:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (TYPE_UNSIGNED (type))
+	    fprintf_filtered (stream, "%u", (unsigned int) val);
+	  else
+	    fprintf_filtered (stream, "%d", (int) val);
+	  fputs_filtered (" ", stream);
+	  LA_PRINT_CHAR ((unsigned char) val, stream);
+	}
+      break;
+
+    case TYPE_CODE_FLT:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  print_floating (valaddr + embedded_offset, type, stream);
+	}
+      break;
+
+    case TYPE_CODE_METHOD:
+      break;
+
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_SET:
+      elttype = TYPE_INDEX_TYPE (type);
+      CHECK_TYPEDEF (elttype);
+      if (TYPE_STUB (elttype))
+	{
+	  fprintf_filtered (stream, _("<incomplete type>"));
+	  gdb_flush (stream);
+	  break;
+	}
+      else
+	{
+	  struct type *range = elttype;
+	  LONGEST low_bound, high_bound;
+	  int i;
+	  int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
+	  int need_comma = 0;
+
+	  if (is_bitstring)
+	    fputs_filtered ("B'", stream);
+	  else
+	    fputs_filtered ("{", stream);
+
+	  i = get_discrete_bounds (range, &low_bound, &high_bound);
+	maybe_bad_bstring:
+	  if (i < 0)
+	    {
+	      fputs_filtered (_("<error value>"), stream);
+	      goto done;
+	    }
+
+	  for (i = low_bound; i <= high_bound; i++)
+	    {
+	      int element = value_bit_index (type, valaddr + embedded_offset, i);
+	      if (element < 0)
+		{
+		  i = element;
+		  goto maybe_bad_bstring;
+		}
+	      if (is_bitstring)
+		fprintf_filtered (stream, "%d", element);
+	      else if (element)
+		{
+		  if (need_comma)
+		    fputs_filtered (", ", stream);
+		  print_type_scalar (range, i, stream);
+		  need_comma = 1;
+
+		  if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))
+		    {
+		      int j = i;
+		      fputs_filtered ("..", stream);
+		      while (i + 1 <= high_bound
+			     && value_bit_index (type, valaddr + embedded_offset, ++i))
+			j = i;
+		      print_type_scalar (range, j, stream);
+		    }
+		}
+	    }
+	done:
+	  if (is_bitstring)
+	    fputs_filtered ("'", stream);
+	  else
+	    fputs_filtered ("}", stream);
+	}
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "void");
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, _("<error type>"));
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
+         dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
+         and no complete type for struct foo in that file.  */
+      fprintf_filtered (stream, _("<incomplete type>"));
+      break;
+
+    default:
+      error (_("Invalid m2 type code %d in symbol table."), TYPE_CODE (type));
+    }
+  gdb_flush (stream);
+  return (0);
 }
--- latest-cvs-gdb/src-cvs/gdb/doc/gdb.texinfo	2006-04-18 01:17:55.000000000 +0100
+++ latest-cvs-gdb/src-m2/gdb/doc/gdb.texinfo	2006-05-08 14:32:03.000000000 +0100
@@ -9458,6 +9458,7 @@
 * M2 Operators::                Built-in operators
 * Built-In Func/Proc::          Built-in functions and procedures
 * M2 Constants::                Modula-2 constants
+* M2 Types::                    Modula-2 types
 * M2 Defaults::                 Default settings for Modula-2
 * Deviations::                  Deviations from standard Modula-2
 * M2 Checks::                   Modula-2 type and range checks
@@ -9582,7 +9583,7 @@
 @end table
 
 @quotation
-@emph{Warning:} Sets and their operations are not yet supported, so @value{GDBN}
+@emph{Warning:} Set expressions and their operations are not yet supported, so @value{GDBN}
 treats the use of the operator @code{IN}, or the use of operators
 @code{+}, @code{-}, @code{*}, @code{/}, @code{=}, , @code{<>}, @code{#},
 @code{<=}, and @code{>=} on sets as an error.
@@ -9751,6 +9752,170 @@
 Set constants are not yet supported.
 @end itemize
 
+@node M2 Types
+@subsubsection Modula-2 Types
+@cindex Modula-2 types
+
+Currently @value{GDBN} can print the following data types in Modula-2
+syntax: array types, record types, set types, pointer types, procedure
+types, enumerated types, subrange types and base types.  You can also
+print the contents of variables declared using these type.
+This section gives a number of simple source code examples together with
+sample @value{GDBN} sessions.
+
+The first example contains the following section of code:
+
+@smallexample
+VAR
+   s: SET OF CHAR ;
+   r: [20..40] ;
+@end smallexample
+
+@noindent
+and you can request @value{GDBN} to interrogate the type and value of
+@code{r} and @code{s}.
+
+@smallexample
+(@value{GDBP}) print s
+@{'A'..'C', 'Z'@}
+(@value{GDBP}) ptype s
+SET OF CHAR
+(@value{GDBP}) print r
+21
+(@value{GDBP}) ptype r
+[20..40]
+@end smallexample
+
+@noindent
+Likewise if your source code declares @code{s} as:
+
+@smallexample
+VAR
+   s: SET ['A'..'Z'] ;
+@end smallexample
+
+@noindent
+then you may query the type of @code{s} by:
+
+@smallexample
+(@value{GDBP}) ptype s
+type = SET ['A'..'Z']
+@end smallexample
+
+@noindent
+Note that at present you cannot interactively manipulate set
+expressions using the debugger.
+
+The following example shows how you might declare an array in Modula-2
+and how you can interact with @value{GDBN} to print its type and contents:
+
+@smallexample
+VAR
+   s: ARRAY [-10..10] OF CHAR ;
+@end smallexample
+
+@smallexample
+(@value{GDBP}) ptype s
+ARRAY [-10..10] OF CHAR
+@end smallexample
+
+Note that the array handling is not yet complete and although the type
+is printed correctly, expression handling still assumes that all
+arrays have a lower bound of zero and not @code{-10} as in the example
+above.  Unbounded arrays are also not yet recognized in @value{GDBN}.
+
+Here are some more type related Modula-2 examples:
+
+@smallexample
+TYPE
+   colour = (blue, red, yellow, green) ;
+   t = [blue..yellow] ;
+VAR
+   s: t ;
+BEGIN
+   s := blue ;
+@end smallexample
+
+@noindent
+The @value{GDBN} interaction shows how you can query the data type
+and value of a variable.
+
+@smallexample
+(@value{GDBP}) print s
+$1 = blue
+(@value{GDBP}) ptype t
+type = [blue..yellow]
+@end smallexample
+
+@noindent
+In this example a Modula-2 array is declared and its contents
+displayed.  Observe that the contents are written in the same way as
+their @code{C} counterparts.
+
+@smallexample
+VAR
+   s: ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   s[1] := 1 ;
+@end smallexample
+
+@smallexample
+(@value{GDBP}) print s
+$1 = @{1, 0, 0, 0, 0@}
+(@value{GDBP}) ptype s
+type = ARRAY [1..5] OF CARDINAL
+@end smallexample
+
+The Modula-2 language interface to @value{GDBN} also understands
+pointer types as shown in this example:
+
+@smallexample
+VAR
+   s: POINTER TO ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   NEW(s) ;
+   s^[1] := 1 ;
+@end smallexample
+
+@noindent
+and you can request that @value{GDBN} describes the type of @code{s}.
+
+@smallexample
+(@value{GDBP}) ptype s
+type = POINTER TO ARRAY [1..5] OF CARDINAL
+@end smallexample
+
+@value{GDBN} handles compound types as we can see in this example.
+Here we combine array types, record types, pointer types and subrange
+types:
+
+@smallexample
+TYPE
+   foo = RECORD
+            f1: CARDINAL ;
+            f2: CHAR ;
+            f3: myarray ;
+         END ;
+
+   myarray = ARRAY myrange OF CARDINAL ;
+   myrange = [-2..2] ;
+VAR
+   s: POINTER TO ARRAY myrange OF foo ;
+@end smallexample
+
+@noindent
+and you can ask @value{GDBN} to describe the type of @code{s} as shown
+below.
+
+@smallexample
+(@value{GDBP}) ptype s
+type = POINTER TO ARRAY [-2..2] OF foo = RECORD
+    f1 : CARDINAL;
+    f2 : CHAR;
+    f3 : ARRAY [-2..2] OF CARDINAL;
+END 
+@end smallexample
+
 @node M2 Defaults
 @subsubsection Modula-2 defaults
 @cindex Modula-2 defaults

[-- Attachment #3: Type: text/plain, Size: 16 bytes --]


regards,
Gaius

Re: Enhanced language support for Modula-2

[Jim Blandy]

On 5/4/06, Daniel Jacobowitz <drow@false.org> wrote:
> On Thu, May 04, 2006 at 08:03:36AM +0100, Gaius Mulley wrote:
> > many thanks for approving the docs. Do you want me to repost the
> > corrected patch?  Also do you know if the code component of the patch
> > is/was approved?
>
> The last time you posted the patch, Jim Blandy did most of the code
> review.  So I've been staying clear of it in hopes that he would look
> at it again this time :-)  Jim, if you have a chance, could you look
> at the new patch?

...zzz  What?  Oh, yes!  Why, an entirely rewritten Modula-2 type
printer!  Great!

The revised patch looks fine.  The only question I have is, what's up
with m2_type_print_base?  Is that the way it's supposed to be?

Re: Enhanced language support for Modula-2

[Eli Zaretskii]

> Cc: gdb-patches@sources.redhat.com,  jimb@red-bean.com
> From: Gaius Mulley <gaius@glam.ac.uk>
> Date: 04 May 2006 08:03:36 +0100
> 
> many thanks for approving the docs. Do you want me to repost the
> corrected patch?

Yes, please.

> Also do you know if the code component of the patch is/was approved?

I don't remember, but you could search the mailing list archives to
find out.

Re: Enhanced language support for Modula-2

[Daniel Jacobowitz]

On Thu, May 04, 2006 at 08:03:36AM +0100, Gaius Mulley wrote:
> many thanks for approving the docs. Do you want me to repost the
> corrected patch?  Also do you know if the code component of the patch
> is/was approved?

The last time you posted the patch, Jim Blandy did most of the code
review.  So I've been staying clear of it in hopes that he would look
at it again this time :-)  Jim, if you have a chance, could you look
at the new patch?

-- 
Daniel Jacobowitz
CodeSourcery

Re: Enhanced language support for Modula-2

[Gaius Mulley]

Eli Zaretskii <eliz@gnu.org> writes:

> > CC: jimb@red-bean.com
> > From: Gaius Mulley <gaius@glam.ac.uk>
> > Date: 20 Apr 2006 14:11:00 +0100
> > 
> > here are the latest patches for the enhanced Modula-2 support for gdb.
> > In summary I've improved the documentation, rewritten m2-typeprint.c
> > to walk the type tree and improved m2-valprint.c to allow variables
> > declared at addresses to be printed using the Modula-2 syntax.
> 
> The doco patches are approved, but please fix the two minor gotchas
> below, before you commit:
> 
> > +@example
> > +VAR
> > +   s: SET OF CHAR ;
> > +   r: [20..40] ;
> > +@end example
> 
> Please change all uses of @example to @smallexample.  We always use
> @smallexample in GDB; sorry that I failed to mention this before.
> 
> > +above.  Unbounded arrays are also not yet recognised in @value{GDBN}.
>                                              ^^^^^^^^^^
> "recognized": we use the US spelling.
> 
> Thanks.

Hi Eli,

many thanks for approving the docs. Do you want me to repost the
corrected patch?  Also do you know if the code component of the patch
is/was approved?

regards,
Gaius

Re: Enhanced language support for Modula-2

[Eli Zaretskii]

> Date: Thu, 20 Apr 2006 20:47:02 +0200 (CEST)
> From: Mark Kettenis <mark.kettenis@xs4all.nl>
> CC: gaius@glam.ac.uk, gdb-patches@sources.redhat.com, jimb@red-bean.com
> 
> > "recognized": we use the US spelling.
> 
> Oh?  I didn't know that.

Well, learn something new every day.

Re: Enhanced language support for Modula-2

[Mark Kettenis]

> Date: Thu, 20 Apr 2006 17:35:20 +0300
> From: Eli Zaretskii <eliz@gnu.org>
> 
> > CC: jimb@red-bean.com
> > From: Gaius Mulley <gaius@glam.ac.uk>
> > Date: 20 Apr 2006 14:11:00 +0100
> > 
> > here are the latest patches for the enhanced Modula-2 support for gdb.
> > In summary I've improved the documentation, rewritten m2-typeprint.c
> > to walk the type tree and improved m2-valprint.c to allow variables
> > declared at addresses to be printed using the Modula-2 syntax.
> 
> The doco patches are approved, but please fix the two minor gotchas
> below, before you commit:
> 
> > +@example
> > +VAR
> > +   s: SET OF CHAR ;
> > +   r: [20..40] ;
> > +@end example
> 
> Please change all uses of @example to @smallexample.  We always use
> @smallexample in GDB; sorry that I failed to mention this before.
> 
> > +above.  Unbounded arrays are also not yet recognised in @value{GDBN}.
>                                              ^^^^^^^^^^
> "recognized": we use the US spelling.

Oh?  I didn't know that.

Ugh Yuck!

(Sorry couldn't resist).

Re: Enhanced language support for Modula-2

[Eli Zaretskii]

> CC: jimb@red-bean.com
> From: Gaius Mulley <gaius@glam.ac.uk>
> Date: 20 Apr 2006 14:11:00 +0100
> 
> here are the latest patches for the enhanced Modula-2 support for gdb.
> In summary I've improved the documentation, rewritten m2-typeprint.c
> to walk the type tree and improved m2-valprint.c to allow variables
> declared at addresses to be printed using the Modula-2 syntax.

The doco patches are approved, but please fix the two minor gotchas
below, before you commit:

> +@example
> +VAR
> +   s: SET OF CHAR ;
> +   r: [20..40] ;
> +@end example

Please change all uses of @example to @smallexample.  We always use
@smallexample in GDB; sorry that I failed to mention this before.

> +above.  Unbounded arrays are also not yet recognised in @value{GDBN}.
                                             ^^^^^^^^^^
"recognized": we use the US spelling.

Thanks.

Enhanced language support for Modula-2

[Gaius Mulley]

[-- Attachment #1: Type: text/plain, Size: 497 bytes --]


Hi,

here are the latest patches for the enhanced Modula-2 support for gdb.
In summary I've improved the documentation, rewritten m2-typeprint.c
to walk the type tree and improved m2-valprint.c to allow variables
declared at addresses to be printed using the Modula-2 syntax.

These patches can be applied to the latest gdb cvs and they don't
cause any extra regression test failures.  They compile and run
fine on Debian Etch LP64 using gcc-4.0.3.

Hope they might be useful..

regards,
Gaius



[-- Attachment #2: Modula-2 enhancements for gdb --]
[-- Type: application/octet-stream, Size: 41024 bytes --]

--- latest-cvs-gdb/src-cvs/gdb/m2-lang.h	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-lang.h	2006-04-20 12:18:17.000000000 +0100
@@ -27,6 +27,11 @@
 extern void m2_print_type (struct type *, char *, struct ui_file *, int,
 			   int);
 
+extern int m2_is_long_set (struct type *type);
+
 extern int m2_val_print (struct type *, const gdb_byte *, int, CORE_ADDR,
 			 struct ui_file *, int, int, int,
 			 enum val_prettyprint);
+
+extern int get_long_set_bounds (struct type *type, LONGEST *low,
+				LONGEST *high);
--- latest-cvs-gdb/src-cvs/gdb/m2-typeprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-typeprint.c	2006-04-20 12:25:24.000000000 +0100
@@ -1,5 +1,6 @@
 /* Support for printing Modula 2 types for GDB, the GNU debugger.
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1995, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    This file is part of GDB.
@@ -20,22 +21,564 @@
    Boston, MA 02110-1301, USA.  */
 
 #include "defs.h"
+#include "gdb_obstack.h"
 #include "bfd.h"		/* Binary File Description */
 #include "symtab.h"
 #include "gdbtypes.h"
 #include "expression.h"
 #include "value.h"
 #include "gdbcore.h"
-#include "target.h"
 #include "m2-lang.h"
+#include "target.h"
+#include "language.h"
+#include "demangle.h"
+#include "c-lang.h"
+#include "typeprint.h"
+#include "cp-abi.h"
+
+#include "gdb_string.h"
 #include <errno.h>
 
+void m2_type_print_varspec_prefix (struct type *, struct ui_file *, int,
+				   int);
+void m2_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
+				   int show, int passed_a_ptr, int demangled_args);
+
+
+void m2_type_print_base (struct type *type, struct ui_file *stream, int show,
+			 int level);
+
+static void m2_print_bounds (struct type *type,
+			     struct ui_file *stream, int show, int level,
+			     int print_high);
+
+static void m2_typedef (struct type *, struct ui_file *, int, int);
+static void m2_array (struct type *, struct ui_file *, int, int);
+static void m2_pointer (struct type *, struct ui_file *, int, int);
+static void m2_ref (struct type *, struct ui_file *, int, int);
+static void m2_procedure (struct type *, struct ui_file *, int, int);
+static void m2_union (struct type *, struct ui_file *);
+static void m2_enum (struct type *, struct ui_file *, int, int);
+static void m2_range (struct type *, struct ui_file *, int, int);
+static void m2_type_name (struct type *type, struct ui_file *stream);
+static void m2_short_set (struct type *type, struct ui_file *stream, int show, int level);
+static int m2_long_set (struct type *type, struct ui_file *stream, int show, int level);
+static void m2_record_fields (struct type *type, struct ui_file *stream, int show, int level);
+static void m2_unknown (const char *s, struct type *type, struct ui_file *stream, int show, int level);
+
+int m2_is_long_set (struct type *type);
+int m2_is_long_set_of_type (struct type *type, struct type **of_type);
+
+
 void
 m2_print_type (struct type *type, char *varstring, struct ui_file *stream,
 	       int show, int level)
 {
-  extern void c_print_type (struct type *, char *, struct ui_file *, int,
-			    int);
+  enum type_code code;
+  int demangled_args;
+
+  CHECK_TYPEDEF (type);
+  code = TYPE_CODE (type);
+
+  QUIT;
+
+  wrap_here ("    ");
+  if (type == NULL)
+    {
+      fputs_filtered (_("<type unknown>"), stream);
+      return;
+    }
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_SET:
+      m2_short_set(type, stream, show, level);
+      break;
+
+    case TYPE_CODE_STRUCT:
+      if (m2_long_set (type, stream, show, level))
+	break;
+      m2_record_fields (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_TYPEDEF:
+      m2_typedef (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_ARRAY:
+      m2_array (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_PTR:
+      m2_pointer (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_REF:
+      m2_ref (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_MEMBER:
+      m2_unknown (_("member"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_METHOD:
+      m2_unknown (_("method"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_FUNC:
+      m2_procedure (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_UNION:
+      m2_union (type, stream);
+      break;
+
+    case TYPE_CODE_ENUM:
+      m2_enum (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_VOID:
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* i18n: Do not translate the "struct" part! */
+      m2_unknown (_("undef"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_ERROR:
+      m2_unknown (_("error"), type, stream, show, level);
+      break;
+
+    case TYPE_CODE_RANGE:
+      m2_range (type, stream, show, level);
+      break;
+
+    case TYPE_CODE_TEMPLATE:
+      break;
+
+    default:
+      m2_type_name (type, stream);
+      break;
+    }
+}
+
+/*
+ *  m2_type_name - if a, type, has a name then print it.
+ */
+
+void
+m2_type_name (struct type *type, struct ui_file *stream)
+{
+  if (TYPE_NAME (type) != NULL)
+    fputs_filtered (TYPE_NAME (type), stream);
+}
+
+/*
+ *  m2_range - displays a Modula-2 subrange type.
+ */
+
+void
+m2_range (struct type *type, struct ui_file *stream, int show,
+	  int level)
+{
+  if (TYPE_HIGH_BOUND (type) == TYPE_LOW_BOUND (type))
+    m2_type_print_base (TYPE_DOMAIN_TYPE (type), stream, show, level);
+  else {
+    struct type *target = TYPE_TARGET_TYPE (type);
+
+    fprintf_filtered (stream, "[");
+    print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+    fprintf_filtered (stream, "..");
+    print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+    fprintf_filtered (stream, "]");
+  }
+}
+
+static void
+m2_typedef (struct type *type, struct ui_file *stream, int show,
+	    int level)
+{
+  if (TYPE_NAME (type) != NULL) {
+    fputs_filtered (TYPE_NAME (type), stream);
+    fputs_filtered (" = ", stream);
+  }
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+/*
+ *  m2_array - prints out a Modula-2 ARRAY ... OF type
+ */
+
+static void m2_array (struct type *type, struct ui_file *stream,
+		      int show, int level)
+{
+  fprintf_filtered (stream, "ARRAY [");
+  if (TYPE_LENGTH (type) >= 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0
+      && TYPE_ARRAY_UPPER_BOUND_TYPE (type) != BOUND_CANNOT_BE_DETERMINED) {
+    if (TYPE_INDEX_TYPE (type) != 0) {
+      m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 0);
+      fprintf_filtered (stream, "..");
+      m2_print_bounds (TYPE_INDEX_TYPE (type), stream, show, -1, 1);
+    }
+    else
+      fprintf_filtered (stream, "%d",
+			(TYPE_LENGTH (type)
+			 / TYPE_LENGTH (TYPE_TARGET_TYPE (type))));
+  }
+  fprintf_filtered (stream, "] OF ");
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+static void
+m2_pointer (struct type *type, struct ui_file *stream, int show,
+	    int level)
+{
+  if (TYPE_CONST (type))
+    fprintf_filtered (stream, "[...] : ");
+  else
+    fprintf_filtered (stream, "POINTER TO ");
+
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+static void
+m2_ref (struct type *type, struct ui_file *stream, int show,
+	int level)
+{
+  fprintf_filtered (stream, "VAR");
+  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, show, level);
+}
+
+static void
+m2_unknown (const char *s, struct type *type, struct ui_file *stream,
+	    int show, int level)
+{
+  fprintf_filtered (stream, "%s %s", s, _("is unknown"));
+}
+
+static void m2_union (struct type *type, struct ui_file *stream)
+{
+  fprintf_filtered (stream, "union");
+}
+
+static void
+m2_procedure (struct type *type, struct ui_file *stream,
+	      int show, int level)
+{
+  fprintf_filtered (stream, "PROCEDURE ");
+  m2_type_name (type, stream);
+  if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_VOID)
+    {
+      int i, len = TYPE_NFIELDS (type);
+
+      fprintf_filtered (stream, " (");
+      for (i = 0; i < len; i++)
+	{
+	  if (i > 0)
+	    {
+	      fputs_filtered (", ", stream);
+	      wrap_here ("    ");
+	    }
+	  m2_print_type (TYPE_FIELD_TYPE (type, i), "", stream, -1, 0);
+	}
+      if (TYPE_TARGET_TYPE (type) != NULL)
+	{
+	  fprintf_filtered (stream, " : ");
+	  m2_print_type (TYPE_TARGET_TYPE (type), "", stream, 0, 0);
+	}
+    }
+}
+
+static void
+m2_print_bounds (struct type *type,
+		 struct ui_file *stream, int show, int level,
+		 int print_high)
+{
+  struct type *target = TYPE_TARGET_TYPE (type);
+
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (TYPE_NFIELDS(type) == 0)
+    return;
+
+  if (print_high)
+    print_type_scalar (target, TYPE_HIGH_BOUND (type), stream);
+  else
+    print_type_scalar (target, TYPE_LOW_BOUND (type), stream);
+}
+
+static void
+m2_short_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  fprintf_filtered(stream, "SET [");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 0);
+
+  fprintf_filtered(stream, "..");
+  m2_print_bounds (TYPE_INDEX_TYPE (type), stream,
+		   show - 1, level, 1);
+  fprintf_filtered(stream, "]");
+}
+
+int
+m2_is_long_set (struct type *type)
+{
+  LONGEST previous_high = 0;  /* unnecessary initialization keeps gcc -Wall happy */
+  int len, i;
+  struct type *range;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+
+    /*
+     *  check if all fields of the RECORD are consecutive sets
+     */
+    len = TYPE_NFIELDS (type);
+    for (i = TYPE_N_BASECLASSES (type); i < len; i++) {
+      if (TYPE_FIELD_TYPE (type, i) == NULL)
+	return 0;
+      if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) != TYPE_CODE_SET)
+	return 0;
+      if (TYPE_FIELD_NAME (type, i) != NULL
+	  && (strcmp (TYPE_FIELD_NAME (type, i), "") != 0))
+	return 0;
+      range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+      if ((i > TYPE_N_BASECLASSES (type))
+	  && previous_high + 1 != TYPE_LOW_BOUND (range))
+	return 0;
+      previous_high = TYPE_HIGH_BOUND (range);
+    }
+    return len>0;
+  }
+  return 0;
+}
+
+/*
+ *  m2_get_discrete_bounds - a wrapper for get_discrete_bounds which
+ *                           understands that CHARs might be signed.
+ *                           This should be integrated into gdbtypes.c
+ *                           inside get_discrete_bounds.
+ */
+
+int
+m2_get_discrete_bounds (struct type *type, LONGEST *lowp, LONGEST *highp)
+{
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_CHAR:
+      if (TYPE_LENGTH (type) < sizeof (LONGEST)) {
+	if (!TYPE_UNSIGNED (type))
+	  {
+	    *lowp = -(1 << (TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1));
+	    *highp = -*lowp - 1;
+	    return 0;
+	  }
+      }
+      /* fall through */
+    default:
+      return get_discrete_bounds (type, lowp, highp);
+    }
+}
+
+/*
+ *  m2_is_long_set_of_type - returns TRUE if the long set was declared as SET OF <oftype>
+ *                           of_type is assigned to the subtype.
+ */
+
+int
+m2_is_long_set_of_type (struct type *type, struct type **of_type)
+{
+  int len, i;
+  struct type *range;
+  struct type *target;
+  LONGEST l1, l2;
+  LONGEST h1, h2;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i));
+    target = TYPE_TARGET_TYPE (range);
+    if (target == NULL)
+      target = builtin_type_int;
+
+    l1 = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    h1 = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    *of_type = target;
+    if (m2_get_discrete_bounds (target, &l2, &h2) >= 0)
+      return (l1 == l2 && h1 == h2);
+    error (_("long_set failed to find discrete bounds for its subtype"));
+    return 0;
+  }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static int
+m2_long_set (struct type *type, struct ui_file *stream, int show, int level)
+{
+  struct type *index_type;
+  struct type *range_type;
+  struct type *of_type;
+  int i;
+  int len = TYPE_NFIELDS (type);
+  LONGEST low;
+  LONGEST high;
+
+  if (m2_is_long_set (type)) {
+    if (TYPE_TAG_NAME (type) != NULL) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+    else if (TYPE_NAME (type) != NULL) {
+      fputs_filtered (TYPE_NAME (type), stream);
+      if (show == 0)
+	return 1;
+    }
+
+    if (TYPE_TAG_NAME (type) != NULL || TYPE_NAME (type) != NULL)
+      fputs_filtered (" = ", stream);
 
-  c_print_type (type, varstring, stream, show, level);	/* FIXME */
+    if (get_long_set_bounds (type, &low, &high)) {
+      fprintf_filtered(stream, "SET OF ");
+      i = TYPE_N_BASECLASSES (type);
+      if (m2_is_long_set_of_type (type, &of_type))
+	m2_print_type (of_type, "", stream, show - 1, level);
+      else {
+	fprintf_filtered(stream, "[");
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)),
+			 stream, show - 1, level, 0);
+
+	fprintf_filtered(stream, "..");
+
+	m2_print_bounds (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)),
+			 stream, show - 1, level, 1);
+	fprintf_filtered(stream, "]");
+      }
+    }
+    else
+      /* i18n: Do not translate the "SET OF" part! */
+      fprintf_filtered(stream, _("SET OF <unknown>"));
+
+    return 1;
+  }
+  return 0;
+}
+
+void
+m2_record_fields (struct type *type, struct ui_file *stream, int show,
+		  int level)
+{
+  /* Print the tag if it exists. 
+   */
+  if (TYPE_TAG_NAME (type) != NULL) {
+    if (strncmp (TYPE_TAG_NAME (type), "$$", 2) != 0) {
+      fputs_filtered (TYPE_TAG_NAME (type), stream);
+      if (show > 0)
+	fprintf_filtered (stream, " = ");
+    }
+  }
+  wrap_here ("    ");
+  if (show < 0)
+    {
+      if (TYPE_CODE (type) == DECLARED_TYPE_STRUCT)
+	fprintf_filtered (stream, "RECORD ... END ");
+      else if (TYPE_DECLARED_TYPE (type) == DECLARED_TYPE_UNION)
+	fprintf_filtered (stream, "CASE ... END ");
+    }
+  else if (show > 0)
+    {
+      if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
+	fprintf_filtered (stream, "RECORD\n");
+      else if (TYPE_CODE (type) == TYPE_CODE_UNION)
+	/* i18n: Do not translate "CASE" and "OF" */
+	fprintf_filtered (stream, _("CASE <variant> OF\n"));
+      int i;
+      int len = TYPE_NFIELDS (type);
+
+      for (i = TYPE_N_BASECLASSES (type); i < len; i++)
+	{
+	  QUIT;
+
+	  print_spaces_filtered (level + 4, stream);
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	  fputs_filtered (" : ", stream);
+	  m2_print_type (TYPE_FIELD_TYPE (type, i),
+			 "",
+			 stream, 0, level + 4);
+	  if (TYPE_FIELD_PACKED (type, i))
+	    {
+	      /* It is a bitfield.  This code does not attempt
+		 to look at the bitpos and reconstruct filler,
+		 unnamed fields.  This would lead to misleading
+		 results if the compiler does not put out fields
+		 for such things (I don't know what it does).  */
+	      fprintf_filtered (stream, " : %d",
+				TYPE_FIELD_BITSIZE (type, i));
+	    }
+	  fprintf_filtered (stream, ";\n");
+	}
+      
+      fprintfi_filtered (level, stream, "END ");
+    }
+}
+
+void
+m2_enum (struct type *type, struct ui_file *stream, int show, int level)
+{
+  int lastval, i, len;
+
+  if (show < 0)
+    {
+      /* If we just printed a tag name, no need to print anything else.  */
+      if (TYPE_TAG_NAME (type) == NULL)
+	fprintf_filtered (stream, "(...)");
+    }
+  else if (show > 0 || TYPE_TAG_NAME (type) == NULL)
+    {
+      fprintf_filtered (stream, "(");
+      len = TYPE_NFIELDS (type);
+      lastval = 0;
+      for (i = 0; i < len; i++)
+	{
+	  QUIT;
+	  if (i > 0)
+	    fprintf_filtered (stream, ", ");
+	  wrap_here ("    ");
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	  if (lastval != TYPE_FIELD_BITPOS (type, i))
+	    {
+	      fprintf_filtered (stream, " = %d", TYPE_FIELD_BITPOS (type, i));
+	      lastval = TYPE_FIELD_BITPOS (type, i);
+	    }
+	  lastval++;
+	}
+      fprintf_filtered (stream, ")");
+    }
+}
+
+/* Print the name of the type (or the ultimate pointer target,
+   function value or array element), or the description of a
+   structure or union.
+
+   SHOW positive means print details about the type (e.g. enum values),
+   and print structure elements passing SHOW - 1 for show.
+   SHOW negative means just print the type name or struct tag if there is one.
+   If there is no name, print something sensible but concise like
+   "struct {...}".
+   SHOW zero means just print the type name or struct tag if there is one.
+   If there is no name, print something sensible but not as concise like
+   "struct {int x; int y;}".
+
+   LEVEL is the number of spaces to indent by.
+   We increase it for some recursive calls.  */
+
+void
+m2_type_print_base (struct type *type, struct ui_file *stream, int show,
+		    int level)
+{
 }
--- latest-cvs-gdb/src-cvs/gdb/dwarf2read.c	2006-02-09 18:18:41.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/dwarf2read.c	2006-04-20 12:18:17.000000000 +0100
@@ -1,7 +1,7 @@
 /* DWARF 2 debugging format support for GDB.
 
-   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-   2004, 2005, 2006
+   Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+                 2002, 2003, 2004, 2005, 2006
    Free Software Foundation, Inc.
 
    Adapted by Gary Funck (gary@intrepid.com), Intrepid Technology,
@@ -1073,6 +1073,9 @@
 
 static void dwarf2_clear_marks (struct dwarf2_per_cu_data *);
 
+static void read_set_type (struct die_info *, struct dwarf2_cu *);
+
+
 /* Try to locate the sections we need for DWARF 2 debugging
    information and return true if we have enough to do something.  */
 
@@ -2662,6 +2665,9 @@
     case DW_TAG_subroutine_type:
       read_subroutine_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
@@ -4240,6 +4246,15 @@
     };
 }
 
+/* Extract all information from a DW_TAG_set_type DIE and put it in
+   the DIE's type field. */
+
+static void
+read_set_type (struct die_info *die, struct dwarf2_cu *cu)
+{
+  if (die->type == NULL)
+    die->type = create_set_type ((struct type *) NULL, die_type (die, cu));
+}
 
 /* First cut: install each common block member as a global variable.  */
 
@@ -4728,10 +4743,17 @@
 	  code = TYPE_CODE_FLT;
 	  break;
 	case DW_ATE_signed:
-	case DW_ATE_signed_char:
 	  break;
 	case DW_ATE_unsigned:
-	case DW_ATE_unsigned_char:
+	  type_flags |= TYPE_FLAG_UNSIGNED;
+	  break;
+	case DW_ATE_signed_char:
+	  if (cu->language == language_m2)
+	    code = TYPE_CODE_CHAR;
+	  break;
+ 	case DW_ATE_unsigned_char:
+	  if (cu->language == language_m2)
+	    code = TYPE_CODE_CHAR;
 	  type_flags |= TYPE_FLAG_UNSIGNED;
 	  break;
 	default:
@@ -6168,10 +6190,12 @@
     case DW_LANG_Ada95:
       cu->language = language_ada;
       break;
+    case DW_LANG_Modula2:
+      cu->language = language_m2;
+      break;
     case DW_LANG_Cobol74:
     case DW_LANG_Cobol85:
     case DW_LANG_Pascal83:
-    case DW_LANG_Modula2:
     default:
       cu->language = language_minimal;
       break;
@@ -6958,6 +6982,7 @@
 	case DW_TAG_class_type:
 	case DW_TAG_structure_type:
 	case DW_TAG_union_type:
+	case DW_TAG_set_type:
 	case DW_TAG_enumeration_type:
 	  SYMBOL_CLASS (sym) = LOC_TYPEDEF;
 	  SYMBOL_DOMAIN (sym) = STRUCT_DOMAIN;
@@ -7287,6 +7312,9 @@
     case DW_TAG_array_type:
       read_array_type (die, cu);
       break;
+    case DW_TAG_set_type:
+      read_set_type (die, cu);
+      break;
     case DW_TAG_pointer_type:
       read_tag_pointer_type (die, cu);
       break;
--- latest-cvs-gdb/src-cvs/gdb/m2-valprint.c	2005-12-17 22:34:01.000000000 +0000
+++ latest-cvs-gdb/src-m2/gdb/m2-valprint.c	2006-04-20 12:18:17.000000000 +0100
@@ -1,7 +1,8 @@
 /* Support for printing Modula 2 values for GDB, the GNU debugger.
 
-   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998, 2000, 2005 Free
-   Software Foundation, Inc.
+   Copyright (C) 1986, 1988, 1989, 1991, 1992, 1996, 1998,
+                 2000, 2005, 2006
+   Free Software Foundation, Inc.
 
    This file is part of GDB.
 
@@ -23,14 +24,542 @@
 #include "defs.h"
 #include "symtab.h"
 #include "gdbtypes.h"
-#include "m2-lang.h"
+#include "expression.h"
+#include "value.h"
+#include "valprint.h"
+#include "language.h"
+#include "typeprint.h"
 #include "c-lang.h"
+#include "m2-lang.h"
+#include "target.h"
+
+int print_unpacked_pointer (struct type *type,
+			    CORE_ADDR address, CORE_ADDR addr,
+			    int format, struct ui_file *stream);
+
+
+/* Print function pointer with inferior address ADDRESS onto stdio
+   stream STREAM.  */
+
+static void
+print_function_pointer_address (CORE_ADDR address, struct ui_file *stream)
+{
+  CORE_ADDR func_addr = gdbarch_convert_from_func_ptr_addr (current_gdbarch,
+							    address,
+							    &current_target);
+
+  /* If the function pointer is represented by a description, print the
+     address of the description.  */
+  if (addressprint && func_addr != address)
+    {
+      fputs_filtered ("@", stream);
+      fputs_filtered (paddress (address), stream);
+      fputs_filtered (": ", stream);
+    }
+  print_address_demangle (func_addr, stream, demangle);
+}
+
+/*
+ *  get_long_set_bounds - assigns the bounds of the long set to low and high.
+ */
+
+int
+get_long_set_bounds (struct type *type, LONGEST *low, LONGEST *high)
+{
+  int len, i;
+
+  if (TYPE_CODE (type) == TYPE_CODE_STRUCT) {
+    len = TYPE_NFIELDS (type);
+    i = TYPE_N_BASECLASSES (type);
+    if (len == 0)
+      return 0;
+    *low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, i)));
+    *high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, len-1)));
+    return 1;
+  }
+  error (_("expecting long_set"));
+  return 0;
+}
+
+static void
+m2_print_long_set (struct type *type, const gdb_byte *valaddr, int embedded_offset,
+		   CORE_ADDR address, struct ui_file *stream, int format,
+		   enum val_prettyprint pretty)
+{
+  int empty_set        = 1;
+  int element_seen     = 0;
+  LONGEST previous_low = 0;
+  LONGEST previous_high= 0;
+  LONGEST i, low_bound, high_bound;
+  LONGEST field_low, field_high;
+  struct type *range;
+  int len, field;
+  struct type *target;
+  int bitval;
+
+  CHECK_TYPEDEF (type);
+
+  fprintf_filtered (stream, "{");
+  len = TYPE_NFIELDS (type);
+  if (get_long_set_bounds (type, &low_bound, &high_bound)) {
+    field = TYPE_N_BASECLASSES (type);
+    range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+  }
+  else {
+    fprintf_filtered (stream, " %s }", _("<unknown bounds of set>"));
+    return;
+  }
+
+  target = TYPE_TARGET_TYPE (range);
+  if (target == NULL)
+    target = builtin_type_int;
+
+  if (get_discrete_bounds (range, &field_low, &field_high) >= 0) {
+    for (i = low_bound; i <= high_bound; i++) {
+      bitval = value_bit_index (TYPE_FIELD_TYPE (type, field),
+				(TYPE_FIELD_BITPOS (type, field) / 8) +
+				valaddr + embedded_offset, i);
+      if (bitval < 0)
+	error (_("bit test is out of range"));
+      else if (bitval > 0) {
+	previous_high = i;
+	if (! element_seen) {
+	  if (! empty_set)
+	    fprintf_filtered (stream, ", ");
+	  print_type_scalar (target, i, stream);
+	  empty_set    = 0;
+	  element_seen = 1;
+	  previous_low = i;
+	}
+      }
+      else {
+	/* bit is not set */
+	if (element_seen) {
+	  if (previous_low+1 < previous_high)
+	    fprintf_filtered (stream, "..");
+	  if (previous_low+1 < previous_high)
+	    print_type_scalar (target, previous_high, stream);
+	  element_seen = 0;
+	}
+      }
+      if (i == field_high) {
+	field++;
+	if (field == len)
+	  break;
+	range = TYPE_INDEX_TYPE (TYPE_FIELD_TYPE (type, field));
+	if (get_discrete_bounds (range, &field_low, &field_high) < 0)
+	  break;
+	target = TYPE_TARGET_TYPE (range);
+	if (target == NULL)
+	  target = builtin_type_int;
+      }
+    }
+    if (element_seen) {
+      if (previous_low+1 < previous_high) {
+	fprintf_filtered (stream, "..");
+	print_type_scalar (target, previous_high, stream);
+      }
+      element_seen = 0;
+    }
+    fprintf_filtered (stream, "}");
+  }
+}
+
+int
+print_unpacked_pointer (struct type *type,
+			CORE_ADDR address, CORE_ADDR addr,
+			int format, struct ui_file *stream)
+{
+  struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+  if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
+    {
+      /* Try to print what function it points to.  */
+      print_function_pointer_address (addr, stream);
+      /* Return value is irrelevant except for string pointers.  */
+      return 0;
+    }
+
+  if (addressprint && format != 's')
+    fputs_filtered (paddress (address), stream);
+
+  /* For a pointer to char or unsigned char, also print the string
+     pointed to, unless pointer is null.  */
+
+  if (TYPE_LENGTH (elttype) == 1
+      && TYPE_CODE (elttype) == TYPE_CODE_INT
+      && (format == 0 || format == 's')
+      && addr != 0)
+      return val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
+  
+  return 0;
+}
+
+static void
+print_variable_at_address (struct type *type, const gdb_byte *valaddr,
+			   struct ui_file *stream, int format,
+			   int deref_ref, int recurse, enum val_prettyprint pretty)
+{
+  CORE_ADDR addr = unpack_pointer (type, valaddr);
+  struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+  fprintf_filtered (stream, "[");
+  fputs_filtered (paddress (addr), stream);
+  fprintf_filtered (stream, "] : ");
+  
+  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
+    {
+      struct value *deref_val =
+	value_at
+	(TYPE_TARGET_TYPE (type),
+	 unpack_pointer (lookup_pointer_type (builtin_type_void),
+			 valaddr));
+      common_val_print (deref_val, stream, format, deref_ref,
+			recurse, pretty);
+    }
+  else
+    fputs_filtered ("???", stream);
+}
+
+/* Print data of type TYPE located at VALADDR (within GDB), which came from
+   the inferior at address ADDRESS, onto stdio stream STREAM according to
+   FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
+   target byte order.
+
+   If the data are a string pointer, returns the number of string characters
+   printed.
+
+   If DEREF_REF is nonzero, then dereference references, otherwise just print
+   them like pointers.
+
+   The PRETTY parameter controls prettyprinting.  */
 
 int
 m2_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 	      CORE_ADDR address, struct ui_file *stream, int format,
 	      int deref_ref, int recurse, enum val_prettyprint pretty)
 {
-  return (c_val_print (type, valaddr, 0, address, stream, format, deref_ref,
-		       recurse, pretty));
+  unsigned int i = 0;	/* Number of characters printed */
+  unsigned len;
+  struct type *elttype;
+  unsigned eltlen;
+  int length_pos, length_size, string_pos;
+  int char_size;
+  LONGEST val;
+  CORE_ADDR addr;
+
+  CHECK_TYPEDEF (type);
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
+	{
+	  elttype = check_typedef (TYPE_TARGET_TYPE (type));
+	  eltlen = TYPE_LENGTH (elttype);
+	  len = TYPE_LENGTH (type) / eltlen;
+	  if (prettyprint_arrays)
+	    {
+	      print_spaces_filtered (2 + 2 * recurse, stream);
+	    }
+	  /* For an array of chars, print with string syntax.  */
+	  if (eltlen == 1 &&
+	      ((TYPE_CODE (elttype) == TYPE_CODE_INT)
+	       || ((current_language->la_language == language_m2)
+		   && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
+	      && (format == 0 || format == 's'))
+	    {
+	      /* If requested, look for the first null char and only print
+	         elements up to it.  */
+	      if (stop_print_at_null)
+		{
+		  unsigned int temp_len;
+
+		  /* Look for a NULL char. */
+		  for (temp_len = 0;
+		       (valaddr + embedded_offset)[temp_len]
+		       && temp_len < len && temp_len < print_max;
+		       temp_len++);
+		  len = temp_len;
+		}
+
+	      LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
+	      i = len;
+	    }
+	  else
+	    {
+	      fprintf_filtered (stream, "{");
+	      val_print_array_elements (type, valaddr + embedded_offset, address, stream,
+					format, deref_ref, recurse, pretty, 0);
+	      fprintf_filtered (stream, "}");
+	    }
+	  break;
+	}
+      /* Array of unspecified length: treat like pointer to first elt.  */
+      print_unpacked_pointer (type, address, address, format, stream);
+      break;
+
+    case TYPE_CODE_PTR:
+      if (TYPE_CONST (type))
+	print_variable_at_address (type, valaddr + embedded_offset, stream, format,
+				   deref_ref, recurse, pretty);
+      else if (format && format != 's')
+	print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+      else {
+	addr = unpack_pointer (type, valaddr + embedded_offset);
+	print_unpacked_pointer (type, addr, address, format, stream);
+      }
+      break;
+
+    case TYPE_CODE_MEMBER:
+      error (_("not implemented: member type in m2_val_print"));
+      break;
+
+    case TYPE_CODE_REF:
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+      if (addressprint)
+	{
+	  CORE_ADDR addr
+	    = extract_typed_address (valaddr + embedded_offset, type);
+	  fprintf_filtered (stream, "@");
+	  fputs_filtered (paddress (addr), stream);
+	  if (deref_ref)
+	    fputs_filtered (": ", stream);
+	}
+      /* De-reference the reference.  */
+      if (deref_ref)
+	{
+	  if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
+	    {
+	      struct value *deref_val =
+	      value_at
+	      (TYPE_TARGET_TYPE (type),
+	       unpack_pointer (lookup_pointer_type (builtin_type_void),
+			       valaddr + embedded_offset));
+	      common_val_print (deref_val, stream, format, deref_ref,
+				recurse, pretty);
+	    }
+	  else
+	    fputs_filtered ("???", stream);
+	}
+      break;
+
+    case TYPE_CODE_UNION:
+      if (recurse && !unionprint)
+	{
+	  fprintf_filtered (stream, "{...}");
+	  break;
+	}
+      /* Fall through.  */
+    case TYPE_CODE_STRUCT:
+      if (m2_is_long_set (type))
+	m2_print_long_set (type, valaddr, embedded_offset, address, stream, format,
+			   pretty);
+      else
+	cp_print_value_fields (type, type, valaddr, embedded_offset, address, stream, format,
+			       recurse, pretty, NULL, 0);
+      break;
+
+    case TYPE_CODE_ENUM:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      len = TYPE_NFIELDS (type);
+      val = unpack_long (type, valaddr + embedded_offset);
+      for (i = 0; i < len; i++)
+	{
+	  QUIT;
+	  if (val == TYPE_FIELD_BITPOS (type, i))
+	    {
+	      break;
+	    }
+	}
+      if (i < len)
+	{
+	  fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
+	}
+      else
+	{
+	  print_longest (stream, 'd', 0, val);
+	}
+      break;
+
+    case TYPE_CODE_FUNC:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	  break;
+	}
+      /* FIXME, we should consider, at least for ANSI C language, eliminating
+         the distinction made between FUNCs and POINTERs to FUNCs.  */
+      fprintf_filtered (stream, "{");
+      type_print (type, "", stream, -1);
+      fprintf_filtered (stream, "} ");
+      /* Try to print what function it points to, and its address.  */
+      print_address_demangle (address, stream, demangle);
+      break;
+
+    case TYPE_CODE_BOOL:
+      format = format ? format : output_format;
+      if (format)
+	print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (val == 0)
+	    fputs_filtered ("FALSE", stream);
+	  else if (val == 1)
+	    fputs_filtered ("TRUE", stream);
+	  else
+	    fprintf_filtered (stream, "%ld)", (long int) val);
+	}
+      break;
+
+    case TYPE_CODE_RANGE:
+      if (TYPE_LENGTH (type) == TYPE_LENGTH (TYPE_TARGET_TYPE (type))) {
+	m2_val_print (TYPE_TARGET_TYPE (type), valaddr, embedded_offset,
+		      address, stream, format, deref_ref, recurse, pretty);
+	break;
+      }
+      /* FIXME: create_range_type does not set the unsigned bit in a
+         range type (I think it probably should copy it from the target
+         type), so we won't print values which are too large to
+         fit in a signed integer correctly.  */
+      /* FIXME: Doesn't handle ranges of enums correctly.  (Can't just
+         print with the target type, though, because the size of our type
+         and the target type might differ).  */
+      /* FALLTHROUGH */
+
+    case TYPE_CODE_INT:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val_print_type_code_int (type, valaddr + embedded_offset, stream);
+	}
+      break;
+
+    case TYPE_CODE_CHAR:
+      format = format ? format : output_format;
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  val = unpack_long (type, valaddr + embedded_offset);
+	  if (TYPE_UNSIGNED (type))
+	    fprintf_filtered (stream, "%u", (unsigned int) val);
+	  else
+	    fprintf_filtered (stream, "%d", (int) val);
+	  fputs_filtered (" ", stream);
+	  LA_PRINT_CHAR ((unsigned char) val, stream);
+	}
+      break;
+
+    case TYPE_CODE_FLT:
+      if (format)
+	{
+	  print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
+	}
+      else
+	{
+	  print_floating (valaddr + embedded_offset, type, stream);
+	}
+      break;
+
+    case TYPE_CODE_METHOD:
+      break;
+
+    case TYPE_CODE_BITSTRING:
+    case TYPE_CODE_SET:
+      elttype = TYPE_INDEX_TYPE (type);
+      CHECK_TYPEDEF (elttype);
+      if (TYPE_STUB (elttype))
+	{
+	  fprintf_filtered (stream, _("<incomplete type>"));
+	  gdb_flush (stream);
+	  break;
+	}
+      else
+	{
+	  struct type *range = elttype;
+	  LONGEST low_bound, high_bound;
+	  int i;
+	  int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
+	  int need_comma = 0;
+
+	  if (is_bitstring)
+	    fputs_filtered ("B'", stream);
+	  else
+	    fputs_filtered ("{", stream);
+
+	  i = get_discrete_bounds (range, &low_bound, &high_bound);
+	maybe_bad_bstring:
+	  if (i < 0)
+	    {
+	      fputs_filtered (_("<error value>"), stream);
+	      goto done;
+	    }
+
+	  for (i = low_bound; i <= high_bound; i++)
+	    {
+	      int element = value_bit_index (type, valaddr + embedded_offset, i);
+	      if (element < 0)
+		{
+		  i = element;
+		  goto maybe_bad_bstring;
+		}
+	      if (is_bitstring)
+		fprintf_filtered (stream, "%d", element);
+	      else if (element)
+		{
+		  if (need_comma)
+		    fputs_filtered (", ", stream);
+		  print_type_scalar (range, i, stream);
+		  need_comma = 1;
+
+		  if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))
+		    {
+		      int j = i;
+		      fputs_filtered ("..", stream);
+		      while (i + 1 <= high_bound
+			     && value_bit_index (type, valaddr + embedded_offset, ++i))
+			j = i;
+		      print_type_scalar (range, j, stream);
+		    }
+		}
+	    }
+	done:
+	  if (is_bitstring)
+	    fputs_filtered ("'", stream);
+	  else
+	    fputs_filtered ("}", stream);
+	}
+      break;
+
+    case TYPE_CODE_VOID:
+      fprintf_filtered (stream, "void");
+      break;
+
+    case TYPE_CODE_ERROR:
+      fprintf_filtered (stream, _("<error type>"));
+      break;
+
+    case TYPE_CODE_UNDEF:
+      /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
+         dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
+         and no complete type for struct foo in that file.  */
+      fprintf_filtered (stream, _("<incomplete type>"));
+      break;
+
+    default:
+      error (_("Invalid m2 type code %d in symbol table."), TYPE_CODE (type));
+    }
+  gdb_flush (stream);
+  return (0);
 }
--- latest-cvs-gdb/src-cvs/gdb/doc/gdb.texinfo	2006-04-18 01:17:55.000000000 +0100
+++ latest-cvs-gdb/src-m2/gdb/doc/gdb.texinfo	2006-04-20 12:18:17.000000000 +0100
@@ -9458,6 +9458,7 @@
 * M2 Operators::                Built-in operators
 * Built-In Func/Proc::          Built-in functions and procedures
 * M2 Constants::                Modula-2 constants
+* M2 Types::                    Modula-2 types
 * M2 Defaults::                 Default settings for Modula-2
 * Deviations::                  Deviations from standard Modula-2
 * M2 Checks::                   Modula-2 type and range checks
@@ -9582,7 +9583,7 @@
 @end table
 
 @quotation
-@emph{Warning:} Sets and their operations are not yet supported, so @value{GDBN}
+@emph{Warning:} Set expressions and their operations are not yet supported, so @value{GDBN}
 treats the use of the operator @code{IN}, or the use of operators
 @code{+}, @code{-}, @code{*}, @code{/}, @code{=}, , @code{<>}, @code{#},
 @code{<=}, and @code{>=} on sets as an error.
@@ -9751,6 +9752,170 @@
 Set constants are not yet supported.
 @end itemize
 
+@node M2 Types
+@subsubsection Modula-2 Types
+@cindex Modula-2 types
+
+Currently @value{GDBN} can print the following data types in Modula-2
+syntax: array types, record types, set types, pointer types, procedure
+types, enumerated types, subrange types and base types.  You can also
+print the contents of variables declared using these type.
+This section gives a number of simple source code examples together with
+sample @value{GDBN} sessions.
+
+The first example contains the following section of code:
+
+@example
+VAR
+   s: SET OF CHAR ;
+   r: [20..40] ;
+@end example
+
+@noindent
+and you can request @value{GDBN} to interrogate the type and value of
+@code{r} and @code{s}.
+
+@example
+(@value{GDBP}) print s
+@{'A'..'C', 'Z'@}
+(@value{GDBP}) ptype s
+SET OF CHAR
+(@value{GDBP}) print r
+21
+(@value{GDBP}) ptype r
+[20..40]
+@end example
+
+@noindent
+Likewise if your source code declares @code{s} as:
+
+@example
+VAR
+   s: SET ['A'..'Z'] ;
+@end example
+
+@noindent
+then you may query the type of @code{s} by:
+
+@example
+(@value{GDBP}) ptype s
+type = SET ['A'..'Z']
+@end example
+
+@noindent
+Note that at present you cannot interactively manipulate set
+expressions using the debugger.
+
+The following example shows how you might declare an array in Modula-2
+and how you can interact with @value{GDBN} to print its type and contents:
+
+@example
+VAR
+   s: ARRAY [-10..10] OF CHAR ;
+@end example
+
+@example
+(@value{GDBP}) ptype s
+ARRAY [-10..10] OF CHAR
+@end example
+
+Note that the array handling is not yet complete and although the type
+is printed correctly, expression handling still assumes that all
+arrays have a lower bound of zero and not @code{-10} as in the example
+above.  Unbounded arrays are also not yet recognised in @value{GDBN}.
+
+Here are some more type related Modula-2 examples:
+
+@example
+TYPE
+   colour = (blue, red, yellow, green) ;
+   t = [blue..yellow] ;
+VAR
+   s: t ;
+BEGIN
+   s := blue ;
+@end example
+
+@noindent
+The @value{GDBN} interaction shows how you can query the data type
+and value of a variable.
+
+@example
+(@value{GDBP}) print s
+$1 = blue
+(@value{GDBP}) ptype t
+type = [blue..yellow]
+@end example
+
+@noindent
+In this example a Modula-2 array is declared and its contents
+displayed.  Observe that the contents are written in the same way as
+their @code{C} counterparts.
+
+@example
+VAR
+   s: ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   s[1] := 1 ;
+@end example
+
+@example
+(@value{GDBP}) print s
+$1 = @{1, 0, 0, 0, 0@}
+(@value{GDBP}) ptype s
+type = ARRAY [1..5] OF CARDINAL
+@end example
+
+The Modula-2 language interface to @value{GDBN} also understands
+pointer types as shown in this example:
+
+@example
+VAR
+   s: POINTER TO ARRAY [1..5] OF CARDINAL ;
+BEGIN
+   NEW(s) ;
+   s^[1] := 1 ;
+@end example
+
+@noindent
+and you can request that @value{GDBN} describes the type of @code{s}.
+
+@example
+(@value{GDBP}) ptype s
+type = POINTER TO ARRAY [1..5] OF CARDINAL
+@end example
+
+@value{GDBN} handles compound types as we can see in this example.
+Here we combine array types, record types, pointer types and subrange
+types:
+
+@example
+TYPE
+   foo = RECORD
+            f1: CARDINAL ;
+            f2: CHAR ;
+            f3: myarray ;
+         END ;
+
+   myarray = ARRAY myrange OF CARDINAL ;
+   myrange = [-2..2] ;
+VAR
+   s: POINTER TO ARRAY myrange OF foo ;
+@end example
+
+@noindent
+and you can ask @value{GDBN} to describe the type of @code{s} as shown
+below.
+
+@example
+(@value{GDBP}) ptype s
+type = POINTER TO ARRAY [-2..2] OF foo = RECORD
+    f1 : CARDINAL;
+    f2 : CHAR;
+    f3 : ARRAY [-2..2] OF CARDINAL;
+END 
+@end example
+
 @node M2 Defaults
 @subsubsection Modula-2 defaults
 @cindex Modula-2 defaults