summaryrefslogtreecommitdiffstats
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/check.c17
-rw-r--r--gcc/fortran/gfortran.h1
-rw-r--r--gcc/fortran/intrinsic.c10
-rw-r--r--gcc/fortran/intrinsic.h3
-rw-r--r--gcc/fortran/iresolve.c26
-rw-r--r--gcc/fortran/trans-intrinsic.c1
-rw-r--r--gcc/fortran/trans-io.c90
7 files changed, 143 insertions, 5 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 6bc9e09f203..fc5390c6679 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2093,3 +2093,20 @@ gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
return SUCCESS;
}
+
+
+try
+gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
+{
+
+ if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (status, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (status, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f33e79bac1b..8ec92157755 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -315,6 +315,7 @@ enum gfc_generic_isym_id
GFC_ISYM_EXPONENT,
GFC_ISYM_FLOOR,
GFC_ISYM_FRACTION,
+ GFC_ISYM_GETCWD,
GFC_ISYM_GETGID,
GFC_ISYM_GETPID,
GFC_ISYM_GETUID,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 414cc1a5913..c20f8b2f08c 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1241,6 +1241,10 @@ add_functions (void)
make_generic ("fraction", GFC_ISYM_FRACTION);
/* Unix IDs (g77 compatibility) */
+ add_sym_1 ("getcwd", 0, 1, BT_INTEGER, di, NULL, NULL, gfc_resolve_getcwd,
+ c, BT_CHARACTER, dc, 0);
+ make_generic ("getcwd", GFC_ISYM_GETCWD);
+
add_sym_0 ("getgid", 1, 0, BT_INTEGER, di, NULL, NULL, gfc_resolve_getgid);
make_generic ("getgid", GFC_ISYM_GETGID);
@@ -1914,6 +1918,11 @@ add_subroutines (void)
gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
vl, BT_REAL, 4, 0, tm, BT_REAL, 4, 0);
+ add_sym_2s ("getcwd", 0, 1, BT_UNKNOWN, 0,
+ gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
+ c, BT_CHARACTER, dc, 0,
+ st, BT_INTEGER, di, 1);
+
add_sym_2s ("getenv", 0, 1, BT_UNKNOWN, 0,
NULL, NULL, NULL,
name, BT_CHARACTER, dc, 0,
@@ -1923,6 +1932,7 @@ add_subroutines (void)
NULL, NULL, gfc_resolve_getarg,
c, BT_INTEGER, di, 0, vl, BT_CHARACTER, dc, 0);
+
/* F2003 commandline routines. */
add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index b2ffb155a85..f1b11b04264 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -48,6 +48,7 @@ try gfc_check_dot_product (gfc_expr *, gfc_expr *);
try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_etime (gfc_expr *);
try gfc_check_etime_sub (gfc_expr *, gfc_expr *);
+try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
try gfc_check_g77_math1 (gfc_expr *);
try gfc_check_huge (gfc_expr *);
try gfc_check_i (gfc_expr *);
@@ -256,6 +257,7 @@ void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fraction (gfc_expr *, gfc_expr *);
void gfc_resolve_g77_math1 (gfc_expr *, gfc_expr *);
+void gfc_resolve_getcwd (gfc_expr *);
void gfc_resolve_getgid (gfc_expr *);
void gfc_resolve_getpid (gfc_expr *);
void gfc_resolve_getuid (gfc_expr *);
@@ -324,6 +326,7 @@ void gfc_resolve_cpu_time (gfc_code *);
void gfc_resolve_system_clock(gfc_code *);
void gfc_resolve_random_number (gfc_code *);
void gfc_resolve_getarg (gfc_code *);
+void gfc_resolve_getcwd_sub (gfc_code *);
void gfc_resolve_get_command (gfc_code *);
void gfc_resolve_get_command_argument (gfc_code *);
void gfc_resolve_get_environment_variable (gfc_code *);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 713d81f20ff..ed8bc569bcf 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -572,6 +572,15 @@ gfc_resolve_g77_math1 (gfc_expr * f, gfc_expr * x)
void
+gfc_resolve_getcwd (gfc_expr * f)
+{
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = 4;
+ f->value.function.name = gfc_get_string (PREFIX("getcwd"));
+}
+
+
+void
gfc_resolve_getgid (gfc_expr * f)
{
f->ts.type = BT_INTEGER;
@@ -1499,6 +1508,23 @@ gfc_resolve_getarg (gfc_code * c)
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+/* Resolve the getcwd intrinsic subroutine. */
+
+void
+gfc_resolve_getcwd_sub (gfc_code * c)
+{
+ const char *name;
+ int kind;
+
+ if (c->ext.actual->next->expr != NULL)
+ kind = c->ext.actual->next->expr->ts.kind;
+ else
+ kind = gfc_default_integer_kind;
+
+ name = gfc_get_string (PREFIX("getcwd_i%d_sub"), kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
/* Resolve the get_command intrinsic subroutine. */
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 18f9ecfc619..a5ce489b847 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2952,6 +2952,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
case GFC_ISYM_RAND:
case GFC_ISYM_ETIME:
case GFC_ISYM_SECOND:
+ case GFC_ISYM_GETCWD:
case GFC_ISYM_GETGID:
case GFC_ISYM_GETPID:
case GFC_ISYM_GETUID:
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 66d25b22db3..2d16ac5d350 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1140,6 +1140,79 @@ gfc_trans_dt_end (gfc_code * code)
return gfc_finish_block (&block);
}
+static void
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
+
+static tree
+transfer_array_component (tree expr, gfc_component * cm)
+{
+ tree tmp;
+ stmtblock_t body;
+ stmtblock_t block;
+ gfc_loopinfo loop;
+ int n,i;
+ gfc_ss *ss;
+ gfc_se se;
+ gfc_array_ref ar;
+
+ gfc_start_block (&block);
+ gfc_init_se (&se, NULL);
+
+ ss = gfc_get_ss ();
+ ss->type = GFC_SS_COMPONENT;
+ ss->expr = NULL;
+ ss->shape = gfc_get_shape (cm->as->rank);
+ ss->next = gfc_ss_terminator;
+ ss->data.info.dimen = cm->as->rank;
+ ss->data.info.descriptor = expr;
+ ss->data.info.data = gfc_conv_array_data (expr);
+ ss->data.info.offset = gfc_conv_array_offset (expr);
+ for (n = 0; n < cm->as->rank; n++)
+ {
+ ss->data.info.dim[n] = n;
+ ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
+ ss->data.info.stride[n] = gfc_index_one_node;
+
+ mpz_init (ss->shape[n]);
+ mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
+ cm->as->lower[n]->value.integer);
+ mpz_add_ui (ss->shape[n], ss->shape[n], 1);
+ }
+
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop);
+ gfc_mark_ss_chain_used (ss, 1);
+ gfc_start_scalarized_body (&loop, &body);
+
+ gfc_copy_loopinfo_to_se (&se, &loop);
+ se.ss = ss;
+ se.expr = expr;
+
+ ar.type = AR_FULL;
+ ar.as = cm->as;
+ ar.dimen = cm->as->rank;
+ for (i = 0; i < cm->as->rank; i++)
+ {
+ ar.dimen_type[i] = DIMEN_RANGE;
+ ar.start[i] = ar.end[i] = ar.stride[i] = NULL;
+ }
+ gfc_conv_array_ref (&se, &ar);
+ tmp = gfc_build_addr_expr (NULL, se.expr);
+ transfer_expr (&se, &cm->ts, tmp);
+
+ gfc_add_block_to_block (&body, &se.pre);
+ gfc_add_block_to_block (&body, &se.post);
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (&loop.pre, &loop.post);
+ tmp = gfc_finish_block (&loop.pre);
+ gfc_cleanup_loop (&loop);
+ for (n = 0; n < cm->as->rank; n++)
+ mpz_clear (ss->shape[n]);
+ gfc_free (ss->shape);
+ return tmp;
+}
/* Generate the call for a scalar transfer node. */
@@ -1199,11 +1272,18 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
se->string_length =
TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
}
- if (c->dimension)
- gfc_todo_error ("IO of arrays in derived types");
- if (!c->pointer)
- tmp = gfc_build_addr_expr (NULL, tmp);
- transfer_expr (se, &c->ts, tmp);
+
+ if (c->dimension)
+ {
+ tmp = transfer_array_component (tmp, c);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ else
+ {
+ if (!c->pointer)
+ tmp = gfc_build_addr_expr (NULL, tmp);
+ transfer_expr (se, &c->ts, tmp);
+ }
}
return;
OpenPOWER on IntegriCloud