check.c (gfc_check_getcwd_sub): New function.
2004-09-15 Steven G. Kargl <kargls@comcast.net> * check.c (gfc_check_getcwd_sub): New function. * gfortran.h (GFC_ISYM_GETCWD): New symbol. * intrinsic.c (add_functions): Add function definition; Use symbol. * intrinsic.c (add_subroutines): Add subroutine definitions. * intrinsic.h: Add prototypes. * iresolve.c (gfc_resolve_getcwd, gfc_resolve_getcwd_sub): New functions. * trans-intrinsic.c (gfc_conv_intrinsic_function): Use symbol. libgfortran/ * intrinsics/getcwd.c: New file. * Makefile.am: Add getcwd.c. * Makefile.in: Regenerated. From-SVN: r87552
This commit is contained in:
Steven G. Kargl
Paul Brook
parent
4672f86ad0
commit
a8c60d7fff
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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 *);
|
||||
|
|
|
|||
|
|
@ -571,6 +571,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)
|
||||
{
|
||||
|
|
@ -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. */
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
Loading…
Reference in New Issue