https://gcc.gnu.org/g:cb2e6d872e374ee0df02414e1c1f31ed4cb28be8
commit cb2e6d872e374ee0df02414e1c1f31ed4cb28be8
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Mon Jul 22 22:53:27 2024 +0200
Very first program compiles.
Diff:
---
gcc/fortran/decl.cc | 11 +++++
gcc/fortran/dump-parse-tree.cc | 8 ++++
gcc/fortran/expr.cc | 1 +
gcc/fortran/gfortran.h | 20 ++++++++
gcc/fortran/libgfortran.h | 2 +-
gcc/fortran/match.cc | 7 +++
gcc/fortran/misc.cc | 6 +++
gcc/fortran/primary.cc | 80 ++++++++++++++++++++++++++++++++
gcc/fortran/trans-const.cc | 11 +++++
gcc/fortran/trans-types.cc | 69 +++++++++++++++++++++++++++
gcc/fortran/trans-types.h | 1 +
gcc/testsuite/gfortran.dg/unsigned_1.f90 | 8 ++++
12 files changed, 223 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index b8308aeee550..cc358f09b838 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 80aa8ef84e71..e94dc495708a 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 8de694e31da7..2c1f965c73a2 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 3bdf18d6f9bc..d51960ff0d31 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 2cb4a5a08ffd..895629d6f801 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 1851a8f94a54..e206da95bde1 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 a365cec9b492..991829516efe 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 76f6bcb8a789..d2a6e69fa428 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 fc5b6d030578..204f4df301c0 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 59d72136a0de..a00dc80bf596 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)
{
@@ -756,6 +769,18 @@ validate_integer (int kind)
return -1;
}
+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)
{
@@ -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]);
@@ -1092,6 +1150,13 @@ gfc_get_int_type (int kind)
return index < 0 ? 0 : gfc_integer_types[index];
}
+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)
{
@@ -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 60096facde81..afc4da995265 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 000000000000..e8caadca9d98
--- /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
