This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, fortran] PR28585: Add Fortran 2003 NEW_LINE intrinsic function
- From: Tobias Burnus <burnus at net-b dot de>
- To: "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 07 Oct 2006 23:39:13 +0200
- Subject: Re: [Patch, fortran] PR28585: Add Fortran 2003 NEW_LINE intrinsic function
- References: <4504A704.70502@net-b.de> <450F010F.6080701@net-b.de> <451AFCC8.4060602@net-b.de> <BA54FB26-AEA1-4D02-9594-5012D47F7CB2@gmail.com>
Hi FX, hi all,
FX Coudert wrote:
> Sorry for this late review. Here are comments on your patch
Here is an updated version of the patch.
Tobias
2006-08-26 Tobias Burnus <burnus@net-b.de>
PR fortran/28585
* intrinsic.c(add_functions): Add new_line Fortran 2003 intrinsic
intrinsic.h: Add gfc_simplify_new_line and gfc_check_new_line prototypes
check.c: Add gfc_check_new_line
simplify.c: Add gfc_simplify_new_line
* intrinsic.text: Document new_line intrinsic
* gfortran.dg/new_line.f90: new testcase
Index: gcc/fortran/intrinsic.c
===================================================================
*** gcc/fortran/intrinsic.c (Revision 117540)
--- gcc/fortran/intrinsic.c (Arbeitskopie)
*************** add_functions (void)
*** 1910,1915 ****
--- 1910,1919 ----
make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
+ add_sym_1 ("new_line", 0, 0, BT_CHARACTER, dc, GFC_STD_F2003,
+ gfc_check_new_line, gfc_simplify_new_line, NULL,
+ i, BT_CHARACTER, dc, REQUIRED);
+
add_sym_2 ("nint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
Index: gcc/fortran/intrinsic.h
===================================================================
*** gcc/fortran/intrinsic.h (Revision 117540)
--- gcc/fortran/intrinsic.h (Arbeitskopie)
*************** try gfc_check_merge (gfc_expr *, gfc_exp
*** 98,103 ****
--- 98,104 ----
try gfc_check_minloc_maxloc (gfc_actual_arglist *);
try gfc_check_minval_maxval (gfc_actual_arglist *);
try gfc_check_nearest (gfc_expr *, gfc_expr *);
+ try gfc_check_new_line (gfc_expr *);
try gfc_check_null (gfc_expr *);
try gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_precision (gfc_expr *);
*************** gfc_expr *gfc_simplify_modulo (gfc_expr
*** 255,260 ****
--- 256,262 ----
gfc_expr *gfc_simplify_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
gfc_expr *gfc_simplify_nearest (gfc_expr *, gfc_expr *);
+ gfc_expr *gfc_simplify_new_line (gfc_expr *);
gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_null (gfc_expr *);
gfc_expr *gfc_simplify_idnint (gfc_expr *);
Index: gcc/fortran/iresolve.c
===================================================================
*** gcc/fortran/iresolve.c (Revision 117540)
--- gcc/fortran/iresolve.c (Arbeitskopie)
*************** gfc_resolve_nearest (gfc_expr * f, gfc_e
*** 1511,1516 ****
--- 1511,1535 ----
a->ts.kind);
}
+ gfc_expr *
+ gfc_simplify_new_line (gfc_expr * e)
+ {
+ gfc_expr *result;
+ int index;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
+
+ result->value.character.string = gfc_getmem (2);
+
+ result->value.character.length = 1;
+ result->value.character.string[0] = '\n';
+ result->value.character.string[1] = '\0'; /* For debugger */
+ return result;
+ }
+
void
gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
{
Index: gcc/fortran/check.c
===================================================================
*** gcc/fortran/check.c (Revision 117540)
--- gcc/fortran/check.c (Arbeitskopie)
*************** gfc_check_nearest (gfc_expr * x, gfc_exp
*** 1827,1832 ****
--- 1827,1840 ----
return SUCCESS;
}
+ try
+ gfc_check_new_line (gfc_expr * a)
+ {
+ if (type_check (a, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+ }
try
gfc_check_null (gfc_expr * mold)
Index: gcc/fortran/intrinsic.texi
===================================================================
*** gcc/fortran/intrinsic.texi (Revision 117540)
--- gcc/fortran/intrinsic.texi (Arbeitskopie)
*************** Some intrinsics have documentation yet t
*** 183,188 ****
--- 183,189 ----
* @code{MODULO}: MODULO, Modulo function
* @code{MVBITS}: MVBITS, Move bits from one integer to another
* @code{NEAREST}: NEAREST, Nearest representable number
+ * @code{NEW_LINE}: NEW_LINE, New line character
* @code{NINT}: NINT, Nearest whole number
* @code{NOT}: NOT, Logical negation
* @code{NULL}: NULL, Function that returns an disassociated pointer
*************** end program test_nearest
*** 5879,5884 ****
--- 5880,5924 ----
+ @node NEW_LINE
+ @section @code{NEW_LINE} --- New line character
+ @findex @code{NEW_LINE} intrinsic
+ @findex @code{NEW_LINE} intrinsic
+
+ @table @asis
+ @item @emph{Description}:
+ @code{NEW_LINE(C)} returns the new-line character
+
+ @item @emph{Standard}:
+ F2003 and later
+
+ @item @emph{Class}:
+ Elemental function
+
+ @item @emph{Syntax}:
+ @code{C = NEW_LINE(C)}
+
+ @item @emph{Arguments}:
+ @multitable @columnfractions .15 .80
+ @item @var{C} @tab The argument shall be a scalar or array of the
+ type @code{CHARACTER}.
+ @end multitable
+
+ @item @emph{Return value}:
+ Returns a @var{CHARACTER} scalar of length one with the new-line character of
+ the same kind as parameter @var{C}.
+
+ @item @emph{Example}:
+ @smallexample
+ program newline
+ implicit none
+ write(*,'(A)') 'This is record 1.'//NEW_LINE('A')//'This is record 2.'
+ end program newline
+ @end smallexample
+ @end table
+
+
+
@node NINT
@section @code{NINT} --- Nearest whole number
@findex @code{NINT} intrinsic
--- /dev/null 2006-09-26 21:08:37.000000000 +0200
+++ gcc/testsuite/gfortran.dg/new_line.f90 2006-10-07 23:28:23.232865500 +0200
@@ -0,0 +1,30 @@
+! { dg-do run }
+! Checks Fortran 2003's new_line intrinsic function
+! PR fortran/28585
+program new_line_check
+ implicit none
+ character(len=*), parameter :: rec1 = 'record1'
+ character(len=*), parameter :: rec2 = 'record2'
+ character(len=50) :: r1,r2
+ integer :: len
+
+ open(10,file="test.dat",form='formatted',access='stream',&
+ status='new',position='rewind')
+ write(10,'(a)') rec1//new_line('a')//rec2
+ close(10)
+
+ open(10,file="test.dat",form='formatted',access='sequential',&
+ status='old',position='rewind')
+ read(10,'(a)') r1
+ read(10,'(a)') r2
+ close(10,status='delete')
+ if(r1 /= rec1 .or. r2 /= rec2) call abort()
+
+ open(unit=10,form='unformatted',access='stream', &
+ status='scratch',position='rewind')
+ write(10) rec1//new_line('a')//rec2
+ len = len_trim(rec1//new_line('a')//rec2)
+ rewind(10)
+ read(10) r1(1:len)
+ if(r1 /= rec1//new_line('a')//rec2) call abort()
+end program new_line_check