intrinsic.c (add_subroutines): Add ITIME and IDATE.

	* intrinsic.c (add_subroutines): Add ITIME and IDATE.
	* intrinsic.h (gfc_check_itime_idate,gfc_resolve_idate,
	fc_resolve_itime): New protos.
	* iresolve.c (gfc_resolve_itime, gfc_resolve_idate): New functions.
	* check.c (gfc_check_itime_idate): New function.
	* intrinsic.texi: Document the new intrinsics.

	* intrinsics/date_and_time.c (itime0,idate0,itime_i4,itime_i8,
	idate_i4,idate_i8): New functions.

	* gfortran.dg/itime_idate_1.f: New test.
	* gfortran.dg/itime_idate_2.f: New test.

Co-Authored-By: Daniel Franke <franke.daniel@gmail.com>

From-SVN: r115173

gcc/fortran/ChangeLog

+2006-07-04  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+	    Daniel Franke  <franke.daniel@gmail.com>
+
+	* intrinsic.c (add_subroutines): Add ITIME and IDATE.
+	* intrinsic.h (gfc_check_itime_idate,gfc_resolve_idate,
+	fc_resolve_itime): New protos.
+	* iresolve.c (gfc_resolve_itime, gfc_resolve_idate): New functions.
+	* check.c (gfc_check_itime_idate): New function.
+	* intrinsic.texi: Document the new intrinsics.
+
+2006-07-03  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsics/date_and_time.c (itime0,idate0,itime_i4,itime_i8,
+	idate_i4,idate_i8): New functions.
+
+
 2006-07-03  Asher Langton  <langton2@llnl.gov>
 
 	* decl.c (match_old_style_init): Add data attribute to symbol.

gcc/fortran/check.c

@@ -3037,6 +3037,28 @@ gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
 
 
 try
