Mirror of the gdb-patches mailing list
 help / color / mirror / Atom feed
* Enhanced language support for Modula-2
@ 2006-04-20 13:23 Gaius Mulley
  2006-04-20 14:35 ` Eli Zaretskii
  0 siblings, 1 reply; 45+ messages in thread
From: Gaius Mulley @ 2006-04-20 13:23 UTC (permalink / raw)
  To: gdb-patches; +Cc: jimb

[-- 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

^ permalink raw reply	[flat|nested] 45+ messages in thread
* Enhanced language support for Modula-2
@ 2006-02-15 23:15 Gaius Mulley
  2006-02-16  0:20 ` Jim Blandy
  2006-02-16  4:34 ` Eli Zaretskii
  0 siblings, 2 replies; 45+ messages in thread
From: Gaius Mulley @ 2006-02-15 23:15 UTC (permalink / raw)
  To: gdb-patches



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);
 }


^ permalink raw reply	[flat|nested] 45+ messages in thread
end of thread, other threads:[~2006-05-13 19:08 UTC | newest]

Thread overview: 45+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2006-04-20 13:23 Enhanced language support for Modula-2 Gaius Mulley
2006-04-20 14:35 ` Eli Zaretskii
2006-04-20 18:47   ` Mark Kettenis
2006-04-20 18:54     ` Eli Zaretskii
2006-05-04  7:17   ` Gaius Mulley
2006-05-04 15:37     ` Daniel Jacobowitz
2006-05-04 18:01       ` Jim Blandy
2006-05-08 14:09         ` Gaius Mulley
2006-05-08 17:47           ` Jim Blandy
2006-05-09 22:57             ` Gaius Mulley
2006-05-10 21:45               ` Jim Blandy
2006-05-11 12:37                 ` Gaius Mulley
2006-05-12 18:18                   ` Joel Brobecker
2006-05-12 18:27                     ` Jim Blandy
2006-05-13 13:31                       ` Gaius Mulley
2006-05-13 16:24                       ` [commit]: " Gaius Mulley
2006-05-13 16:43                         ` Daniel Jacobowitz
2006-05-13 18:56                           ` Gaius Mulley
2006-05-13 19:08                             ` Daniel Jacobowitz
2006-05-13 19:44                               ` Gaius Mulley
2006-05-13 11:02                     ` Gaius Mulley
2006-05-08 21:03           ` Eli Zaretskii
2006-05-04 16:12     ` Eli Zaretskii
  -- strict thread matches above, loose matches on Subject: below --
2006-02-15 23:15 Gaius Mulley
2006-02-16  0:20 ` Jim Blandy
2006-02-16 11:06   ` Gaius Mulley
2006-02-20 15:05   ` Daniel Jacobowitz
2006-02-20 21:42     ` Jim Blandy
2006-02-21 11:06       ` Gaius Mulley
2006-02-21 19:01         ` Jim Blandy
2006-02-25 13:17           ` Gaius Mulley
2006-02-26  5:44             ` Jim Blandy
2006-02-26  5:46               ` Daniel Jacobowitz
2006-02-28  5:37               ` Gaius Mulley
2006-02-28 13:53                 ` Jim Blandy
2006-03-02  8:57                   ` Gaius Mulley
2006-03-02 17:27                     ` Jim Blandy
2006-02-21 19:21         ` Jim Blandy
2006-02-21 20:51           ` Eli Zaretskii
2006-02-21 20:50         ` Eli Zaretskii
2006-02-21 20:57           ` Mark Kettenis
2006-02-22  5:33             ` Eli Zaretskii
2006-02-22 18:36               ` Eli Zaretskii
2006-02-16  4:34 ` Eli Zaretskii
2006-02-16 11:11   ` Gaius Mulley

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox