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

gcc/fortran/ChangeLog

+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

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,

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.  */

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) */
 

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/getenv_1.f90

+! { 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

libgfortran/ChangeLog

+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

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 \

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
 

libgfortran/intrinsics/env.c

+/* 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;
+}