fget.c: New file.

	* intrinsics/fget.c: New file.
	* intrinsics/ftell.c: New file.
	* io/unix.c (stream_offset): New function.
	* io/io.h: Add prototype for stream_offset.
	* Makefile.am: Add intrinsics/fget.c and intrinsics/ftell.c.
	* Makefile.in: Regenerate.

	* intrinsic.c (add_functions): Add COMPLEX, FTELL, FGETC, FGET,
	FPUTC, FPUT, AND, XOR and OR intrinsic functions.
	(add_subroutines): Add FGETC, FGET, FPUTC, FPUT and FTELL intrinsic
	subroutines.
	* gfortran.h: Add GFC_ISYM_AND, GFC_ISYM_COMPLEX, GFC_ISYM_FGET,
	GFC_ISYM_FGETC, GFC_ISYM_FPUT, GFC_ISYM_FPUTC, GFC_ISYM_FTELL,
	GFC_ISYM_OR, GFC_ISYM_XOR.
	* iresolve.c (gfc_resolve_and, gfc_resolve_complex,
	gfc_resolve_or, gfc_resolve_fgetc, gfc_resolve_fget,
	gfc_resolve_fputc, gfc_resolve_fput, gfc_resolve_ftell,
	gfc_resolve_xor, gfc_resolve_fgetc_sub, gfc_resolve_fget_sub,
	gfc_resolve_fputc_sub, gfc_resolve_fput_sub, gfc_resolve_ftell_sub):
	New functions.
	* check.c (gfc_check_complex, gfc_check_fgetputc_sub,
	gfc_check_fgetputc, gfc_check_fgetput_sub, gfc_check_fgetput,
	gfc_check_ftell, gfc_check_ftell_sub, gfc_check_and): New functions.
	* simplify.c (gfc_simplify_and, gfc_simplify_complex, gfc_simplify_or,
	gfc_simplify_xor): New functions.
	* trans-intrinsic.c (gfc_conv_intrinsic_function): Add cases for
	GFC_ISYM_AND, GFC_ISYM_COMPLEX, GFC_ISYM_FGET, GFC_ISYM_FGETC,
	GFC_ISYM_FPUT, GFC_ISYM_FPUTC, GFC_ISYM_FTELL, GFC_ISYM_OR and
	GFC_ISYM_XOR.
	* intrinsic.h: Add prototypes for all functions added to iresolve.c,
	simplify.c and check.c.

	* gfortran.dg/complex_intrinsic_1.f90: New test.
	* gfortran.dg/complex_intrinsic_2.f90: New test.
	* gfortran.dg/fgetc_1.f90: New test.
	* gfortran.dg/fgetc_2.f90: New test.
	* gfortran.dg/fgetc_3.f90: New test.
	* gfortran.dg/ftell_1.f90: New test.
	* gfortran.dg/ftell_2.f90: New test.
	* gfortran.dg/gnu_logical_1.F: New test.
	* gfortran.dg/gnu_logical_2.f90: New test.

From-SVN: r106859

1 files changed, 281 insertions, 0 deletions

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 22aeda8..de3c271 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -118,6 +118,26 @@ gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
 
 
 void
