intrinsic.c (add_subroutines): Add getenv and get_environment_variable.
2004-08-06 Janne Blomqvist <jblomqvi@cc.hut.fi> * intrinsic.c (add_subroutines): Add getenv and get_environment_variable. (add_sym_5s): New function. * intrinsic.h (gfc_resolve_get_environment_variable): Add prototype. * iresolve.c (gfc_resolve_get_environment_variable): New function. libgfortran/ * intrinsics/env.c: New file. * Makefile.am: Add env.c to build. * Makefile.in: Regenerate. testsuite/ * gfortran.dg/getenv_1.f90: New test. From-SVN: r85656
This commit is contained in:
Janne Blomqvist
Paul Brook
parent
c7d78bbe0e
commit
aa6fc63508
|
|
@ -1,3 +1,12 @@
|
|||
2004-08-06 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
|
||||
* intrinsic.c (add_subroutines): Add getenv and
|
||||
get_environment_variable. (add_sym_5s): New function.
|
||||
* intrinsic.h (gfc_resolve_get_environment_variable): Add
|
||||
prototype.
|
||||
* iresolve.c (gfc_resolve_get_environment_variable): New
|
||||
function.
|
||||
|
||||
2004-08-06 Feng Wang <fengwang@nudt.edu.cn>
|
||||
|
||||
* f95-lang.c (gfc_init_builtin_functions): Fix the number of
|
||||
|
|
|
|||
|
|
@ -617,6 +617,36 @@ static void add_sym_5 (const char *name, int elemental, int actual_ok, bt type,
|
|||
}
|
||||
|
||||
|
||||
static void add_sym_5s
|
||||
(
|
||||
const char *name, int elemental, int actual_ok, bt type, int kind,
|
||||
try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
|
||||
gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
|
||||
void (*resolve)(gfc_code *),
|
||||
const char* a1, bt type1, int kind1, int optional1,
|
||||
const char* a2, bt type2, int kind2, int optional2,
|
||||
const char* a3, bt type3, int kind3, int optional3,
|
||||
const char* a4, bt type4, int kind4, int optional4,
|
||||
const char* a5, bt type5, int kind5, int optional5)
|
||||
{
|
||||
gfc_check_f cf;
|
||||
gfc_simplify_f sf;
|
||||
gfc_resolve_f rf;
|
||||
|
||||
cf.f5 = check;
|
||||
sf.f5 = simplify;
|
||||
rf.s1 = resolve;
|
||||
|
||||
add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
|
||||
a1, type1, kind1, optional1,
|
||||
a2, type2, kind2, optional2,
|
||||
a3, type3, kind3, optional3,
|
||||
a4, type4, kind4, optional4,
|
||||
a5, type5, kind5, optional5,
|
||||
(void*)0);
|
||||
}
|
||||
|
||||
|
||||
/* Locate an intrinsic symbol given a base pointer, number of elements
|
||||
in the table and a pointer to a name. Returns the NULL pointer if
|
||||
a name is not found. */
|
||||
|
|
@ -1742,13 +1772,15 @@ add_subroutines (void)
|
|||
*t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
|
||||
*f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
|
||||
*com = "command", *length = "length", *st = "status",
|
||||
*val = "value", *num = "number";
|
||||
*val = "value", *num = "number", *name = "name",
|
||||
*trim_name = "trim_name";
|
||||
|
||||
int di, dr, dc;
|
||||
int di, dr, dc, dl;
|
||||
|
||||
di = gfc_default_integer_kind ();
|
||||
dr = gfc_default_real_kind ();
|
||||
dc = gfc_default_character_kind ();
|
||||
dl = gfc_default_logical_kind ();
|
||||
|
||||
add_sym_0s ("abort", 1, NULL);
|
||||
|
||||
|
|
@ -1775,6 +1807,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 ("getenv", 0, 1, BT_UNKNOWN, 0,
|
||||
NULL, NULL, NULL,
|
||||
name, BT_CHARACTER, dc, 0,
|
||||
val, BT_CHARACTER, dc, 0);
|
||||
|
||||
add_sym_2s ("getarg", 0, 1, BT_UNKNOWN, 0,
|
||||
NULL, NULL, gfc_resolve_getarg,
|
||||
c, BT_INTEGER, di, 0, vl, BT_CHARACTER, dc, 0);
|
||||
|
|
@ -1793,8 +1830,18 @@ add_subroutines (void)
|
|||
val, BT_CHARACTER, dc, 1,
|
||||
length, BT_INTEGER, di, 1,
|
||||
st, BT_INTEGER, di, 1);
|
||||
|
||||
/* Extension */
|
||||
|
||||
|
||||
/* F2003 subroutine to get environment variables. */
|
||||
|
||||
add_sym_5s ("get_environment_variable", 0, 1, BT_UNKNOWN, 0,
|
||||
NULL, NULL, gfc_resolve_get_environment_variable,
|
||||
name, BT_CHARACTER, dc, 0,
|
||||
val, BT_CHARACTER, dc, 1,
|
||||
length, BT_INTEGER, di, 1,
|
||||
st, BT_INTEGER, di, 1,
|
||||
trim_name, BT_LOGICAL, dl, 1);
|
||||
|
||||
|
||||
/* This needs changing to add_sym_5s if it gets a resolution function. */
|
||||
add_sym_5 ("mvbits", 1, 1, BT_UNKNOWN, 0,
|
||||
|
|
|
|||
|
|
@ -318,6 +318,7 @@ void gfc_resolve_random_number (gfc_code *);
|
|||
void gfc_resolve_getarg (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 *);
|
||||
|
||||
|
||||
/* The mvbits() subroutine requires the most arguments: five. */
|
||||
|
|
|
|||
|
|
@ -1449,6 +1449,19 @@ gfc_resolve_get_command_argument (gfc_code * c)
|
|||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
/* Resolve the get_environment_variable intrinsic subroutine. */
|
||||
|
||||
void
|
||||
gfc_resolve_get_environment_variable (gfc_code * code)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
kind = gfc_default_integer_kind();
|
||||
name = gfc_get_string (PREFIX("get_environment_variable_i%d"), kind);
|
||||
code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
2004-08-06 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
|
||||
* gfortran.dg/getenv_1.f90: New test.
|
||||
|
||||
2004-08-06 Mark Mitchell <mark@codesourcery.com>
|
||||
|
||||
* gcc.dg/symbian4.c: Expect a 2-byte wchar_t, not a 4-byte
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
! { dg do-run }
|
||||
! Test the getenv and get_environment_variable intrinsics.
|
||||
! Ignore the return value because it's not supported/meaningful on all targets
|
||||
program getenv_1
|
||||
implicit none
|
||||
character(len=101) :: var
|
||||
character(len=*), parameter :: home = 'HOME'
|
||||
integer :: len, stat
|
||||
call getenv(name=home, value=var)
|
||||
call get_environment_variable(name=home, value=var, &
|
||||
length=len, status=stat)
|
||||
end program getenv_1
|
||||
|
|
@ -1,3 +1,9 @@
|
|||
2004-08-06 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
|
||||
* intrinsics/env.c: New file.
|
||||
* Makefile.am: Add env.c to build.
|
||||
* Makefile.in: Regenerate.
|
||||
|
||||
2004-08-05 Victor Leikehman <lei@il.ibm.com>
|
||||
|
||||
PR libgfortran/16704
|
||||
|
|
|
|||
|
|
@ -43,6 +43,7 @@ intrinsics/c99_functions.c \
|
|||
intrinsics/cpu_time.c \
|
||||
intrinsics/cshift0.c \
|
||||
intrinsics/date_and_time.c \
|
||||
intrinsics/env.c \
|
||||
intrinsics/eoshift0.c \
|
||||
intrinsics/eoshift2.c \
|
||||
intrinsics/etime.c \
|
||||
|
|
|
|||
|
|
@ -119,7 +119,7 @@ am__objects_32 = backspace.lo close.lo endfile.lo format.lo inquire.lo \
|
|||
list_read.lo lock.lo open.lo read.lo rewind.lo transfer.lo \
|
||||
unit.lo unix.lo write.lo
|
||||
am__objects_33 = associated.lo abort.lo args.lo c99_functions.lo \
|
||||
cpu_time.lo cshift0.lo date_and_time.lo eoshift0.lo \
|
||||
cpu_time.lo cshift0.lo date_and_time.lo env.lo eoshift0.lo \
|
||||
eoshift2.lo etime.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_kind.lo \
|
||||
|
|
@ -314,6 +314,7 @@ intrinsics/c99_functions.c \
|
|||
intrinsics/cpu_time.c \
|
||||
intrinsics/cshift0.c \
|
||||
intrinsics/date_and_time.c \
|
||||
intrinsics/env.c \
|
||||
intrinsics/eoshift0.c \
|
||||
intrinsics/eoshift2.c \
|
||||
intrinsics/etime.c \
|
||||
|
|
@ -2025,6 +2026,15 @@ date_and_time.obj: intrinsics/date_and_time.c
|
|||
date_and_time.lo: intrinsics/date_and_time.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o date_and_time.lo `test -f 'intrinsics/date_and_time.c' || echo '$(srcdir)/'`intrinsics/date_and_time.c
|
||||
|
||||
env.o: intrinsics/env.c
|
||||
$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o env.o `test -f 'intrinsics/env.c' || echo '$(srcdir)/'`intrinsics/env.c
|
||||
|
||||
env.obj: intrinsics/env.c
|
||||
$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o env.obj `if test -f 'intrinsics/env.c'; then $(CYGPATH_W) 'intrinsics/env.c'; else $(CYGPATH_W) '$(srcdir)/intrinsics/env.c'; fi`
|
||||
|
||||
env.lo: intrinsics/env.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o env.lo `test -f 'intrinsics/env.c' || echo '$(srcdir)/'`intrinsics/env.c
|
||||
|
||||
eoshift0.o: intrinsics/eoshift0.c
|
||||
$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o eoshift0.o `test -f 'intrinsics/eoshift0.c' || echo '$(srcdir)/'`intrinsics/eoshift0.c
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,181 @@
|
|||
/* Implementation of the GETENV g77, and
|
||||
GET_ENVIRONMENT_VARIABLE F2003, intrinsics.
|
||||
Copyright (C) 2004 Free Software Foundation, Inc.
|
||||
Contributed by Janne Blomqvist.
|
||||
|
||||
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 <sys/types.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include "libgfortran.h"
|
||||
|
||||
|
||||
/* GETENV (NAME, VALUE), g77 intrinsic for retrieving the value of
|
||||
an environment variable. The name of the variable is specified in
|
||||
NAME, and the result is stored into VALUE. */
|
||||
|
||||
void
|
||||
prefix(getenv) (char * name,
|
||||
char * value,
|
||||
gfc_strlen_type name_len,
|
||||
gfc_strlen_type value_len)
|
||||
{
|
||||
|
||||
/* Make a null-terminated copy of the name string so that c library
|
||||
functions work correctly. This is a C99 VLA, which ought to be
|
||||
faster than malloc and free. */
|
||||
|
||||
char name_nt[name_len+1];
|
||||
|
||||
char *res = NULL;
|
||||
int res_len;
|
||||
|
||||
if (name == NULL || value == NULL)
|
||||
runtime_error ("Both arguments to getenv are mandatory.");
|
||||
|
||||
if (value_len < 1 || name_len < 1)
|
||||
runtime_error ("Zero length string(s) passed to getenv.");
|
||||
else
|
||||
memset (value, ' ', value_len); /* Blank the string. */
|
||||
|
||||
memcpy (name_nt, name, name_len);
|
||||
memset (&name_nt[name_len], '\0', 1);
|
||||
|
||||
res = getenv(name_nt);
|
||||
|
||||
/* If res is NULL, it means that the environment variable didn't
|
||||
exist, so just return. */
|
||||
if (res == NULL)
|
||||
return;
|
||||
|
||||
res_len = strlen(res);
|
||||
if (value_len < res_len)
|
||||
memcpy (value, res, value_len);
|
||||
else
|
||||
memcpy (value, res, res_len);
|
||||
}
|
||||
|
||||
|
||||
/* GET_ENVIRONMENT_VARIABLE (name, [value, length, status, trim_name])
|
||||
is a F2003 intrinsic for getting an environment variable. Note that as
|
||||
Un*x doesn't consider trailing blanks in environment variables to be
|
||||
significant, the trim_name argument has no meaning. */
|
||||
|
||||
/* Status codes specifyed by the standard. */
|
||||
#define GFC_SUCCESS 0
|
||||
#define GFC_VALUE_TOO_SHORT -1
|
||||
#define GFC_NAME_DOES_NOT_EXIST 1
|
||||
|
||||
/* This is also specified by the standard and means that the
|
||||
processor doesn't support environment variables. At the moment,
|
||||
gfortran doesn't use it. */
|
||||
#define GFC_NOT_SUPPORTED 2
|
||||
|
||||
/* Processor-specific failure code. */
|
||||
#define GFC_FAILURE 42
|
||||
|
||||
void
|
||||
prefix(get_environment_variable_i4)
|
||||
(
|
||||
char *name,
|
||||
char *value,
|
||||
GFC_INTEGER_4 *length,
|
||||
GFC_INTEGER_4 *status,
|
||||
GFC_LOGICAL_4 *trim_name,
|
||||
gfc_strlen_type name_len,
|
||||
gfc_strlen_type value_len)
|
||||
{
|
||||
int stat = GFC_SUCCESS, res_len = 0;
|
||||
char name_nt[name_len+1], *res;
|
||||
|
||||
if (name == NULL)
|
||||
runtime_error ("Name is required for get_environment_variable.");
|
||||
|
||||
if (value == NULL && length == NULL && status == NULL && trim_name == NULL)
|
||||
return;
|
||||
|
||||
if (name_len < 1)
|
||||
runtime_error ("Zero-length string passed as name to "
|
||||
"get_environment_variable.");
|
||||
|
||||
if (value != NULL)
|
||||
{
|
||||
if (value_len < 1)
|
||||
runtime_error ("Zero-length string passed as value to "
|
||||
"get_environment_variable.");
|
||||
else
|
||||
memset (value, ' ', value_len); /* Blank the string. */
|
||||
}
|
||||
|
||||
memcpy (name_nt, name, name_len);
|
||||
memset (&name_nt[name_len], '\0', 1);
|
||||
|
||||
res = getenv(name_nt);
|
||||
|
||||
if (res == NULL)
|
||||
stat = GFC_NAME_DOES_NOT_EXIST;
|
||||
else
|
||||
{
|
||||
res_len = strlen(res);
|
||||
if (value != NULL)
|
||||
{
|
||||
if (value_len < res_len)
|
||||
{
|
||||
memcpy (value, res, value_len);
|
||||
stat = GFC_VALUE_TOO_SHORT;
|
||||
}
|
||||
else
|
||||
memcpy (value, res, res_len);
|
||||
}
|
||||
}
|
||||
|
||||
if (status != NULL)
|
||||
*status = stat;
|
||||
|
||||
if (length != NULL)
|
||||
*length = res_len;
|
||||
}
|
||||
|
||||
|
||||
/* INTEGER*8 wrapper for get_environment_variable. */
|
||||
|
||||
void
|
||||
prefix(get_environment_variable_i8)
|
||||
(
|
||||
char *name,
|
||||
char *value,
|
||||
GFC_INTEGER_8 *length,
|
||||
GFC_INTEGER_8 *status,
|
||||
GFC_LOGICAL_8 *trim_name,
|
||||
gfc_strlen_type name_len,
|
||||
gfc_strlen_type value_len)
|
||||
{
|
||||
GFC_INTEGER_4 length4, status4;
|
||||
GFC_LOGICAL_4 trim_name4;
|
||||
|
||||
prefix (get_environment_variable_i4) (name, value, &length4, &status4,
|
||||
&trim_name4, name_len, value_len);
|
||||
|
||||
if (length)
|
||||
*length = length4;
|
||||
|
||||
if (status)
|
||||
*status = status4;
|
||||
}
|
||||
Loading…
Reference in New Issue