[gfortran] Fix PR23661, allow PRINT with format variable again

[Tobias Schlueter]

On Thu, 1 Sep 2005 Tobias.Schlueter@Physik.Uni-Muenchen.DE wrote:

> Quoting Tobias.Schlueter@Physik.Uni-Muenchen.DE:
> > Bubblestrapped and tested, a number of testcases is also included.  OK for
> > mainline and 4.0?
> 
> This time it'll hopefully be attached for real ...

Looks like the web interface is broken, this time hopefully ...

- Tobi
-------------- next part --------------
2005-09-01  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
fortran/
	PR fortran/23661
	* io.c (match_io): Correctly backup if PRINT followed by
	symbol which is not a namelist.  Force blank between PRINT
	and namelist in free form.
testsuite/
	* gfortran.dg/print_fmt_1.f90, gfortran.dg/print_fmt_2.f90
	gfortran.dg/print_fmt_3.f90: New test.

Index: fortran/io.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/io.c,v
retrieving revision 1.30
diff -c -3 -p -r1.30 io.c
*** fortran/io.c	14 Aug 2005 16:15:39 -0000	1.30
--- fortran/io.c	1 Sep 2005 13:42:02 -0000
*************** match_io (io_kind k)
*** 2133,2165 ****
  
    if (gfc_match_char ('(') == MATCH_NO)
      {
!       /* Treat the non-standard case of PRINT namelist.  */
!       if (k == M_PRINT && (gfc_match_name (name) == MATCH_YES)
! 	    && !gfc_find_symbol (name, NULL, 1, &sym)
! 	    && (sym->attr.flavor == FL_NAMELIST))
  	{
! 	  if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
! 			      "%C is an extension") == FAILURE)
  	    {
!  	      m = MATCH_ERROR;
! 	      goto cleanup;
  	    }
! 	  if (gfc_match_eos () == MATCH_NO)
! 	    {
! 	      gfc_error ("Namelist followed by I/O list at %C");
! 	      m = MATCH_ERROR;
! 	      goto cleanup;
! 	    }
! 
! 	  dt->io_unit = default_unit (k);
! 	  dt->namelist = sym;
! 	  goto get_io_list;
  	}
  
- 
-       if (k == M_WRITE)
- 	goto syntax;
- 
        if (gfc_current_form == FORM_FREE)
         {
           c = gfc_peek_char();
--- 2133,2171 ----
  
    if (gfc_match_char ('(') == MATCH_NO)
      {
!       if (k == M_WRITE)
! 	goto syntax;
!       else if (k == M_PRINT 
! 	       && (gfc_current_form == FORM_FIXED
! 		   || gfc_peek_char () == ' '))
  	{
! 	  /* Treat the non-standard case of PRINT namelist.  */
! 	  where = gfc_current_locus;
! 	  if ((gfc_match_name (name) == MATCH_YES)
! 	      && !gfc_find_symbol (name, NULL, 1, &sym)
! 	      && sym->attr.flavor == FL_NAMELIST)
  	    {
! 	      if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
! 				  "%C is an extension") == FAILURE)
! 		{
! 		  m = MATCH_ERROR;
! 		  goto cleanup;
! 		}
! 	      if (gfc_match_eos () == MATCH_NO)
! 		{
! 		  gfc_error ("Namelist followed by I/O list at %C");
! 		  m = MATCH_ERROR;
! 		  goto cleanup;
! 		}
! 
! 	      dt->io_unit = default_unit (k);
! 	      dt->namelist = sym;
! 	      goto get_io_list;
  	    }
! 	  else
! 	    gfc_current_locus = where;
  	}
  
        if (gfc_current_form == FORM_FREE)
         {
           c = gfc_peek_char();
Index: testsuite/gfortran.dg/print_fmt_1.f90
===================================================================
RCS file: testsuite/gfortran.dg/print_fmt_1.f90
diff -N testsuite/gfortran.dg/print_fmt_1.f90
*** /dev/null	1 Jan 1970 00:00:00 -0000
--- testsuite/gfortran.dg/print_fmt_1.f90	1 Sep 2005 13:42:13 -0000
***************
*** 0 ****
--- 1,7 ----
+ ! { dg-do run }
+ ! PR 23661
+ ! PRINT with a character format was broken
+ character(5) :: f = "(a)"
+ ! { dg-output "check" }
+ print f, "check"
+ end
Index: testsuite/gfortran.dg/print_fmt_2.f90
===================================================================
RCS file: testsuite/gfortran.dg/print_fmt_2.f90
diff -N testsuite/gfortran.dg/print_fmt_2.f90
*** /dev/null	1 Jan 1970 00:00:00 -0000
--- testsuite/gfortran.dg/print_fmt_2.f90	1 Sep 2005 13:42:13 -0000
***************
*** 0 ****
--- 1,11 ----
+ ! { dg-do compile }
+ ! PR 23661 Make sure space between PRINT and variable name is enforced in
+ ! free form.
+ ! Also tests the namelist case
+ character(5) :: f = "(a)"
+ real  x
+ namelist /mynml/ x
+ printf, "check" ! { dg-error "" }
+ x = 1
+ printmynml ! { dg-error "" }
+ end
Index: testsuite/gfortran.dg/print_fmt_3.f
===================================================================
RCS file: testsuite/gfortran.dg/print_fmt_3.f
diff -N testsuite/gfortran.dg/print_fmt_3.f
*** /dev/null	1 Jan 1970 00:00:00 -0000
--- testsuite/gfortran.dg/print_fmt_3.f	1 Sep 2005 13:42:13 -0000
***************
*** 0 ****
--- 1,11 ----
+ ! { dg-do compile }
+ ! PR 23661 Make sure space between PRINT and variable name is not enforced in
+ ! fixed form.
+ ! Also tests the namelist case
+       character(5) :: f = "(a)"
+       real  x
+       namelist /mynml/ x
+       printf, "check"           ! { dg-error "" }
+       x = 1
+       printmynml                ! { dg-error "" }
+       end