+gfc_resolve_and (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+{
+  f->ts.type = i->ts.type;
+  f->ts.kind = gfc_kind_max (i,j);
+
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (i->ts.kind == gfc_kind_max (i,j))
+	gfc_convert_type(j, &i->ts, 2);
+      else
+	gfc_convert_type(i, &j->ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string ("__and_%c%d",
+					   gfc_type_letter (i->ts.type),
+					   f->ts.kind);
+}
+
+
+void
 gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
 {
   gfc_typespec ts;
@@ -357,6 +377,36 @@ gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
 }
 
 void
+gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
+{
+  int kind;
+
+  if (x->ts.type == BT_INTEGER)
+    {
+      if (y->ts.type == BT_INTEGER)
+	kind = gfc_default_real_kind;
+      else
+	kind = y->ts.kind;
+    }
+  else
+    {
+      if (y->ts.type == BT_REAL)
+	kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
+      else
+	kind = x->ts.kind;
+    }
+
+  f->ts.type = BT_COMPLEX;
+  f->ts.kind = kind;
+
+  f->value.function.name =
+    gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
+		    gfc_type_letter (x->ts.type), x->ts.kind,
+		    gfc_type_letter (y->ts.type), y->ts.kind);
+}
+
+
+void
 gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
 {
   f->ts = x->ts;
@@ -1178,6 +1228,26 @@ gfc_resolve_not (gfc_expr * f, gfc_expr * i)
 
 
 void
+gfc_resolve_or (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+{
+  f->ts.type = i->ts.type;
+  f->ts.kind = gfc_kind_max (i,j);
+
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (i->ts.kind == gfc_kind_max (i,j))
+	gfc_convert_type(j, &i->ts, 2);
+      else
+	gfc_convert_type(i, &j->ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string ("__or_%c%d",
+					   gfc_type_letter (i->ts.type),
+					   f->ts.kind);
+}
+
+
+void
 gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
 		  gfc_expr * vector ATTRIBUTE_UNUSED)
 {
@@ -1554,6 +1624,84 @@ gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
 
 
 void
+gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
+{
+  gfc_typespec ts;
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.derived = NULL;
+      ts.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX("fgetc"));
+}
+
+
+void
+gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  f->value.function.name = gfc_get_string (PREFIX("fget"));
+}
+
+
+void
+gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
+{
+  gfc_typespec ts;
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.derived = NULL;
+      ts.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX("fputc"));
+}
+
+
+void
+gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
+{
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_c_int_kind;
+  f->value.function.name = gfc_get_string (PREFIX("fput"));
+}
+
+
+void
+gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
+{
+  gfc_typespec ts;
+
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_index_integer_kind;
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.derived = NULL;
+      ts.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string (PREFIX("ftell"));
+}
+
+
+void
 gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
 		 gfc_expr * mask)
 {
@@ -1799,6 +1947,26 @@ gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
 }
 
 
+void
+gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
+{
+  f->ts.type = i->ts.type;
+  f->ts.kind = gfc_kind_max (i,j);
+
+  if (i->ts.kind != j->ts.kind)
+    {
+      if (i->ts.kind == gfc_kind_max (i,j))
+	gfc_convert_type(j, &i->ts, 2);
+      else
+	gfc_convert_type(i, &j->ts, 2);
+    }
+
+  f->value.function.name = gfc_get_string ("__xor_%c%d",
+					   gfc_type_letter (i->ts.type),
+					   f->ts.kind);
+}
+
+
 /* Intrinsic subroutine resolution.  */
 
 void
@@ -2266,6 +2434,119 @@ gfc_resolve_fstat_sub (gfc_code * c)
 
 
 void
+gfc_resolve_fgetc_sub (gfc_code * c)
+{
+  const char *name;
+  gfc_typespec ts;
+  gfc_expr *u, *st;
+
+  u = c->ext.actual->expr;
+  st = c->ext.actual->next->next->expr;
+
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.derived = NULL;
+      ts.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  if (st != NULL)
+    name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
+  else
+    name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_fget_sub (gfc_code * c)
+{
+  const char *name;
+  gfc_expr *st;
+
+  st = c->ext.actual->next->expr;
+  if (st != NULL)
+    name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
+  else
+    name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_fputc_sub (gfc_code * c)
+{
+  const char *name;
+  gfc_typespec ts;
+  gfc_expr *u, *st;
+
+  u = c->ext.actual->expr;
+  st = c->ext.actual->next->next->expr;
+
+  if (u->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.derived = NULL;
+      ts.cl = NULL;
+      gfc_convert_type (u, &ts, 2);
+    }
+
+  if (st != NULL)
+    name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
+  else
+    name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_fput_sub (gfc_code * c)
+{
+  const char *name;
+  gfc_expr *st;
+
+  st = c->ext.actual->next->expr;
+  if (st != NULL)
+    name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
+  else
+    name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
+
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_ftell_sub (gfc_code * c)
+{
+  const char *name;
+  gfc_expr *unit;
+  gfc_expr *offset;
+  gfc_typespec ts;
+
+  unit = c->ext.actual->expr;
+  offset = c->ext.actual->next->expr;
+
+  if (unit->ts.kind != gfc_c_int_kind)
+    {
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_c_int_kind;
+      ts.derived = NULL;
+      ts.cl = NULL;
+      gfc_convert_type (unit, &ts, 2);
+    }
+
+  name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
 gfc_resolve_ttynam_sub (gfc_code * c)
 {
   gfc_typespec ts;