diff options
| -rw-r--r-- | gcc/fortran/check.c | 17 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.h | 3 | ||||
| -rw-r--r-- | gcc/fortran/iresolve.c | 26 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans-io.c | 90 | ||||
| -rw-r--r-- | libgfortran/Makefile.am | 1 | ||||
| -rw-r--r-- | libgfortran/Makefile.in | 14 | ||||
| -rw-r--r-- | libgfortran/intrinsics/getcwd.c | 71 |
10 files changed, 227 insertions, 7 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 6bc9e09..fc5390c 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 f33e79b..8ec9215 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 414cc1a..c20f8b2 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 b2ffb15..f1b11b0 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 713d81f..ed8bc56 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 18f9ecf..a5ce489 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 66d25b2..2d16ac5 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; diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 91d70b8..060166a 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -49,6 +49,7 @@ intrinsics/erf.c \ intrinsics/eoshift0.c \ intrinsics/eoshift2.c \ intrinsics/etime.c \ +intrinsics/getcwd.c \ intrinsics/getXid.c \ intrinsics/ishftc.c \ intrinsics/pack_generic.c \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index ded21b6..fb06ca5 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -120,8 +120,8 @@ am__objects_32 = backspace.lo close.lo endfile.lo format.lo inquire.lo \ unit.lo unix.lo write.lo am__objects_33 = associated.lo abort.lo args.lo bessel.lo \ c99_functions.lo cpu_time.lo cshift0.lo date_and_time.lo \ - env.lo erf.lo eoshift0.lo eoshift2.lo etime.lo getXid.lo \ - ishftc.lo pack_generic.lo size.lo spread_generic.lo \ + env.lo erf.lo eoshift0.lo eoshift2.lo etime.lo getcwd.lo \ + getXid.lo ishftc.lo pack_generic.lo size.lo spread_generic.lo \ string_intrinsics.lo rand.lo random.lo reshape_generic.lo \ reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \ system_clock.lo transpose_generic.lo unpack_generic.lo \ @@ -321,6 +321,7 @@ intrinsics/erf.c \ intrinsics/eoshift0.c \ intrinsics/eoshift2.c \ intrinsics/etime.c \ +intrinsics/getcwd.c \ intrinsics/getXid.c \ intrinsics/ishftc.c \ intrinsics/pack_generic.c \ @@ -2086,6 +2087,15 @@ etime.obj: intrinsics/etime.c etime.lo: intrinsics/etime.c $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o etime.lo `test -f 'intrinsics/etime.c' || echo '$(srcdir)/'`intrinsics/etime.c +getcwd.o: intrinsics/getcwd.c + $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o getcwd.o `test -f 'intrinsics/getcwd.c' || echo '$(srcdir)/'`intrinsics/getcwd.c + +getcwd.obj: intrinsics/getcwd.c + $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o getcwd.obj `if test -f 'intrinsics/getcwd.c'; then $(CYGPATH_W) 'intrinsics/getcwd.c'; else $(CYGPATH_W) '$(srcdir)/intrinsics/getcwd.c'; fi` + +getcwd.lo: intrinsics/getcwd.c + $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o getcwd.lo `test -f 'intrinsics/getcwd.c' || echo '$(srcdir)/'`intrinsics/getcwd.c + getXid.o: intrinsics/getXid.c $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o getXid.o `test -f 'intrinsics/getXid.c' || echo '$(srcdir)/'`intrinsics/getXid.c diff --git a/libgfortran/intrinsics/getcwd.c b/libgfortran/intrinsics/getcwd.c new file mode 100644 index 0000000..86afa6c --- /dev/null +++ b/libgfortran/intrinsics/getcwd.c @@ -0,0 +1,71 @@ +/* Implementation of the GETCWD intrinsic. + Copyright (C) 2004 Free Software Foundation, Inc. + Contributed by Steven G. Kargl <kargls@comcast.net>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with libgfor; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include "libgfortran.h" + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#ifdef HAVE_STRING_H +#include <string.h> +#endif + +#include <errno.h> + +void +prefix(getcwd_i4_sub) (char * cwd, GFC_INTEGER_4 * status, + gfc_charlen_type cwd_len) +{ + char str[cwd_len + 1], *s; + GFC_INTEGER_4 stat; + + memset(cwd, ' ', (size_t) cwd_len); + + if (!getcwd (str, (size_t) cwd_len + 1)) + stat = errno; + else + { + stat = 0; + memcpy (cwd, str, strlen (str)); + } + if (status != NULL) + *status = stat; +} + +void +prefix(getcwd_i8_sub) (char * cwd, GFC_INTEGER_8 * status, + gfc_charlen_type cwd_len) +{ + GFC_INTEGER_4 status4; + + prefix (getcwd_i4_sub) (cwd, &status4, cwd_len); + if (status) + *status = status4; +} + +GFC_INTEGER_4 +prefix(getcwd) (char * cwd, gfc_charlen_type cwd_len) +{ + GFC_INTEGER_4 status; + prefix(getcwd_i4_sub) (cwd, &status, cwd_len); + return status; +} |