Very first program compiles.

12 files changed, 223 insertions, 1 deletions

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index b8308ae..cc358f0 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -4342,6 +4342,17 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
       goto get_kind;
     }
 
+  if (flag_unsigned)
+    {
+      if ((matched_type && strcmp ("unsigned", name) == 0)
+	  || (!matched_type && gfc_match (" unsigned") == MATCH_YES))
+	{
+	  ts->type = BT_UNSIGNED;
+	  ts->kind = gfc_default_integer_kind;
+	  goto get_kind;
+	}
+    }
+
   if ((matched_type && strcmp ("character", name) == 0)
       || (!matched_type && gfc_match (" character") == MATCH_YES))
     {
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 80aa8ef..e94dc49 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -563,6 +563,14 @@ show_expr (gfc_expr *p)
 	    fprintf (dumpfile, "_%d", p->ts.kind);
 	  break;
 
+	case BT_UNSIGNED:
+	  mpz_out_str (dumpfile, 10, p->value.integer);
+	  fputc('u', dumpfile);
+
+	  if (p->ts.kind != gfc_default_integer_kind)
+	    fprintf (dumpfile, "_%d", p->ts.kind);
+	  break;
+
 	case BT_LOGICAL:
 	  if (p->value.logical)
 	    fputs (".true.", dumpfile);
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 8de694e..2c1f965 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -159,6 +159,7 @@ gfc_get_constant_expr (bt type, int kind, locus *where)
   switch (type)
     {
     case BT_INTEGER:
+    case BT_UNSIGNED:
       mpz_init (e->value.integer);
       break;
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 3bdf18d..d51960f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2732,6 +2732,25 @@ gfc_integer_info;
 
 extern gfc_integer_info gfc_integer_kinds[];
 
+/* Unsigned numbers, experimental.  */
+
+typedef struct
+{
+  mpz_t huge;
+
+  int kind, radix, digits, bit_size, range;
+
+  /* True if the C type of the given name maps to this precision.  Note that
+     more than one bit can be set.  We will use this later on.  */
+  unsigned int c_unsigned_char : 1;
+  unsigned int c_unsigned_short : 1;
+  unsigned int c_unsigned_int : 1;
+  unsigned int c_unsigned_long : 1;
+  unsigned int c_unsigned_long_long : 1;
+}
+gfc_unsigned_info;
+
+extern gfc_unsigned_info gfc_unsigned_kinds[];
 
 typedef struct
 {
@@ -3455,6 +3474,7 @@ tree gfc_get_union_type (gfc_symbol *);
 tree gfc_get_derived_type (gfc_symbol * derived, int codimen = 0);
 extern int gfc_index_integer_kind;
 extern int gfc_default_integer_kind;
+extern int gfc_default_unsigned_kind;
 extern int gfc_max_integer_kind;
 extern int gfc_default_real_kind;
 extern int gfc_default_double_kind;
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 2cb4a5a..895629d 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -190,7 +190,7 @@ typedef enum
 typedef enum
 { BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX,
   BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID,
-  BT_ASSUMED, BT_UNION, BT_BOZ
+  BT_ASSUMED, BT_UNION, BT_BOZ, BT_UNSIGNED
 }
 bt;
 
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 1851a8f..e206da9 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -2131,6 +2131,13 @@ gfc_match_type_spec (gfc_typespec *ts)
       goto kind_selector;
     }
 
+  if (flag_unsigned && gfc_match ("unsigned") == MATCH_YES)
+    {
+      ts->type = BT_UNSIGNED;
+      ts->kind = gfc_default_integer_kind;
+      goto kind_selector;
+    }
+
   if (gfc_match ("double precision") == MATCH_YES)
     {
       ts->type = BT_REAL;
diff --git a/gcc/fortran/misc.cc b/gcc/fortran/misc.cc
index a365cec..9918295 100644
--- a/gcc/fortran/misc.cc
+++ b/gcc/fortran/misc.cc
@@ -70,6 +70,9 @@ gfc_basic_typename (bt type)
     case BT_INTEGER:
       p = "INTEGER";
       break;
+    case BT_UNSIGNED:
+      p = "UNSIGNED";
+      break;
     case BT_REAL:
       p = "REAL";
       break;
@@ -145,6 +148,9 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
       else
 	sprintf (buffer, "INTEGER(%d)", ts->kind);
       break;
+    case BT_UNSIGNED:
+      sprintf (buffer, "UNSIGNED(%d)", ts->kind);
+      break;
     case BT_REAL:
       sprintf (buffer, "REAL(%d)", ts->kind);
       break;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 76f6bcb..d2a6e69 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -209,6 +209,24 @@ convert_integer (const char *buffer, int kind, int radix, locus *where)
 }
 
 
+/* Convert an unsigned string to an expression node.  XXX:
+   This needs a calculation modulo 2^n.  */
+static gfc_expr *
+convert_unsigned (const char *buffer, int kind, int radix, locus *where)
+{
+  gfc_expr *e;
+  mpz_t tmp;
+  mpz_init_set_ui (tmp, 1);
+  /* XXX  Change this later.  */
+  mpz_mul_2exp (tmp, tmp, kind * 8);
+  mpz_sub_ui (tmp, tmp, 1);
+  e = gfc_get_constant_expr (BT_UNSIGNED, kind, where);
+  mpz_set_str (e->value.integer, buffer, radix);
+  mpz_and (e->value.integer, e->value.integer, tmp);
+  mpz_clear (tmp);
+  return e;
+}
+
 /* Convert a real string to an expression node.  */
 
 static gfc_expr *
@@ -296,6 +314,61 @@ match_integer_constant (gfc_expr **result, int signflag)
   return MATCH_YES;
 }
 
+/* Match an unsigned constant (an integer with suffixed u).  No sign
+   is currently accepted, in accordance with 24-116.txt, but that
+   could be changed later.  This is very much like the integer
+   constant matching above, but with enough differences to put it into
+   its own function.  */
+
+static match
+match_unsigned_constant (gfc_expr **result)
+{
+  int length, kind, is_iso_c;
+  locus old_loc;
+  char *buffer;
+  gfc_expr *e;
+  match m;
+
+  old_loc = gfc_current_locus;
+  gfc_gobble_whitespace ();
+
+  length = match_digits (/* signflag = */ false, 10, NULL);
+  gfc_current_locus = old_loc;
+  if (length == -1)
+    return MATCH_NO;
+
+  buffer = (char *) alloca (length + 1);
+  memset (buffer, '\0', length + 1);
+
+  gfc_gobble_whitespace ();
+
+  match_digits (false, 10, buffer);
+  m = gfc_match_char ('u');
+  if (m == MATCH_NO)
+    return m;
+
+  kind = get_kind (&is_iso_c);
+  if (kind == -2)
+    kind = gfc_default_unsigned_kind;
+  if (kind == -1)
+    return MATCH_ERROR;
+
+  if (kind == 4 && flag_integer4_kind == 8)
+    kind = 8;
+
+  if (gfc_validate_kind (BT_UNSIGNED, kind, true) < 0)
+    {
+      gfc_error ("Unsigned kind %d at %C not available", kind);
+      return MATCH_ERROR;
+    }
+
+  e = convert_unsigned (buffer, kind, 10, &gfc_current_locus);
+  e->ts.is_c_interop = is_iso_c;
+
+  *result = e;
+  return MATCH_YES;
+
+}
 
 /* Match a Hollerith constant.  */
 
@@ -1549,6 +1622,13 @@ gfc_match_literal_constant (gfc_expr **result, int signflag)
   if (m != MATCH_NO)
     return m;
 
+  if (flag_unsigned)
+    {
+      m = match_unsigned_constant (result);
+      if (m != MATCH_NO)
+	return m;
+    }
+
   m = match_integer_constant (result, signflag);
   if (m != MATCH_NO)
     return m;
diff --git a/gcc/fortran/trans-const.cc b/gcc/fortran/trans-const.cc
index fc5b6d0..204f4df 100644
--- a/gcc/fortran/trans-const.cc
+++ b/gcc/fortran/trans-const.cc
@@ -206,6 +206,14 @@ gfc_conv_mpz_to_tree (mpz_t i, int kind)
   return wide_int_to_tree (gfc_get_int_type (kind), val);
 }
 