+gfc_check_itime_idate (gfc_expr * values)
+{
+  if (array_check (values, 0) == FAILURE)
+    return FAILURE;
+
+  if (rank_check (values, 0, 1) == FAILURE)
+    return FAILURE;
+
+  if (variable_check (values, 0) == FAILURE)
+    return FAILURE;
+
+  if (type_check (values, 0, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  if (kind_value_check(values, 0, gfc_default_integer_kind) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+try
 gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
 {
   if (scalar_check (unit, 0) == FAILURE)

gcc/fortran/intrinsic.c

@@ -2241,8 +2241,16 @@ add_subroutines (void)
 
   /* More G77 compatibility garbage.  */
   add_sym_2s ("ctime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
-	     gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
-	     tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED);
+	      gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
+	      tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED);
+
+  add_sym_1s ("idate", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_itime_idate, NULL, gfc_resolve_idate,
+	      vl, BT_INTEGER, 4, REQUIRED);
+
+  add_sym_1s ("itime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
+	      gfc_check_itime_idate, NULL, gfc_resolve_itime,
+	      vl, BT_INTEGER, 4, REQUIRED);
 
   add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
 	      gfc_check_second_sub, NULL, gfc_resolve_second_sub,

gcc/fortran/intrinsic.h

@@ -159,6 +159,7 @@ try gfc_check_fgetput_sub (gfc_expr *, gfc_expr *);
 try gfc_check_ftell_sub (gfc_expr *, gfc_expr *);
 try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
 try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *);
+try gfc_check_itime_idate (gfc_expr *);
 try gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_perror (gfc_expr *);
 try gfc_check_rename_sub (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -445,6 +446,8 @@ void gfc_resolve_get_command (gfc_code *);
 void gfc_resolve_get_command_argument (gfc_code *);
 void gfc_resolve_get_environment_variable (gfc_code *);
 void gfc_resolve_hostnm_sub (gfc_code *);
+void gfc_resolve_idate (gfc_code *);
+void gfc_resolve_itime (gfc_code *);
 void gfc_resolve_kill_sub (gfc_code *);
 void gfc_resolve_mvbits (gfc_code *);
 void gfc_resolve_perror (gfc_code *);

gcc/fortran/intrinsic.texi

@@ -100,7 +100,9 @@ and editing.  All contributions and corrections are strongly encouraged.
 * @code{HUGE}:          HUGE,      Largest number of a kind
 * @code{IACHAR}:        IACHAR,    Code in @acronym{ASCII} collating sequence
 * @code{ICHAR}:         ICHAR,     Character-to-integer conversion function
+* @code{IDATE}:         IDATE,     Current local time (day/month/year)
 * @code{IRAND}:         IRAND,     Integer pseudo-random number
+* @code{ITIME}:         ITIME,     Current local time (hour/minutes/seconds)
 * @code{KIND}:          KIND,      Kind of an entity
 * @code{LOC}:           LOC,       Returns the address of a variable
 * @code{LOG}:           LOG,       Logarithm function
@@ -3294,6 +3296,46 @@ end program read_val
 @end smallexample
 @end table
 
+@node IDATE
+@section @code{IDATE} --- Get current local time subroutine (day/month/year) 
+@findex @code{IDATE} intrinsic
+
+@table @asis
+@item @emph{Description}:
+@code{IDATE(TARRAY)} Fills @var{TARRAY} with the numerical values at the  
+current local time. The day (in the range 1-31), month (in the range 1-12), 
+and year appear in elements 1, 2, and 3 of @var{TARRAY}, respectively. 
+The year has four significant digits.
+
+@item @emph{Option}:
+gnu
+
+@item @emph{Class}:
+subroutine
+
+@item @emph{Syntax}:
+@code{CALL IDATE(TARRAY)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .80
+@item @var{TARRAY} @tab The type shall be @code{INTEGER, DIMENSION(3)} and
+the kind shall be the default integer kind.
+@end multitable
+
+@item @emph{Return value}:
+Does not return.
+
+@item @emph{Example}:
+@smallexample
+program test_idate
+  integer, dimension(3) :: tarray
+  call idate(tarray)
+  print *, tarray(1)
+  print *, tarray(2)
+  print *, tarray(3)
+end program test_idate
+@end smallexample
+@end table
 
 
 @node IRAND
@@ -3340,6 +3382,47 @@ end program test_irand
 
 @end table
 
+@node ITIME
+@section @code{ITIME} --- Get current local time subroutine (hour/minutes/seconds) 
+@findex @code{ITIME} intrinsic
+
+@table @asis
+@item @emph{Description}:
+@code{IDATE(TARRAY)} Fills @var{TARRAY} with the numerical values at the  
+current local time. The hour (in the range 1-24), minute (in the range 1-60), 
+and seconds (in the range 1-60) appear in elements 1, 2, and 3 of @var{TARRAY}, 
+respectively.
+
+@item @emph{Option}:
+gnu
+
+@item @emph{Class}:
+subroutine
+
+@item @emph{Syntax}:
+@code{CALL ITIME(TARRAY)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .80
+@item @var{TARRAY} @tab The type shall be @code{INTEGER, DIMENSION(3)}
+and the kind shall be the default integer kind.
+@end multitable
+
+@item @emph{Return value}:
+Does not return.
+
+
+@item @emph{Example}:
+@smallexample
+program test_itime
+  integer, dimension(3) :: tarray
+  call itime(tarray)
+  print *, tarray(1)
+  print *, tarray(2)
+  print *, tarray(3)
+end program test_itime
+@end smallexample
+@end table
 
 
 @node KIND

gcc/fortran/iresolve.c

@@ -2334,6 +2334,26 @@ gfc_resolve_etime_sub (gfc_code * c)
 }
 
 
+/* G77 compatibility subroutines itime() and idate().  */
+
+void
+gfc_resolve_itime (gfc_code * c)
+{
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol
+		      (gfc_get_string (PREFIX("itime_i%d"),
+				       gfc_default_integer_kind));
+}
+
+
+void
+gfc_resolve_idate (gfc_code * c)
+{
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol
+		      (gfc_get_string (PREFIX("idate_i%d"),
+				       gfc_default_integer_kind));
+}
+
+
 /* G77 compatibility subroutine second().  */
 
 void

gcc/testsuite/ChangeLog

+2006-07-04  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* gfortran.dg/itime_idate_1.f: New test.
+	* gfortran.dg/itime_idate_2.f: New test.
+
 2006-07-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/27704

gcc/testsuite/gfortran.dg/itime_idate_1.f

+! { dg-do run }
+! Test for ITIME and IDATE intrinsics
+      integer x(3)
+      call itime(x)
+      if (x(1) < 0 .or. x(1) > 23 .or.
+     &    x(2) < 0 .or. x(2) > 59 .or.
+     &    x(3) < 0 .or. x(3) > 61) call abort
+      call idate(x)
+      if (x(1) < 1 .or. x(1) > 31 .or.
+     &    x(2) < 1 .or. x(2) > 12 .or.
+     &    x(3) < 2001 .or. x(3) > 2100) call abort
+      end

gcc/testsuite/gfortran.dg/itime_idate_2.f

+! { dg-do run }
+! { dg-options "-fdefault-integer-8" }
+! Test for ITIME and IDATE intrinsics
+      integer x(3)
+      call itime(x)
+      if (x(1) < 0 .or. x(1) > 23 .or.
+     &    x(2) < 0 .or. x(2) > 59 .or.
+     &    x(3) < 0 .or. x(3) > 61) call abort
+      call idate(x)
+      if (x(1) < 1 .or. x(1) > 31 .or.
+     &    x(2) < 1 .or. x(2) > 12 .or.
+     &    x(3) < 2001 .or. x(3) > 2100) call abort
+      end

libgfortran/ChangeLog

+2006-07-04  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	* intrinsics/date_and_time.c (itime0,idate0,itime_i4,itime_i8,
+	idate_i4,idate_i8): New functions.
+
 2006-07-03  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR libgfortran/27704

libgfortran/intrinsics/date_and_time.c

 /* Implementation of the DATE_AND_TIME intrinsic.
-   Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc.
+   Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
    Contributed by Steven Bosscher.
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -84,7 +84,7 @@ Boston, MA 02110-1301, USA.  */
    ZONE (optional) shall be scalar and of type default character, and
    shall be of length at least 5 in order to contain the complete
    value. It is an INTENT(OUT) argument. Its leftmost 5 characters
-   are assigned a value of the form ±hhmm, where hh and mm are the
+   are assigned a value of the form [+-]hhmm, where hh and mm are the
    time difference with respect to Coordinated Universal Time (UTC) in
    hours and parts of an hour expressed in minutes, respectively. If
    there is no clock available, they are assigned blanks.
@@ -359,3 +359,165 @@ secnds (GFC_REAL_4 *x)
   temp2 = (temp1 - temp2 > 0.0) ? temp2 : (temp2 - 86400.0);
   return temp1 - temp2;
 }
+
+
+
+/* ITIME(X) - Non-standard
+
+   Description: Returns the current local time hour, minutes, and seconds
+   in elements 1, 2, and 3 of X, respectively.  */
+
+static void
+itime0 (int x[3])
+{
+#ifndef HAVE_NO_DATE_TIME
+  time_t lt;
+  struct tm local_time;
+
+  lt = time (NULL);
+
+  if (lt != (time_t) -1)
+    {
+      local_time = *localtime (&lt);
+
+      x[0] = local_time.tm_hour;
+      x[1] = local_time.tm_min;
+      x[2] = local_time.tm_sec;
+    }
+#else
+  x[0] = x[1] = x[2] = -1;
+#endif
+}
+
+extern void itime_i4 (gfc_array_i4 *);
+export_proto(itime_i4);
+
+void
+itime_i4 (gfc_array_i4 *__values)
+{
+  int x[3], i;
+  size_t len, delta;
+  GFC_INTEGER_4 *vptr;
+  
+  /* Call helper function.  */
+  itime0(x);
+
+  /* Copy the value into the array.  */
+  len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
+  assert (len >= 3);
+  delta = __values->dim[0].stride;
+  if (delta == 0)
+    delta = 1;
+
+  vptr = __values->data;
+  for (i = 0; i < 3; i++, vptr += delta)
+    *vptr = x[i];
+}
+
+
+extern void itime_i8 (gfc_array_i8 *);
+export_proto(itime_i8);
+
+void
+itime_i8 (gfc_array_i8 *__values)
+{
+  int x[3], i;
+  size_t len, delta;
+  GFC_INTEGER_8 *vptr;
+  
+  /* Call helper function.  */
+  itime0(x);
+
+  /* Copy the value into the array.  */
+  len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
+  assert (len >= 3);
+  delta = __values->dim[0].stride;
+  if (delta == 0)
+    delta = 1;
+
+  vptr = __values->data;
+  for (i = 0; i < 3; i++, vptr += delta)
+    *vptr = x[i];
+}
+
+
+
+/* IDATE(X) - Non-standard
+
+   Description: Fills TArray with the numerical values at the current
+   local time. The day (in the range 1-31), month (in the range 1-12),
+   and year appear in elements 1, 2, and 3 of X, respectively.
+   The year has four significant digits.  */
+
+static void
+idate0 (int x[3])
+{
+#ifndef HAVE_NO_DATE_TIME
+  time_t lt;
+  struct tm local_time;
+
+  lt = time (NULL);
+
+  if (lt != (time_t) -1)
+    {
+      local_time = *localtime (&lt);
+
+      x[0] = local_time.tm_mday;
+      x[1] = 1 + local_time.tm_mon;
+      x[2] = 1900 + local_time.tm_year;
+    }
+#else
+  x[0] = x[1] = x[2] = -1;
+#endif
+}
+
+extern void idate_i4 (gfc_array_i4 *);
+export_proto(idate_i4);
+
+void
+idate_i4 (gfc_array_i4 *__values)
+{
+  int x[3], i;
+  size_t len, delta;
+  GFC_INTEGER_4 *vptr;
+  
+  /* Call helper function.  */
+  idate0(x);
+
+  /* Copy the value into the array.  */
+  len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
+  assert (len >= 3);
+  delta = __values->dim[0].stride;
+  if (delta == 0)
+    delta = 1;
+
+  vptr = __values->data;
+  for (i = 0; i < 3; i++, vptr += delta)
+    *vptr = x[i];
+}
+
+
+extern void idate_i8 (gfc_array_i8 *);
+export_proto(idate_i8);
+
+void
+idate_i8 (gfc_array_i8 *__values)
+{
+  int x[3], i;
+  size_t len, delta;
+  GFC_INTEGER_8 *vptr;
+  
+  /* Call helper function.  */
+  idate0(x);
+
+  /* Copy the value into the array.  */
+  len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
+  assert (len >= 3);
+  delta = __values->dim[0].stride;
+  if (delta == 0)
+    delta = 1;
+
+  vptr = __values->data;
+  for (i = 0; i < 3; i++, vptr += delta)
+    *vptr = x[i];
+}