From aa6fc6350836d2dd03becd67b61dcd86eb8f9087 Mon Sep 17 00:00:00 2001 From: Janne Blomqvist Date: Sat, 7 Aug 2004 00:47:03 +0300 Subject: [PATCH] intrinsic.c (add_subroutines): Add getenv and get_environment_variable. 2004-08-06 Janne Blomqvist * 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 --- gcc/fortran/ChangeLog | 9 ++ gcc/fortran/intrinsic.c | 55 +++++++- gcc/fortran/intrinsic.h | 1 + gcc/fortran/iresolve.c | 13 ++ gcc/testsuite/ChangeLog | 4 + gcc/testsuite/gfortran.dg/getenv_1.f90 | 12 ++ libgfortran/ChangeLog | 6 + libgfortran/Makefile.am | 1 + libgfortran/Makefile.in | 12 +- libgfortran/intrinsics/env.c | 181 +++++++++++++++++++++++++ 10 files changed, 289 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/getenv_1.f90 create mode 100644 libgfortran/intrinsics/env.c diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7eb4fb566b3..b4338512ce7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2004-08-06 Janne Blomqvist + + * 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 * f95-lang.c (gfc_init_builtin_functions): Fix the number of diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 659b507f6c5..c80909f8f6c 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 2d759cf5a9d..3a50d05b8c5 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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. */ diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index f7e7f71427e..b42294d7d23 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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) */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 63ca7a78c50..8caed21c95a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2004-08-06 Janne Blomqvist + + * gfortran.dg/getenv_1.f90: New test. + 2004-08-06 Mark Mitchell * gcc.dg/symbian4.c: Expect a 2-byte wchar_t, not a 4-byte diff --git a/gcc/testsuite/gfortran.dg/getenv_1.f90 b/gcc/testsuite/gfortran.dg/getenv_1.f90 new file mode 100644 index 00000000000..8a96bd7f6eb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/getenv_1.f90 @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 4a06ac5e8fe..fc7f6654c2c 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,9 @@ +2004-08-06 Janne Blomqvist + + * intrinsics/env.c: New file. + * Makefile.am: Add env.c to build. + * Makefile.in: Regenerate. + 2004-08-05 Victor Leikehman PR libgfortran/16704 diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 450a9a4e868..35332dc4c07 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -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 \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 754c3ea4027..b0fa2ec7bba 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -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 diff --git a/libgfortran/intrinsics/env.c b/libgfortran/intrinsics/env.c new file mode 100644 index 00000000000..9898471844a --- /dev/null +++ b/libgfortran/intrinsics/env.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 +#include +#include +#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; +} -- 2.30.2