+/* Same, but for unsigned.  */
+
+tree
+gfc_conv_mpz_unsigned_to_tree (mpz_t i, int kind)
+{
+  wide_int val = wi:: from_mpz (gfc_get_unsigned_type (kind), i, true);
+  return wide_int_to_tree (gfc_get_unsigned_type (kind), val);
+}
 
 /* Convert a GMP integer into a tree node of type given by the type
    argument.  */
@@ -315,6 +323,9 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
       else
 	return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
 
+    case BT_UNSIGNED:
+      return gfc_conv_mpz_unsigned_to_tree (expr->value.integer, expr->ts.kind);
+
     case BT_REAL:
       if (expr->representation.string)
 	return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 59d7213..a00dc80 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -86,8 +86,10 @@ static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)];
 #define MAX_INT_KINDS 5
 gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
 gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
+gfc_unsigned_info gfc_unsigned_kinds[MAX_INT_KINDS + 1];
 static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
 static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
+static GTY(()) tree gfc_unsigned_types[MAX_INT_KINDS + 1];
 
 #define MAX_REAL_KINDS 5
 gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
@@ -109,6 +111,7 @@ int gfc_index_integer_kind;
 /* The default kinds of the various types.  */
 
 int gfc_default_integer_kind;
+int gfc_default_unsigned_kind;
 int gfc_max_integer_kind;
 int gfc_default_real_kind;
 int gfc_default_double_kind;
