Re: Enhanced language support for Modula-2

[Gaius Mulley <gaius@glam.ac.uk>]

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