procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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
This commit is contained in:
Francois-Xavier Coudert 2006-07-04 13:39:46 +02:00 • committed by François-Xavier Coudert
parent 0b50988af5
commit 12197210b4
11 changed files with 353 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
gcc/fortran/ChangeLog
View file

@ -1,3 +1,19 @@
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.

22
gcc/fortran/check.c
View file

@ -3036,6 +3036,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)
{

12
gcc/fortran/intrinsic.c
View file

@ -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,

3
gcc/fortran/intrinsic.h
View file

@ -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 *);

83
gcc/fortran/intrinsic.texi
View file

@ -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

20
gcc/fortran/iresolve.c
View file

@ -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

5
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,8 @@
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

12
gcc/testsuite/gfortran.dg/itime_idate_1.f Normal file
View file

@ -0,0 +1,12 @@
! { 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

13
gcc/testsuite/gfortran.dg/itime_idate_2.f Normal file
View file

@ -0,0 +1,13 @@
! { 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

5
libgfortran/ChangeLog
View file

@ -1,3 +1,8 @@
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

166
libgfortran/intrinsics/date_and_time.c
View file

@ -1,5 +1,5 @@
/* 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];
}