@@ -413,6 +416,14 @@ gfc_init_kinds (void)
       gfc_integer_kinds[i_index].digits = bitsize - 1;
       gfc_integer_kinds[i_index].bit_size = bitsize;
 
+      if (flag_unsigned)
+	{
+	  gfc_unsigned_kinds[i_index].kind = kind;
+	  gfc_unsigned_kinds[i_index].radix = 2;
+	  gfc_unsigned_kinds[i_index].digits = bitsize;
+	  gfc_unsigned_kinds[i_index].bit_size = bitsize;
+	}
+
       gfc_logical_kinds[i_index].kind = kind;
       gfc_logical_kinds[i_index].bit_size = bitsize;
 
@@ -585,6 +596,8 @@ gfc_init_kinds (void)
       gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
     }
 
+  gfc_default_unsigned_kind = gfc_default_integer_kind;
+
   /* Choose the default real kind.  Again, we choose 4 when possible.  */
   if (flag_default_real_8)
     {
@@ -757,6 +770,18 @@ validate_integer (int kind)
 }
 
 static int
+validate_unsigned (int kind)
+{
+  int i;
+
+  for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
+    if (gfc_unsigned_kinds[i].kind == kind)
+      return i;
+
+  return -1;
+}
+
+static int
 validate_real (int kind)
 {
   int i;
@@ -810,6 +835,9 @@ gfc_validate_kind (bt type, int kind, bool may_fail)
     case BT_INTEGER:
       rc = validate_integer (kind);
       break;
+    case BT_UNSIGNED:
+      rc = validate_unsigned (kind);
+      break;
     case BT_LOGICAL:
       rc = validate_logical (kind);
       break;
@@ -880,6 +908,24 @@ gfc_build_uint_type (int size)
   return make_unsigned_type (size);
 }
 
+static tree
+gfc_build_unsigned_type (gfc_unsigned_info *info)
+{
+  int mode_precision = info->bit_size;
+
+  if (mode_precision == CHAR_TYPE_SIZE)
+    info->c_unsigned_char = 1;
+  if (mode_precision == SHORT_TYPE_SIZE)
+    info->c_unsigned_short = 1;
+  if (mode_precision == INT_TYPE_SIZE)
+    info->c_unsigned_int = 1;
+  if (mode_precision == LONG_TYPE_SIZE)
+    info->c_unsigned_long = 1;
+  if (mode_precision == LONG_LONG_TYPE_SIZE)
+    info->c_unsigned_long_long = 1;
+
+  return gfc_build_uint_type (mode_precision);
+}
 
 static tree
 gfc_build_real_type (gfc_real_info *info)
@@ -992,6 +1038,18 @@ gfc_init_types (void)
       PUSH_TYPE (name_buf, type);
     }
 
+  if (flag_unsigned)
+    {
+      for (index = 0; gfc_unsigned_kinds[index].kind != 0;++index)
+	{
+	  type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]);
+	  gfc_unsigned_types[index] = type;
+	  snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d",
+		    gfc_integer_kinds[index].kind);
+	  PUSH_TYPE (name_buf, type);
+	}
+    }
+
   for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
     {
       type = gfc_build_logical_type (&gfc_logical_kinds[index]);
@@ -1093,6 +1151,13 @@ gfc_get_int_type (int kind)
 }
 
 tree
+gfc_get_unsigned_type (int kind)
+{
+  int index = gfc_validate_kind (BT_INTEGER, kind, true);
+  return index < 0 ? 0 : gfc_integer_types[index];
+}
+
+tree
 gfc_get_real_type (int kind)
 {
   int index = gfc_validate_kind (BT_REAL, kind, true);
@@ -1192,6 +1257,10 @@ gfc_typenode_for_spec (gfc_typespec * spec, int codim)
         basetype = gfc_get_int_type (spec->kind);
       break;
 
+    case BT_UNSIGNED:
+      basetype = gfc_get_unsigned_type (spec->kind);
+      break;
+
     case BT_REAL:
       basetype = gfc_get_real_type (spec->kind);
       break;
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 60096fa..afc4da9 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -76,6 +76,7 @@ void gfc_init_c_interop_kinds (void);
 
 tree get_dtype_type_node (void);
 tree gfc_get_int_type (int);
+tree gfc_get_unsigned_type (int);
 tree gfc_get_real_type (int);
 tree gfc_get_complex_type (int);
 tree gfc_get_logical_type (int);
diff --git a/gcc/testsuite/gfortran.dg/unsigned_1.f90 b/gcc/testsuite/gfortran.dg/unsigned_1.f90
new file mode 100644
index 0000000..e8caadc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_1.f90
@@ -0,0 +1,8 @@
+! { dg-do compile }
+! { dg-options "-funsigned" }
+! A first, very simple program, that should compile.
+program memain
+  unsigned :: u
+  u = 1U
+  u = 2u
+end program memain