2010-04-06 Tobias Burnus <burnus@net-b.de>

author burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>

Tue, 6 Apr 2010 16:26:02 +0000 (16:26 +0000)

committer Masaki Muranaka <monaka@monami-software.com>

Sun, 23 May 2010 00:46:06 +0000 (09:46 +0900)
author burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 6 Apr 2010 16:26:02 +0000 (16:26 +0000)
committer Masaki Muranaka <monaka@monami-software.com>
Sun, 23 May 2010 00:46:06 +0000 (09:46 +0900)
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog

index 97a2fca..8af3668 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,47 @@
  2010-04-06  Tobias Burnus  <burnus@net-b.de>
  
  2010-04-06  Tobias Burnus  <burnus@net-b.de>
  
+       PR fortran/39997
+       * intrinsic.c (add_functions): Add num_images.
+       * decl.c (gfc_match_end): Handle END CRITICAL.
+       * intrinsic.h (gfc_simplify_num_images): Add prototype.
+       * dump-parse-tree.c (show_code_node): Dump CRITICAL, ERROR STOP,
+       and SYNC.
+       * gfortran.h (gfc_statement): Add enum items for those.
+       (gfc_exec_op) Ditto.
+       (gfc_isym_id): Add num_images.
+       * trans-stmt.c (gfc_trans_stop): Handle ERROR STOP.
+       (gfc_trans_sync,gfc_trans_critical): New functions.
+       * trans-stmt.h (gfc_trans_stop,gfc_trans_sync,
+       gfc_trans_critical): Add/update prototypes.
+       * trans.c (gfc_trans_code): Handle CRITICAL, ERROR STOP,
+       and SYNC statements.
+       * trans.h (gfor_fndecl_error_stop_string) Add variable.
+       * resolve.c (resolve_sync): Add function.
+       (gfc_resolve_blocks): Handle CRITICAL.
+       (resolve_code): Handle CRITICAL, ERROR STOP,
+       (resolve_branch): Add CRITICAL constraint check.
+       and SYNC statements.
+       * st.c (gfc_free_statement): Add new statements.
+       * trans-decl.c (gfor_fndecl_error_stop_string): Global variable.
+       (gfc_build_builtin_function_decls): Initialize it.
+       * match.c (gfc_match_if): Handle ERROR STOP and SYNC.
+       (gfc_match_critical, gfc_match_error_stop, sync_statement,
+       gfc_match_sync_all, gfc_match_sync_images, gfc_match_sync_memory):
+       New functions.
+       (match_exit_cycle): Handle CRITICAL constraint.
+       (gfc_match_stopcode): Handle ERROR STOP.
+       * match.h (gfc_match_critical, gfc_match_error_stop,
+       gfc_match_sync_all, gfc_match_sync_images,
+       gfc_match_sync_memory): Add prototype.
+       * parse.c (decode_statement, gfc_ascii_statement,
+       parse_executable): Handle new statements.
+       (parse_critical_block): New function.
+       * parse.h (gfc_compile_state): Add COMP_CRITICAL.
+       * intrinsic.texi (num_images): Document new function.
+       * simplify.c (gfc_simplify_num_images): Add function.
+
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
         PR fortran/43178
         * trans-array.c (gfc_conv_expr_descriptor): Update
         gfc_trans_scalar_assign call.
         PR fortran/43178
         * trans-array.c (gfc_conv_expr_descriptor): Update
         gfc_trans_scalar_assign call.
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi

index bc0ea8d..52992ba 100644 (file)
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -92,6 +92,7 @@ Some basic guidelines for editing this document:
  * @code{DATE_AND_TIME}: DATE_AND_TIME, Date and time subroutine
  * @code{DBLE}:          DBLE,      Double precision conversion function
  * @code{DCMPLX}:        DCMPLX,    Double complex conversion function
  * @code{DATE_AND_TIME}: DATE_AND_TIME, Date and time subroutine
  * @code{DBLE}:          DBLE,      Double precision conversion function
  * @code{DCMPLX}:        DCMPLX,    Double complex conversion function
+* @code{DFLOAT}:        DFLOAT,    Double precision conversion function
  * @code{DIGITS}:        DIGITS,    Significant digits function
  * @code{DIM}:           DIM,       Positive difference
  * @code{DOT_PRODUCT}:   DOT_PRODUCT, Dot product function
  * @code{DIGITS}:        DIGITS,    Significant digits function
  * @code{DIM}:           DIM,       Positive difference
  * @code{DOT_PRODUCT}:   DOT_PRODUCT, Dot product function
@@ -110,6 +111,7 @@ Some basic guidelines for editing this document:
  * @code{FDATE}:         FDATE,     Subroutine (or function) to get the current time as a string
  * @code{FGET}:          FGET,      Read a single character in stream mode from stdin
  * @code{FGETC}:         FGETC,     Read a single character in stream mode
  * @code{FDATE}:         FDATE,     Subroutine (or function) to get the current time as a string
  * @code{FGET}:          FGET,      Read a single character in stream mode from stdin
  * @code{FGETC}:         FGETC,     Read a single character in stream mode
+* @code{FLOAT}:         FLOAT,     Convert integer to default real
  * @code{FLOOR}:         FLOOR,     Integer floor function
  * @code{FLUSH}:         FLUSH,     Flush I/O unit(s)
  * @code{FNUM}:          FNUM,      File number function
  * @code{FLOOR}:         FLOOR,     Integer floor function
  * @code{FLUSH}:         FLUSH,     Flush I/O unit(s)
  * @code{FNUM}:          FNUM,      File number function
@@ -152,7 +154,6 @@ Some basic guidelines for editing this document:
  * @code{INT8}:          INT8,      Convert to 64-bit integer type
  * @code{IOR}:           IOR,       Bitwise logical or
  * @code{IRAND}:         IRAND,     Integer pseudo-random number
  * @code{INT8}:          INT8,      Convert to 64-bit integer type
  * @code{IOR}:           IOR,       Bitwise logical or
  * @code{IRAND}:         IRAND,     Integer pseudo-random number
-* @code{IMAGE_INDEX}:   IMAGE_INDEX, Cosubscript to image index convertion
  * @code{IS_IOSTAT_END}:  IS_IOSTAT_END, Test for end-of-file value
  * @code{IS_IOSTAT_EOR}:  IS_IOSTAT_EOR, Test for end-of-record value
  * @code{ISATTY}:        ISATTY,    Whether a unit is a terminal device
  * @code{IS_IOSTAT_END}:  IS_IOSTAT_END, Test for end-of-file value
  * @code{IS_IOSTAT_EOR}:  IS_IOSTAT_EOR, Test for end-of-record value
  * @code{ISATTY}:        ISATTY,    Whether a unit is a terminal device
@@ -163,7 +164,6 @@ Some basic guidelines for editing this document:
  * @code{KILL}:          KILL,      Send a signal to a process
  * @code{KIND}:          KIND,      Kind of an entity
  * @code{LBOUND}:        LBOUND,    Lower dimension bounds of an array
  * @code{KILL}:          KILL,      Send a signal to a process
  * @code{KIND}:          KIND,      Kind of an entity
  * @code{LBOUND}:        LBOUND,    Lower dimension bounds of an array
-* @code{LCOBOUND}:      LCOBOUND,  Lower codimension bounds of an array
  * @code{LEADZ}:         LEADZ,     Number of leading zero bits of an integer
  * @code{LEN}:           LEN,       Length of a character entity
  * @code{LEN_TRIM}:      LEN_TRIM,  Length of a character entity without trailing blank characters
  * @code{LEADZ}:         LEADZ,     Number of leading zero bits of an integer
  * @code{LEN}:           LEN,       Length of a character entity
  * @code{LEN_TRIM}:      LEN_TRIM,  Length of a character entity without trailing blank characters
@@ -239,6 +239,7 @@ Some basic guidelines for editing this document:
  * @code{SIZE}:          SIZE,      Function to determine the size of an array
  * @code{SIZEOF}:        SIZEOF,    Determine the size in bytes of an expression
  * @code{SLEEP}:         SLEEP,     Sleep for the specified number of seconds
  * @code{SIZE}:          SIZE,      Function to determine the size of an array
  * @code{SIZEOF}:        SIZEOF,    Determine the size in bytes of an expression
  * @code{SLEEP}:         SLEEP,     Sleep for the specified number of seconds
+* @code{SNGL}:          SNGL,      Convert double precision real to default real
  * @code{SPACING}:       SPACING,   Smallest distance between two numbers of a given type
  * @code{SPREAD}:        SPREAD,    Add a dimension to an array 
  * @code{SQRT}:          SQRT,      Square-root function
  * @code{SPACING}:       SPACING,   Smallest distance between two numbers of a given type
  * @code{SPREAD}:        SPREAD,    Add a dimension to an array 
  * @code{SQRT}:          SQRT,      Square-root function
@@ -250,7 +251,6 @@ Some basic guidelines for editing this document:
  * @code{SYSTEM_CLOCK}:  SYSTEM_CLOCK, Time function
  * @code{TAN}:           TAN,       Tangent function
  * @code{TANH}:          TANH,      Hyperbolic tangent function
  * @code{SYSTEM_CLOCK}:  SYSTEM_CLOCK, Time function
  * @code{TAN}:           TAN,       Tangent function
  * @code{TANH}:          TANH,      Hyperbolic tangent function
-* @code{THIS_IMAGE}:    THIS_IMAGE, Cosubscript index of this image
  * @code{TIME}:          TIME,      Time function
  * @code{TIME8}:         TIME8,     Time function (64-bit)
  * @code{TINY}:          TINY,      Smallest positive number of a real kind
  * @code{TIME}:          TIME,      Time function
  * @code{TIME8}:         TIME8,     Time function (64-bit)
  * @code{TINY}:          TINY,      Smallest positive number of a real kind
@@ -260,7 +260,6 @@ Some basic guidelines for editing this document:
  * @code{TRIM}:          TRIM,      Remove trailing blank characters of a string
  * @code{TTYNAM}:        TTYNAM,    Get the name of a terminal device.
  * @code{UBOUND}:        UBOUND,    Upper dimension bounds of an array
  * @code{TRIM}:          TRIM,      Remove trailing blank characters of a string
  * @code{TTYNAM}:        TTYNAM,    Get the name of a terminal device.
  * @code{UBOUND}:        UBOUND,    Upper dimension bounds of an array
-* @code{UCOBOUND}:      UCOBOUND,  Upper codimension bounds of an array
  * @code{UMASK}:         UMASK,     Set the file creation mask
  * @code{UNLINK}:        UNLINK,    Remove a file from the file system
  * @code{UNPACK}:        UNPACK,    Unpack an array of rank one into an array
  * @code{UMASK}:         UMASK,     Set the file creation mask
  * @code{UNLINK}:        UNLINK,    Remove a file from the file system
  * @code{UNPACK}:        UNPACK,    Unpack an array of rank one into an array
@@ -401,12 +400,11 @@ end program test_abs
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument            @tab Return type       @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument            @tab Return type       @tab Standard
-@item @code{ABS(A)}   @tab @code{REAL(4) A}    @tab @code{REAL(4)}    @tab Fortran 77 and later
-@item @code{CABS(A)}  @tab @code{COMPLEX(4) A} @tab @code{REAL(4)}    @tab Fortran 77 and later
-@item @code{DABS(A)}  @tab @code{REAL(8) A}    @tab @code{REAL(8)}    @tab Fortran 77 and later
-@item @code{IABS(A)}  @tab @code{INTEGER(4) A} @tab @code{INTEGER(4)} @tab Fortran 77 and later
-@item @code{ZABS(A)}  @tab @code{COMPLEX(8) A} @tab @code{COMPLEX(8)} @tab GNU extension
-@item @code{CDABS(A)} @tab @code{COMPLEX(8) A} @tab @code{COMPLEX(8)} @tab GNU extension
+@item @code{CABS(A)}  @tab @code{COMPLEX(4) Z} @tab @code{REAL(4)}    @tab Fortran 77 and later
+@item @code{DABS(A)}  @tab @code{REAL(8)    X} @tab @code{REAL(8)}    @tab Fortran 77 and later
+@item @code{IABS(A)}  @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)} @tab Fortran 77 and later
+@item @code{ZABS(A)}  @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension
+@item @code{CDABS(A)} @tab @code{COMPLEX(8) Z} @tab @code{COMPLEX(8)} @tab GNU extension
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -563,9 +561,8 @@ end program test_acos
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name            @tab Argument         @tab Return type     @tab Standard
-@item @code{ACOS(X)}  @tab @code{REAL(4) X} @tab @code{REAL(4)}  @tab Fortran 77 and later
-@item @code{DACOS(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)}  @tab Fortran 77 and later
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{DACOS(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
  @end multitable
  
  @item @emph{See also}:
  @end multitable
  
  @item @emph{See also}:
@@ -764,11 +761,10 @@ end program test_aimag
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name               @tab Argument            @tab Return type     @tab Standard
-@item @code{AIMAG(Z)}    @tab @code{COMPLEX Z}    @tab @code{REAL}     @tab GNU extension
-@item @code{DIMAG(Z)}    @tab @code{COMPLEX(8) Z} @tab @code{REAL(8)}  @tab GNU extension
-@item @code{IMAG(Z)}     @tab @code{COMPLEX Z}    @tab @code{REAL}     @tab GNU extension
-@item @code{IMAGPART(Z)} @tab @code{COMPLEX Z}    @tab @code{REAL}     @tab GNU extension
+@item Name            @tab Argument            @tab Return type       @tab Standard
+@item @code{DIMAG(Z)} @tab @code{COMPLEX(8) Z} @tab @code{REAL(8)}    @tab GNU extension
+@item @code{IMAG(Z)}  @tab @code{COMPLEX Z} @tab @code{REAL}    @tab GNU extension
+@item @code{IMAGPART(Z)} @tab @code{COMPLEX Z} @tab @code{REAL} @tab GNU extension
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -825,8 +821,7 @@ end program test_aint
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name           @tab Argument         @tab Return type      @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name           @tab Argument         @tab Return type      @tab Standard
-@item @code{AINT(A)} @tab @code{REAL(4) A} @tab @code{REAL(4)}   @tab Fortran 77 and later
-@item @code{DINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)}   @tab Fortran 77 and later
+@item @code{DINT(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)}   @tab Fortran 77 and later
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -957,29 +952,26 @@ end program test_all
  
  @table @asis
  @item @emph{Description}:
  
  @table @asis
  @item @emph{Description}:
-@code{ALLOCATED(ARRAY)} and @code{ALLOCATED(SCALAR)} check the allocation
-status of @var{ARRAY} and @var{SCALAR}, respectively.
+@code{ALLOCATED(ARRAY)} checks the status of whether @var{X} is allocated.
  
  @item @emph{Standard}:
  
  @item @emph{Standard}:
-Fortran 95 and later.  Note, the @code{SCALAR=} keyword and allocatable
-scalar entities are available in Fortran 2003 and later.
+Fortran 95 and later
  
  @item @emph{Class}:
  Inquiry function
  
  @item @emph{Syntax}:
  
  @item @emph{Class}:
  Inquiry function
  
  @item @emph{Syntax}:
-@code{RESULT = ALLOCATED(ARRAY)} or @code{RESULT = ALLOCATED(SCALAR)} 
+@code{RESULT = ALLOCATED(ARRAY)}
  
  @item @emph{Arguments}:
  @multitable @columnfractions .15 .70
  @item @var{ARRAY}    @tab The argument shall be an @code{ALLOCATABLE} array.
  
  @item @emph{Arguments}:
  @multitable @columnfractions .15 .70
  @item @var{ARRAY}    @tab The argument shall be an @code{ALLOCATABLE} array.
-@item @var{SCALAR}   @tab The argument shall be an @code{ALLOCATABLE} scalar.
  @end multitable
  
  @item @emph{Return value}:
  The return value is a scalar @code{LOGICAL} with the default logical
  @end multitable
  
  @item @emph{Return value}:
  The return value is a scalar @code{LOGICAL} with the default logical
-kind type parameter.  If the argument is allocated, then the result is
-@code{.TRUE.}; otherwise, it returns @code{.FALSE.} 
+kind type parameter.  If @var{ARRAY} is allocated, @code{ALLOCATED(ARRAY)}
+is @code{.TRUE.}; otherwise, it returns @code{.FALSE.} 
  
  @item @emph{Example}:
  @smallexample
  
  @item @emph{Example}:
  @smallexample
@@ -1096,7 +1088,6 @@ end program test_anint
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument         @tab Return type      @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument         @tab Return type      @tab Standard
-@item @code{AINT(A)}  @tab @code{REAL(4) A} @tab @code{REAL(4)}   @tab Fortran 77 and later
  @item @code{DNINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)}   @tab Fortran 77 and later
  @end multitable
  @end table
  @item @code{DNINT(A)} @tab @code{REAL(8) A} @tab @code{REAL(8)}   @tab Fortran 77 and later
  @end multitable
  @end table
@@ -1212,7 +1203,6 @@ end program test_asin
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
-@item @code{ASIN(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 77 and later
  @item @code{DASIN(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
  @end multitable
  
  @item @code{DASIN(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
  @end multitable
  
@@ -1399,7 +1389,6 @@ end program test_atan
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
-@item @code{ATAN(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 77 and later
  @item @code{DATAN(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
  @end multitable
  
  @item @code{DATAN(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
  @end multitable
  
@@ -1459,9 +1448,8 @@ end program test_atan2
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name                @tab Argument            @tab Return type    @tab Standard
-@item @code{ATAN2(X, Y)}  @tab @code{REAL(4) X, Y} @tab @code{REAL(4)} @tab Fortran 77 and later
-@item @code{DATAN2(X, Y)} @tab @code{REAL(8) X, Y} @tab @code{REAL(8)} @tab Fortran 77 and later
+@item Name            @tab Argument          @tab Return type    @tab Standard
+@item @code{DATAN2(X, Y)} @tab @code{REAL(8) X}, @code{REAL(8) Y} @tab @code{REAL(8)} @tab Fortran 77 and later
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -1611,8 +1599,8 @@ end program test_besj1
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name             @tab Argument          @tab Return type       @tab Standard
-@item @code{DBESJ1(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{DBESJ1(X)}@tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab GNU extension
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -1812,7 +1800,7 @@ end program test_besyn
  @multitable @columnfractions .20 .20 .20 .25
  @item Name               @tab Argument            @tab Return type     @tab Standard
  @item @code{DBESYN(N,X)} @tab @code{INTEGER N} @tab @code{REAL(8)}  @tab GNU extension
  @multitable @columnfractions .20 .20 .20 .25
  @item Name               @tab Argument            @tab Return type     @tab Standard
  @item @code{DBESYN(N,X)} @tab @code{INTEGER N} @tab @code{REAL(8)}  @tab GNU extension
-@item                    @tab @code{REAL(8) X} @tab                 @tab 
+@item                    @tab @code{REAL(8)    X} @tab                 @tab 
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -2300,12 +2288,6 @@ program test_char
  end program test_char
  @end smallexample
  
  end program test_char
  @end smallexample
  
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name           @tab Argument         @tab Return type             @tab Standard
-@item @code{CHAR(I)} @tab @code{INTEGER I} @tab @code{CHARACTER(LEN=1)} @tab F77 and later
-@end multitable
-
  @item @emph{Note}:
  See @ref{ICHAR} for a discussion of converting between numerical values
  and formatted string representations.
  @item @emph{Note}:
  See @ref{ICHAR} for a discussion of converting between numerical values
  and formatted string representations.
@@ -2629,9 +2611,8 @@ end program test_conjg
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name             @tab Argument             @tab Return type       @tab Standard
-@item @code{CONJG(Z)}  @tab @code{COMPLEX Z}     @tab @code{COMPLEX}    @tab GNU extension
-@item @code{DCONJG(Z)} @tab @code{COMPLEX(8) Z}  @tab @code{COMPLEX(8)} @tab GNU extension
+@item Name             @tab Argument             @tab Return type          @tab Standard
+@item @code{DCONJG(Z)} @tab @code{COMPLEX(8) Z}  @tab @code{COMPLEX(8)}    @tab GNU extension
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -2682,7 +2663,6 @@ end program test_cos
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument            @tab Return type       @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument            @tab Return type       @tab Standard
-@item @code{COS(X)}  n@tab @code{REAL(4) X}    @tab @code{REAL(4)}    @tab Fortran 77 and later
  @item @code{DCOS(X)}  @tab @code{REAL(8) X}    @tab @code{REAL(8)}    @tab Fortran 77 and later
  @item @code{CCOS(X)}  @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later
  @item @code{ZCOS(X)}  @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension
  @item @code{DCOS(X)}  @tab @code{REAL(8) X}    @tab @code{REAL(8)}    @tab Fortran 77 and later
  @item @code{CCOS(X)}  @tab @code{COMPLEX(4) X} @tab @code{COMPLEX(4)} @tab Fortran 77 and later
  @item @code{ZCOS(X)}  @tab @code{COMPLEX(8) X} @tab @code{COMPLEX(8)} @tab GNU extension
@@ -2739,7 +2719,6 @@ end program test_cosh
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
-@item @code{COSH(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 77 and later
  @item @code{DCOSH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
  @end multitable
  
  @item @code{DCOSH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 77 and later
  @end multitable
  
@@ -3099,7 +3078,7 @@ end program test_dble
  @end smallexample
  
  @item @emph{See also}:
  @end smallexample
  
  @item @emph{See also}:
-@ref{REAL}
+@ref{DFLOAT}, @ref{FLOAT}, @ref{REAL}
  @end table
  
  
  @end table
  
  
@@ -3153,6 +3132,47 @@ end program test_dcmplx
  @end table
  
  
  @end table
  
  
+
+@node DFLOAT
+@section @code{DFLOAT} --- Double conversion function 
+@fnindex DFLOAT
+@cindex conversion, to real
+
+@table @asis
+@item @emph{Description}:
+@code{DFLOAT(A)} Converts @var{A} to double precision real type.
+
+@item @emph{Standard}:
+GNU extension
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = DFLOAT(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type double precision real.
+
+@item @emph{Example}:
+@smallexample
+program test_dfloat
+    integer :: i = 5
+    print *, dfloat(i)
+end program test_dfloat
+@end smallexample
+
+@item @emph{See also}:
+@ref{DBLE}, @ref{FLOAT}, @ref{REAL}
+@end table
+
+
+
  @node DIGITS
  @section @code{DIGITS} --- Significant binary digits function
  @fnindex DIGITS
  @node DIGITS
  @section @code{DIGITS} --- Significant binary digits function
  @fnindex DIGITS
@@ -3240,10 +3260,9 @@ end program test_dim
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name             @tab Argument               @tab Return type       @tab Standard
-@item @code{DIM(X,Y)}  @tab @code{REAL(4) X, Y}    @tab @code{REAL(4)}    @tab Fortran 77 and later
-@item @code{IDIM(X,Y)} @tab @code{INTEGER(4) X, Y} @tab @code{INTEGER(4)} @tab Fortran 77 and later
-@item @code{DDIM(X,Y)} @tab @code{REAL(8) X, Y}    @tab @code{REAL(8)}    @tab Fortran 77 and later
+@item Name             @tab Argument              @tab Return type       @tab Standard
+@item @code{IDIM(X,Y)} @tab @code{INTEGER(4) X,Y} @tab @code{INTEGER(4)} @tab Fortran 77 and later
+@item @code{DDIM(X,Y)} @tab @code{REAL(8) X,Y}    @tab @code{REAL(8)}    @tab Fortran 77 and later
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -3340,16 +3359,10 @@ program test_dprod
      print *, d
  end program test_dprod
  @end smallexample
      print *, d
  end program test_dprod
  @end smallexample
-
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name              @tab Argument               @tab Return type       @tab Standard
-@item @code{DPROD(X,Y)} @tab @code{REAL(4) X, Y}    @tab @code{REAL(4)}    @tab Fortran 77 and later
-@end multitable
-
  @end table
  
  
  @end table
  
  
+
  @node DREAL
  @section @code{DREAL} --- Double real part function
  @fnindex DREAL
  @node DREAL
  @section @code{DREAL} --- Double real part function
  @fnindex DREAL
@@ -3875,7 +3888,6 @@ end program test_exp
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument             @tab Return type         @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument             @tab Return type         @tab Standard
-@item @code{EXP(X)}   @tab @code{REAL(4) X}     @tab @code{REAL(4)}      @tab Fortran 77 and later
  @item @code{DEXP(X)}  @tab @code{REAL(8) X}     @tab @code{REAL(8)}      @tab Fortran 77 and later
  @item @code{CEXP(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)}   @tab Fortran 77 and later
  @item @code{ZEXP(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}   @tab GNU extension
  @item @code{DEXP(X)}  @tab @code{REAL(8) X}     @tab @code{REAL(8)}      @tab Fortran 77 and later
  @item @code{CEXP(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)}   @tab Fortran 77 and later
  @item @code{ZEXP(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}   @tab GNU extension
@@ -3986,6 +3998,46 @@ end program test_fdate
  
  
  
  
  
  
+@node FLOAT
+@section @code{FLOAT} --- Convert integer to default real
+@fnindex FLOAT
+@cindex conversion, to real
+
+@table @asis
+@item @emph{Description}:
+@code{FLOAT(A)} converts the integer @var{A} to a default real value.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = FLOAT(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab The type shall be @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type default @code{REAL}.
+
+@item @emph{Example}:
+@smallexample
+program test_float
+    integer :: i = 1
+    if (float(i) /= 1.) call abort
+end program test_float
+@end smallexample
+
+@item @emph{See also}:
+@ref{DBLE}, @ref{DFLOAT}, @ref{REAL}
+@end table
+
+
+
  @node FGET
  @section @code{FGET} --- Read a single character in stream mode from stdin 
  @fnindex FGET
  @node FGET
  @section @code{FGET} --- Read a single character in stream mode from stdin 
  @fnindex FGET
@@ -5645,12 +5697,6 @@ program test_ichar
  end program test_ichar
  @end smallexample
  
  end program test_ichar
  @end smallexample
  
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name             @tab Argument             @tab Return type       @tab Standard
-@item @code{ICHAR(C)}  @tab @code{CHARACTER C}   @tab @code{INTEGER(4)}    @tab Fortran 77 and later
-@end multitable
-
  @item @emph{Note}:
  No intrinsic exists to convert between a numeric value and a formatted
  character string representation -- for instance, given the
  @item @emph{Note}:
  No intrinsic exists to convert between a numeric value and a formatted
  character string representation -- for instance, given the
@@ -5836,12 +5882,6 @@ expression indicating the kind parameter of the result.
  The return value is of type @code{INTEGER} and of kind @var{KIND}. If
  @var{KIND} is absent, the return value is of default integer kind.
  
  The return value is of type @code{INTEGER} and of kind @var{KIND}. If
  @var{KIND} is absent, the return value is of default integer kind.
  
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name                            @tab Argument           @tab Return type       @tab Standard
-@item @code{INDEX(STRING, SUBSTRING)} @tab @code{CHARACTER}   @tab @code{INTEGER(4)} @tab Fortran 77 and later
-@end multitable
-
  @item @emph{See also}:
  @ref{SCAN}, @ref{VERIFY}
  @end table
  @item @emph{See also}:
  @ref{SCAN}, @ref{VERIFY}
  @end table
@@ -5903,15 +5943,15 @@ end program
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name            @tab Argument          @tab Return type       @tab Standard
-@item @code{INT(A)}   @tab @code{REAL(4) A}  @tab @code{INTEGER}    @tab Fortran 77 and later
-@item @code{IFIX(A)}  @tab @code{REAL(4) A}  @tab @code{INTEGER}    @tab Fortran 77 and later
-@item @code{IDINT(A)} @tab @code{REAL(8) A}  @tab @code{INTEGER}    @tab Fortran 77 and later
+@item Name             @tab Argument            @tab Return type       @tab Standard
+@item @code{IFIX(A)}   @tab @code{REAL(4) A}    @tab @code{INTEGER}    @tab Fortran 77 and later
+@item @code{IDINT(A)}  @tab @code{REAL(8) A}    @tab @code{INTEGER}    @tab Fortran 77 and later
  @end multitable
  
  @end table
  
  
  @end multitable
  
  @end table
  
  
+
  @node INT2
  @section @code{INT2} --- Convert to 16-bit integer type
  @fnindex INT2
  @node INT2
  @section @code{INT2} --- Convert to 16-bit integer type
  @fnindex INT2
@@ -6075,50 +6115,6 @@ end program test_irand
  
  
  
  
  
  
-@node IMAGE_INDEX
-@section @code{IMAGE_INDEX} --- Function that converts a cosubscript to an image index
-@fnindex IMAGE_INDEX
-@cindex coarray, IMAGE_INDEX
-@cindex images, cosubscript to image index conversion
-
-@table @asis
-@item @emph{Description}:
-Returns the image index belonging to a cosubscript.
-
-@item @emph{Standard}:
-Fortran 2008 and later
-
-@item @emph{Class}:
-Inquiry function.
-
-@item @emph{Syntax}:
-@code{RESULT = IMAGE_INDEX(COARRAY, SUB)}
-
-@item @emph{Arguments}: None.
-@multitable @columnfractions .15 .70
-@item @var{COARRAY} @tab Coarray of any type.
-@item @var{SUB}     @tab default integer rank-1 array of a size equal to
-the corank of @var{COARRAY}.
-@end multitable
-
-
-@item @emph{Return value}:
-Scalar default integer with the value of the image index which corresponds
-to the cosubscripts. For invalid cosubscripts the result is zero.
-
-@item @emph{Example}:
-@smallexample
-INTEGER :: array[2,-1:4,8,*]
-! Writes  28 (or 0 if there are fewer than 28 images)
-WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
-@end smallexample
-
-@item @emph{See also}:
-@ref{THIS_IMAGE}, @ref{NUM_IMAGES}
-@end table
-
-
-
  @node IS_IOSTAT_END
  @section @code{IS_IOSTAT_END} --- Test for end-of-file value
  @fnindex IS_IOSTAT_END
  @node IS_IOSTAT_END
  @section @code{IS_IOSTAT_END} --- Test for end-of-file value
  @fnindex IS_IOSTAT_END
@@ -6539,46 +6535,7 @@ structure component, or if it has a zero extent along the relevant
  dimension, the lower bound is taken to be 1.
  
  @item @emph{See also}:
  dimension, the lower bound is taken to be 1.
  
  @item @emph{See also}:
-@ref{UBOUND}, @ref{LCOBOUND}
-@end table
-
-
-
-@node LCOBOUND
-@section @code{LCOBOUND} --- Lower codimension bounds of an array
-@fnindex LCOBOUND
-@cindex coarray, lower bound
-
-@table @asis
-@item @emph{Description}:
-Returns the lower bounds of a coarray, or a single lower cobound
-along the @var{DIM} codimension.
-@item @emph{Standard}:
-Fortran 2008 and later
-
-@item @emph{Class}:
-Inquiry function
-
-@item @emph{Syntax}:
-@code{RESULT = LCOBOUND(COARRAY [, DIM [, KIND]])}
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{ARRAY} @tab Shall be an coarray, of any type.
-@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}.
-@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
-expression indicating the kind parameter of the result.
-@end multitable
-
-@item @emph{Return value}:
-The return value is of type @code{INTEGER} and of kind @var{KIND}. If
-@var{KIND} is absent, the return value is of default integer kind.
-If @var{DIM} is absent, the result is an array of the lower cobounds of
-@var{COARRAY}.  If @var{DIM} is present, the result is a scalar
-corresponding to the lower cobound of the array along that codimension.
-
-@item @emph{See also}:
-@ref{UCOBOUND}, @ref{LBOUND}
+@ref{UBOUND}
  @end table
  
  
  @end table
  
  
@@ -6656,14 +6613,6 @@ expression indicating the kind parameter of the result.
  The return value is of type @code{INTEGER} and of kind @var{KIND}. If
  @var{KIND} is absent, the return value is of default integer kind.
  
  The return value is of type @code{INTEGER} and of kind @var{KIND}. If
  @var{KIND} is absent, the return value is of default integer kind.
  
-
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name               @tab Argument          @tab Return type       @tab Standard
-@item @code{LEN(STRING)} @tab @code{CHARACTER}  @tab @code{INTEGER}    @tab Fortran 77 and later
-@end multitable
-
-
  @item @emph{See also}:
  @ref{LEN_TRIM}, @ref{ADJUSTL}, @ref{ADJUSTR}
  @end table
  @item @emph{See also}:
  @ref{LEN_TRIM}, @ref{ADJUSTL}, @ref{ADJUSTR}
  @end table
@@ -6746,12 +6695,6 @@ Elemental function
  Returns @code{.TRUE.} if @code{STRING_A >= STRING_B}, and @code{.FALSE.}
  otherwise, based on the ASCII ordering.
  
  Returns @code{.TRUE.} if @code{STRING_A >= STRING_B}, and @code{.FALSE.}
  otherwise, based on the ASCII ordering.
  
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name                           @tab Argument          @tab Return type       @tab Standard
-@item @code{LGE(STRING_A, STRING_B)} @tab @code{CHARACTER}  @tab @code{LOGICAL}    @tab Fortran 77 and later
-@end multitable
-
  @item @emph{See also}:
  @ref{LGT}, @ref{LLE}, @ref{LLT}
  @end table
  @item @emph{See also}:
  @ref{LGT}, @ref{LLE}, @ref{LLT}
  @end table
@@ -6798,12 +6741,6 @@ Elemental function
  Returns @code{.TRUE.} if @code{STRING_A > STRING_B}, and @code{.FALSE.}
  otherwise, based on the ASCII ordering.
  
  Returns @code{.TRUE.} if @code{STRING_A > STRING_B}, and @code{.FALSE.}
  otherwise, based on the ASCII ordering.
  
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name                           @tab Argument          @tab Return type       @tab Standard
-@item @code{LGT(STRING_A, STRING_B)} @tab @code{CHARACTER}  @tab @code{LOGICAL}    @tab Fortran 77 and later
-@end multitable
-
  @item @emph{See also}:
  @ref{LGE}, @ref{LLE}, @ref{LLT}
  @end table
  @item @emph{See also}:
  @ref{LGE}, @ref{LLE}, @ref{LLT}
  @end table
@@ -6893,12 +6830,6 @@ Elemental function
  Returns @code{.TRUE.} if @code{STRING_A <= STRING_B}, and @code{.FALSE.}
  otherwise, based on the ASCII ordering.
  
  Returns @code{.TRUE.} if @code{STRING_A <= STRING_B}, and @code{.FALSE.}
  otherwise, based on the ASCII ordering.
  
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name                           @tab Argument          @tab Return type       @tab Standard
-@item @code{LLE(STRING_A, STRING_B)} @tab @code{CHARACTER}  @tab @code{LOGICAL}    @tab Fortran 77 and later
-@end multitable
-
  @item @emph{See also}:
  @ref{LGE}, @ref{LGT}, @ref{LLT}
  @end table
  @item @emph{See also}:
  @ref{LGE}, @ref{LGT}, @ref{LLT}
  @end table
@@ -6945,12 +6876,6 @@ Elemental function
  Returns @code{.TRUE.} if @code{STRING_A < STRING_B}, and @code{.FALSE.}
  otherwise, based on the ASCII ordering.
  
  Returns @code{.TRUE.} if @code{STRING_A < STRING_B}, and @code{.FALSE.}
  otherwise, based on the ASCII ordering.
  
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name                           @tab Argument          @tab Return type       @tab Standard
-@item @code{LLT(STRING_A, STRING_B)} @tab @code{CHARACTER}  @tab @code{LOGICAL}    @tab Fortran 77 and later
-@end multitable
-
  @item @emph{See also}:
  @ref{LGE}, @ref{LGT}, @ref{LLE}
  @end table
  @item @emph{See also}:
  @ref{LGE}, @ref{LGT}, @ref{LLE}
  @end table
@@ -7544,12 +7469,12 @@ and has the same type and kind as the first argument.
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name             @tab Argument             @tab Return type         @tab Standard
-@item @code{MAX0(A1)}  @tab @code{INTEGER(4) A1} @tab @code{INTEGER(4)}   @tab Fortran 77 and later
-@item @code{AMAX0(A1)} @tab @code{INTEGER(4) A1} @tab @code{REAL(MAX(X))} @tab Fortran 77 and later
-@item @code{MAX1(A1)}  @tab @code{REAL A1}       @tab @code{INT(MAX(X))}  @tab Fortran 77 and later
-@item @code{AMAX1(A1)} @tab @code{REAL(4) A1}    @tab @code{REAL(4)}      @tab Fortran 77 and later
-@item @code{DMAX1(A1)} @tab @code{REAL(8) A1}    @tab @code{REAL(8)}      @tab Fortran 77 and later
+@item Name             @tab Argument            @tab Return type         @tab Standard
+@item @code{MAX0(I)}   @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)}   @tab Fortran 77 and later
+@item @code{AMAX0(I)}  @tab @code{INTEGER(4) I} @tab @code{REAL(MAX(X))} @tab Fortran 77 and later
+@item @code{MAX1(X)}   @tab @code{REAL X}    @tab @code{INT(MAX(X))}  @tab Fortran 77 and later
+@item @code{AMAX1(X)}  @tab @code{REAL(4)    X} @tab @code{REAL(4)}      @tab Fortran 77 and later
+@item @code{DMAX1(X)}  @tab @code{REAL(8)    X} @tab @code{REAL(8)}      @tab Fortran 77 and later
  @end multitable
  
  @item @emph{See also}:
  @end multitable
  
  @item @emph{See also}:
@@ -7864,12 +7789,12 @@ and has the same type and kind as the first argument.
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name              @tab Argument             @tab Return type        @tab Standard
-@item @code{MIN0(A1)}   @tab @code{INTEGER(4) A1} @tab @code{INTEGER(4)}  @tab Fortran 77 and later
-@item @code{AMIN0(A1)}  @tab @code{INTEGER(4) A1} @tab @code{REAL(4)}     @tab Fortran 77 and later
-@item @code{MIN1(A1)}   @tab @code{REAL A1}       @tab @code{INTEGER(4)}  @tab Fortran 77 and later
-@item @code{AMIN1(A1)}  @tab @code{REAL(4) A1}    @tab @code{REAL(4)}     @tab Fortran 77 and later
-@item @code{DMIN1(A1)}  @tab @code{REAL(8) A1}    @tab @code{REAL(8)}     @tab Fortran 77 and later
+@item Name             @tab Argument            @tab Return type         @tab Standard
+@item @code{MIN0(I)}   @tab @code{INTEGER(4) I} @tab @code{INTEGER(4)}   @tab Fortran 77 and later
+@item @code{AMIN0(I)}  @tab @code{INTEGER(4) I} @tab @code{REAL(MIN(X))} @tab Fortran 77 and later
+@item @code{MIN1(X)}   @tab @code{REAL X}    @tab @code{INT(MIN(X))}  @tab Fortran 77 and later
+@item @code{AMIN1(X)}  @tab @code{REAL(4)    X} @tab @code{REAL(4)}      @tab Fortran 77 and later
+@item @code{DMIN1(X)}  @tab @code{REAL(8)    X} @tab @code{REAL(8)}      @tab Fortran 77 and later
  @end multitable
  
  @item @emph{See also}:
  @end multitable
  
  @item @emph{See also}:
@@ -8079,10 +8004,9 @@ end program test_mod
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name             @tab Arguments          @tab Return type    @tab Standard
-@item @code{MOD(A,P)}  @tab @code{INTEGER A,P} @tab @code{INTEGER} @tab Fortran 95 and later
-@item @code{AMOD(A,P)} @tab @code{REAL(4) A,P} @tab @code{REAL(4)} @tab Fortran 95 and later
-@item @code{DMOD(A,P)} @tab @code{REAL(8) A,P} @tab @code{REAL(8)} @tab Fortran 95 and later
+@item Name             @tab Arguments      @tab Return type    @tab Standard
+@item @code{AMOD(A,P)} @tab @code{REAL(4)} @tab @code{REAL(4)} @tab Fortran 95 and later
+@item @code{DMOD(A,P)} @tab @code{REAL(8)} @tab @code{REAL(8)} @tab Fortran 95 and later
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -8359,10 +8283,9 @@ end program test_nint
  @end smallexample
  
  @item @emph{Specific names}:
  @end smallexample
  
  @item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name             @tab Argument           @tab Return Type     @tab Standard
-@item @code{NINT(A)}   @tab @code{REAL(4) A}   @tab  @code{INTEGER} @tab Fortran 95 and later
-@item @code{IDNINT(A)} @tab @code{REAL(8) A}   @tab  @code{INTEGER} @tab Fortran 95 and later
+@multitable @columnfractions .25 .25 .25
+@item Name             @tab Argument         @tab Standard
+@item @code{IDNINT(X)} @tab @code{REAL(8)}   @tab Fortran 95 and later
  @end multitable
  
  @item @emph{See also}:
  @end multitable
  
  @item @emph{See also}:
@@ -8491,7 +8414,7 @@ END IF
  @end smallexample
  
  @item @emph{See also}:
  @end smallexample
  
  @item @emph{See also}:
-@ref{THIS_IMAGE}, @ref{IMAGE_INDEX}
+@c FIXME: ref{THIS_IMAGE}
  @end table
  
  
  @end table
  
  
@@ -9070,9 +8993,6 @@ See @code{PRECISION} for an example.
  @section @code{REAL} --- Convert to real type 
  @fnindex REAL
  @fnindex REALPART
  @section @code{REAL} --- Convert to real type 
  @fnindex REAL
  @fnindex REALPART
-@fnindex FLOAT
-@fnindex DFLOAT
-@fnindex SNGL
  @cindex conversion, to real
  @cindex complex numbers, real part
  
  @cindex conversion, to real
  @cindex complex numbers, real part
  
@@ -9127,17 +9047,8 @@ program test_real
  end program test_real
  @end smallexample
  
  end program test_real
  @end smallexample
  
-@item @emph{Specific names}:
-@multitable @columnfractions .20 .20 .20 .25
-@item Name             @tab Argument           @tab Return type     @tab Standard
-@item @code{FLOAT(A)}  @tab @code{INTEGER(4)}  @tab @code{REAL(4)}  @tab Fortran 77 and later
-@item @code{DFLOAT(A)} @tab @code{INTEGER(4)}  @tab @code{REAL(8)}  @tab GNU extension
-@item @code{SNGL(A)}   @tab @code{INTEGER(8)}  @tab @code{REAL(4)}  @tab Fortran 77 and later
-@end multitable
-
-
  @item @emph{See also}:
  @item @emph{See also}:
-@ref{DBLE}
+@ref{DBLE}, @ref{DFLOAT}, @ref{FLOAT}
  
  @end table
  
  
  @end table
  
@@ -9833,10 +9744,9 @@ end program test_sign
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name              @tab Arguments              @tab Return type       @tab Standard
-@item @code{SIGN(A,B)}  @tab @code{REAL(4) A, B}    @tab @code{REAL(4)}    @tab f77, gnu
-@item @code{ISIGN(A,B)} @tab @code{INTEGER(4) A, B} @tab @code{INTEGER(4)} @tab f77, gnu
-@item @code{DSIGN(A,B)} @tab @code{REAL(8) A, B}    @tab @code{REAL(8)}    @tab f77, gnu
+@item Name              @tab Arguments      @tab Return type    @tab Standard
+@item @code{ISIGN(A,P)} @tab @code{INTEGER(4)} @tab @code{INTEGER(4)} @tab f95, gnu
+@item @code{DSIGN(A,P)} @tab @code{REAL(8)} @tab @code{REAL(8)} @tab f95, gnu
  @end multitable
  @end table
  
  @end multitable
  @end table
  
@@ -9942,12 +9852,11 @@ end program test_sin
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name            @tab Argument             @tab Return type       @tab Standard
-@item @code{SIN(X)}   @tab @code{REAL(4) X}     @tab @code{REAL(4)}    @tab f77, gnu
-@item @code{DSIN(X)}  @tab @code{REAL(8) X}     @tab @code{REAL(8)}    @tab f95, gnu
-@item @code{CSIN(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)} @tab f95, gnu
-@item @code{ZSIN(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)} @tab f95, gnu
-@item @code{CDSIN(X)} @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)} @tab f95, gnu
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{DSIN(X)}  @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab f95, gnu
+@item @code{CSIN(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)}    @tab f95, gnu
+@item @code{ZSIN(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}    @tab f95, gnu
+@item @code{CDSIN(X)} @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}    @tab f95, gnu
  @end multitable
  
  @item @emph{See also}:
  @end multitable
  
  @item @emph{See also}:
@@ -9996,7 +9905,6 @@ end program test_sinh
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
-@item @code{SINH(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 95 and later
  @item @code{DSINH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 95 and later
  @end multitable
  
  @item @code{DSINH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 95 and later
  @end multitable
  
@@ -10136,6 +10044,40 @@ end
  
  
  
  
  
  
+@node SNGL
+@section @code{SNGL} --- Convert double precision real to default real
+@fnindex SNGL
+@cindex conversion, to real
+
+@table @asis
+@item @emph{Description}:
+@code{SNGL(A)} converts the double precision real @var{A}
+to a default real value. This is an archaic form of @code{REAL}
+that is specific to one type for @var{A}.
+
+@item @emph{Standard}:
+Fortran 77 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = SNGL(A)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab The type shall be a double precision @code{REAL}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type default @code{REAL}.
+
+@item @emph{See also}:
+@ref{DBLE}
+@end table
+
+
+
  @node SPACING
  @section @code{SPACING} --- Smallest distance between two numbers of a given type
  @fnindex SPACING
  @node SPACING
  @section @code{SPACING} --- Smallest distance between two numbers of a given type
  @fnindex SPACING
@@ -10276,7 +10218,6 @@ end program test_sqrt
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name             @tab Argument             @tab Return type          @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name             @tab Argument             @tab Return type          @tab Standard
-@item @code{SQRT(X)}   @tab @code{REAL(4) X}     @tab @code{REAL(4)}       @tab Fortran 95 and later
  @item @code{DSQRT(X)}  @tab @code{REAL(8) X}     @tab @code{REAL(8)}       @tab Fortran 95 and later
  @item @code{CSQRT(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)}    @tab Fortran 95 and later
  @item @code{ZSQRT(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}    @tab GNU extension
  @item @code{DSQRT(X)}  @tab @code{REAL(8) X}     @tab @code{REAL(8)}       @tab Fortran 95 and later
  @item @code{CSQRT(X)}  @tab @code{COMPLEX(4) X}  @tab @code{COMPLEX(4)}    @tab Fortran 95 and later
  @item @code{ZSQRT(X)}  @tab @code{COMPLEX(8) X}  @tab @code{COMPLEX(8)}    @tab GNU extension
@@ -10651,9 +10592,8 @@ end program test_tan
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
-@item Name            @tab Argument          @tab Return type     @tab Standard
-@item @code{TAN(X)}   @tab @code{REAL(4) X}  @tab @code{REAL(4)}  @tab Fortran 95 and later
-@item @code{DTAN(X)}  @tab @code{REAL(8) X}  @tab @code{REAL(8)}  @tab Fortran 95 and later
+@item Name            @tab Argument          @tab Return type       @tab Standard
+@item @code{DTAN(X)}  @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 95 and later
  @end multitable
  
  @item @emph{See also}:
  @end multitable
  
  @item @emph{See also}:
@@ -10705,7 +10645,6 @@ end program test_tanh
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
  @item @emph{Specific names}:
  @multitable @columnfractions .20 .20 .20 .25
  @item Name            @tab Argument          @tab Return type       @tab Standard
-@item @code{TANH(X)}  @tab @code{REAL(4) X}  @tab @code{REAL(4)}    @tab Fortran 95 and later
  @item @code{DTANH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 95 and later
  @end multitable
  
  @item @code{DTANH(X)} @tab @code{REAL(8) X}  @tab @code{REAL(8)}    @tab Fortran 95 and later
  @end multitable
  
@@ -10715,64 +10654,6 @@ end program test_tanh
  
  
  
  
  
  
-@node THIS_IMAGE
-@section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image
-@fnindex THIS_IMAGE
-@cindex coarray, THIS_IMAGE
-@cindex images, index of this image
-
-@table @asis
-@item @emph{Description}:
-Returns the cosubscript for this image.
-
-@item @emph{Standard}:
-Fortran 2008 and later
-
-@item @emph{Class}:
-Transformational function
-
-@item @emph{Syntax}:
-@multitable @columnfractions .80
-@item @code{RESULT = THIS_IMAGE()}
-@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])}
-@end multitable
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{COARRAY} @tab Coarray of any type  (optional; if @var{DIM}
-present, required).
-@item @var{DIM}     @tab default integer scalar (optional). If present,
-@var{DIM} shall be between one and the corank of @var{COARRAY}.
-@end multitable
-
-
-@item @emph{Return value}:
-Default integer. If @var{COARRAY} is not present, it is scalar and its value
-is the index of the invoking image. Otherwise, if @var{DIM} is not present,
-a rank-1 array with corank elements is returned, containing the cosubscripts
-for @var{COARRAY} specifying the invoking image. If @var{DIM} is present,
-a scalar is returned, with the value of the @var{DIM} element of
-@code{THIS_IMAGE(COARRAY)}.
-
-@item @emph{Example}:
-@smallexample
-INTEGER :: value[*]
-INTEGER :: i
-value = THIS_IMAGE()
-SYNC ALL
-IF (THIS_IMAGE() == 1) THEN
-  DO i = 1, NUM_IMAGES()
-    WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
-  END DO
-END IF
-@end smallexample
-
-@item @emph{See also}:
-@ref{NUM_IMAGES}, @ref{IMAGE_INDEX}
-@end table
-
-
-
  @node TIME
  @section @code{TIME} --- Time function
  @fnindex TIME
  @node TIME
  @section @code{TIME} --- Time function
  @fnindex TIME
@@ -11149,46 +11030,7 @@ dimension, the upper bound is taken to be the number of elements along
  the relevant dimension.
  
  @item @emph{See also}:
  the relevant dimension.
  
  @item @emph{See also}:
-@ref{LBOUND}, @ref{LCOBOUND}
-@end table
-
-
-
-@node UCOBOUND
-@section @code{UCOBOUND} --- Upper codimension bounds of an array
-@fnindex UCOBOUND
-@cindex coarray, upper bound
-
-@table @asis
-@item @emph{Description}:
-Returns the upper cobounds of a coarray, or a single upper cobound
-along the @var{DIM} codimension.
-@item @emph{Standard}:
-Fortran 2008 and later
-
-@item @emph{Class}:
-Inquiry function
-
-@item @emph{Syntax}:
-@code{RESULT = UCOBOUND(COARRAY [, DIM [, KIND]])}
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{ARRAY} @tab Shall be an coarray, of any type.
-@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}.
-@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
-expression indicating the kind parameter of the result.
-@end multitable
-
-@item @emph{Return value}:
-The return value is of type @code{INTEGER} and of kind @var{KIND}. If
-@var{KIND} is absent, the return value is of default integer kind.
-If @var{DIM} is absent, the result is an array of the lower cobounds of
-@var{COARRAY}.  If @var{DIM} is present, the result is a scalar
-corresponding to the lower cobound of the array along that codimension.
-
-@item @emph{See also}:
-@ref{LCOBOUND}, @ref{LBOUND}
+@ref{LBOUND}
  @end table
  
  
  @end table
  
  
@@ -11439,21 +11281,14 @@ Fortran 95 elemental function: @ref{IEOR}
  @section @code{ISO_FORTRAN_ENV}
  @table @asis
  @item @emph{Standard}:
  @section @code{ISO_FORTRAN_ENV}
  @table @asis
  @item @emph{Standard}:
-Fortran 2003 and later, except when otherwise noted
+Fortran 2003 and later; @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64},
+@code{REAL32}, @code{REAL64}, @code{REAL128} are Fortran 2008 or later
  @end table
  
  The @code{ISO_FORTRAN_ENV} module provides the following scalar default-integer
  named constants:
  
  @table @asis
  @end table
  
  The @code{ISO_FORTRAN_ENV} module provides the following scalar default-integer
  named constants:
  
  @table @asis
-@item @code{ATOMIC_INT_KIND}:
-Default-kind integer constant to be used as kind parameter when defining
-integer variables used in atomic operations. (Fortran 2008 or later.)
-
-@item @code{ATOMIC_LOGICAL_KIND}:
-Default-kind integer constant to be used as kind parameter when defining
-logical variables used in atomic operations. (Fortran 2008 or later.)
-
  @item @code{CHARACTER_STORAGE_SIZE}:
  Size in bits of the character storage unit.
  
  @item @code{CHARACTER_STORAGE_SIZE}:
  Size in bits of the character storage unit.
  
@@ -11467,10 +11302,10 @@ Size in bits of the file-storage unit.
  Identifies the preconnected unit identified by the asterisk
  (@code{*}) in @code{READ} statement.
  
  Identifies the preconnected unit identified by the asterisk
  (@code{*}) in @code{READ} statement.
  
-@item @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64}:
+@item @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64}
  Kind type parameters to specify an INTEGER type with a storage
  size of 16, 32, and 64 bits. It is negative if a target platform
  Kind type parameters to specify an INTEGER type with a storage
  size of 16, 32, and 64 bits. It is negative if a target platform
-does not support the particular kind. (Fortran 2008 or later.)
+does not support the particular kind.
  
  @item @code{IOSTAT_END}:
  The value assigned to the variable passed to the IOSTAT= specifier of
  
  @item @code{IOSTAT_END}:
  The value assigned to the variable passed to the IOSTAT= specifier of
@@ -11480,11 +11315,6 @@ an input/output statement if an end-of-file condition occurred.
  The value assigned to the variable passed to the IOSTAT= specifier of
  an input/output statement if an end-of-record condition occurred.
  
  The value assigned to the variable passed to the IOSTAT= specifier of
  an input/output statement if an end-of-record condition occurred.
  
-@item @code{IOSTAT_INQUIRE_INTERNAL_UNIT}:
-Scalar default-integer constant, used by @code{INQUIRE} for the
-IOSTAT= specifier to denote an that a unit number identifies an
-internal unit. (Fortran 2008 or later.)
-
  @item @code{NUMERIC_STORAGE_SIZE}:
  The size in bits of the numeric storage unit.
  
  @item @code{NUMERIC_STORAGE_SIZE}:
  The size in bits of the numeric storage unit.
  
@@ -11492,29 +11322,10 @@ The size in bits of the numeric storage unit.
  Identifies the preconnected unit identified by the asterisk
  (@code{*}) in @code{WRITE} statement.
  
  Identifies the preconnected unit identified by the asterisk
  (@code{*}) in @code{WRITE} statement.
  
-@item @code{REAL32}, @code{REAL64}, @code{REAL128}:
+@item @code{REAL32}, @code{REAL64}, @code{REAL128}
  Kind type parameters to specify a REAL type with a storage
  size of 32, 64, and 128 bits. It is negative if a target platform
  Kind type parameters to specify a REAL type with a storage
  size of 32, 64, and 128 bits. It is negative if a target platform
-does not support the particular kind. (Fortran 2008 or later.)
-
-@item @code{STAT_LOCKED}:
-Scalar default-integer constant used as STAT= return value by @code{LOCK} to
-denote that the lock variable is locked by the executing image. (Fortran 2008
-or later.)
-
-@item @code{STAT_LOCKED_OTHER_IMAGE}:
-Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to
-denote that the lock variable is locked by another image. (Fortran 2008 or
-later.)
-
-@item @code{STAT_STOPPED_IMAGE}:
-Positive, scalar default-integer constant used as STAT= return value if the
-argument in the statement requires synchronisation with an image, which has
-initiated the termination of the execution. (Fortran 2008 or later.)
-
-@item @code{STAT_UNLOCKED}:
-Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to
-denote that the lock variable is unlocked. (Fortran 2008 or later.)
+does not support the particular kind.
  @end table
  
  
  @end table
  
  
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c

index a4900aa..48bb733 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1,6 +1,5 @@
  /* Matching subroutines in all sizes, shapes and colors.
  /* Matching subroutines in all sizes, shapes and colors.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-   2009, 2010
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
     2010 Free Software Foundation, Inc.
     Contributed by Andy Vaught
  
     2010 Free Software Foundation, Inc.
     Contributed by Andy Vaught
  
@@ -950,8 +949,6 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
    locus start;
    match m;
  
    locus start;
    match m;
  
-  e1 = e2 = e3 = NULL;
-
    /* Match the start of an iterator without affecting the symbol table.  */
  
    start = gfc_current_locus;
    /* Match the start of an iterator without affecting the symbol table.  */
  
    start = gfc_current_locus;
@@ -965,12 +962,9 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
    if (m != MATCH_YES)
      return MATCH_NO;
  
    if (m != MATCH_YES)
      return MATCH_NO;
  
-  /* F2008, C617 & C565.  */
-  if (var->symtree->n.sym->attr.codimension)
-    {
-      gfc_error ("Loop variable at %C cannot be a coarray");
-      goto cleanup;
-    }
+  gfc_match_char ('=');
+
+  e1 = e2 = e3 = NULL;
  
    if (var->ref != NULL)
      {
  
    if (var->ref != NULL)
      {
@@ -985,8 +979,6 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
        goto cleanup;
      }
  
        goto cleanup;
      }
  
-  gfc_match_char ('=');
-
    var->symtree->n.sym->attr.implied_index = 1;
  
    m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
    var->symtree->n.sym->attr.implied_index = 1;
  
    m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
@@ -1006,7 +998,7 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
  
    if (gfc_match_char (',') != MATCH_YES)
      {
  
    if (gfc_match_char (',') != MATCH_YES)
      {
-      e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+      e3 = gfc_int_expr (1);
        goto done;
      }
  
        goto done;
      }
  
@@ -1751,12 +1743,6 @@ gfc_match_critical (void)
        == FAILURE)
      return MATCH_ERROR;
  
        == FAILURE)
      return MATCH_ERROR;
  
-  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
-    {
-       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
-       return MATCH_ERROR;
-    }
-
    if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
      {
        gfc_error ("Nested CRITICAL block at %C");
    if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
      {
        gfc_error ("Nested CRITICAL block at %C");
@@ -1827,7 +1813,7 @@ gfc_match_do (void)
  
    if (gfc_match_eos () == MATCH_YES)
      {
  
    if (gfc_match_eos () == MATCH_YES)
      {
-      iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
+      iter.end = gfc_logical_expr (1, NULL);
        new_st.op = EXEC_DO_WHILE;
        goto done;
      }
        new_st.op = EXEC_DO_WHILE;
        goto done;
      }
@@ -2006,23 +1992,42 @@ gfc_match_cycle (void)
  static match
  gfc_match_stopcode (gfc_statement st)
  {
  static match
  gfc_match_stopcode (gfc_statement st)
  {
+  int stop_code;
    gfc_expr *e;
    match m;
    gfc_expr *e;
    match m;
+  int cnt;
  
  
+  stop_code = -1;
    e = NULL;
  
    if (gfc_match_eos () != MATCH_YES)
      {
    e = NULL;
  
    if (gfc_match_eos () != MATCH_YES)
      {
-      m = gfc_match_init_expr (&e);
+      m = gfc_match_small_literal_int (&stop_code, &cnt);
        if (m == MATCH_ERROR)
         goto cleanup;
        if (m == MATCH_ERROR)
         goto cleanup;
+
+      if (m == MATCH_YES && cnt > 5)
+       {
+         gfc_error ("Too many digits in STOP code at %C");
+         goto cleanup;
+       }
+
        if (m == MATCH_NO)
        if (m == MATCH_NO)
+       {
+         /* Try a character constant.  */
+         m = gfc_match_expr (&e);
+         if (m == MATCH_ERROR)
+           goto cleanup;
+         if (m == MATCH_NO)
+           goto syntax;
+         if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+           goto syntax;
+       }
+
+      if (gfc_match_eos () != MATCH_YES)
         goto syntax;
      }
  
         goto syntax;
      }
  
-  if (gfc_match_eos () != MATCH_YES)
-    goto syntax;
-
    if (gfc_pure (NULL))
      {
        gfc_error ("%s statement not allowed in PURE procedure at %C",
    if (gfc_pure (NULL))
      {
        gfc_error ("%s statement not allowed in PURE procedure at %C",
@@ -2033,40 +2038,7 @@ gfc_match_stopcode (gfc_statement st)
    if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
      {
        gfc_error ("Image control statement STOP at %C in CRITICAL block");
    if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
      {
        gfc_error ("Image control statement STOP at %C in CRITICAL block");
-      goto cleanup;
-    }
-
-  if (e != NULL)
-    {
-      if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
-       {
-         gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
-                    &e->where);
-         goto cleanup;
-       }
-
-      if (e->rank != 0)
-       {
-         gfc_error ("STOP code at %L must be scalar",
-                    &e->where);
-         goto cleanup;
-       }
-
-      if (e->ts.type == BT_CHARACTER
-         && e->ts.kind != gfc_default_character_kind)
-       {
-         gfc_error ("STOP code at %L must be default character KIND=%d",
-                    &e->where, (int) gfc_default_character_kind);
-         goto cleanup;
-       }
-
-      if (e->ts.type == BT_INTEGER
-         && e->ts.kind != gfc_default_integer_kind)
-       {
-         gfc_error ("STOP code at %L must be default integer KIND=%d",
-                    &e->where, (int) gfc_default_integer_kind);
-         goto cleanup;
-       }
+      return MATCH_ERROR;
      }
  
    switch (st)
      }
  
    switch (st)
@@ -2085,7 +2057,7 @@ gfc_match_stopcode (gfc_statement st)
      }
  
    new_st.expr1 = e;
      }
  
    new_st.expr1 = e;
-  new_st.ext.stop_code = -1;
+  new_st.ext.stop_code = stop_code;
  
    return MATCH_YES;
  
  
    return MATCH_YES;
  
@@ -2166,12 +2138,6 @@ sync_statement (gfc_statement st)
        == FAILURE)
      return MATCH_ERROR;
  
        == FAILURE)
      return MATCH_ERROR;
  
-  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
-    {
-       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
-       return MATCH_ERROR;
-    }
-
    if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
      {
        gfc_error ("Image control statement SYNC at %C in CRITICAL block");
    if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
      {
        gfc_error ("Image control statement SYNC at %C in CRITICAL block");
@@ -2479,8 +2445,7 @@ gfc_match_goto (void)
         }
  
        cp = gfc_get_case ();
         }
  
        cp = gfc_get_case ();
-      cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
-                                            NULL, i++);
+      cp->low = cp->high = gfc_int_expr (i++);
  
        tail->op = EXEC_SELECT;
        tail->ext.case_list = cp;
  
        tail->op = EXEC_SELECT;
        tail->ext.case_list = cp;
@@ -2960,7 +2925,10 @@ gfc_match_nullify (void)
         }
  
        /* build ' => NULL() '.  */
         }
  
        /* build ' => NULL() '.  */
-      e = gfc_get_null_expr (&gfc_current_locus);
+      e = gfc_get_expr ();
+      e->where = gfc_current_locus;
+      e->expr_type = EXPR_NULL;
+      e->ts.type = BT_UNKNOWN;
  
        /* Chain to list.  */
        if (tail == NULL)
  
        /* Chain to list.  */
        if (tail == NULL)
@@ -3368,8 +3336,7 @@ gfc_match_call (void)
           c->op = EXEC_SELECT;
  
           new_case = gfc_get_case ();
           c->op = EXEC_SELECT;
  
           new_case = gfc_get_case ();
-         new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
-         new_case->low = new_case->high;
+         new_case->high = new_case->low = gfc_int_expr (i);
           c->ext.case_list = new_case;
  
           c->next = gfc_get_code ();
           c->ext.case_list = new_case;
  
           c->next = gfc_get_code ();
@@ -3595,7 +3562,7 @@ gfc_match_common (void)
  
           /* Deal with an optional array specification after the
              symbol name.  */
  
           /* Deal with an optional array specification after the
              symbol name.  */
-         m = gfc_match_array_spec (&as, true, true);
+         m = gfc_match_array_spec (&as);
           if (m == MATCH_ERROR)
             goto cleanup;
  
           if (m == MATCH_ERROR)
             goto cleanup;
  
@@ -4294,7 +4261,7 @@ select_type_set_tmp (gfc_typespec *ts)
    if (ts->type == BT_CLASS)
      {
        gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
    if (ts->type == BT_CLASS)
      {
        gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
-                             &tmp->n.sym->as, false);
+                             &tmp->n.sym->as);
        tmp->n.sym->attr.class_ok = 1;
      }
  
        tmp->n.sym->attr.class_ok = 1;
      }
  
@@ -4327,14 +4294,8 @@ gfc_match_select_type (void)
        expr1 = gfc_get_expr();
        expr1->expr_type = EXPR_VARIABLE;
        if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
        expr1 = gfc_get_expr();
        expr1->expr_type = EXPR_VARIABLE;
        if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
-       {
-         m = MATCH_ERROR;
-         goto cleanup;
-       }
-      if (expr2->ts.type == BT_UNKNOWN)
-       expr1->symtree->n.sym->attr.untyped = 1;
-      else
-       expr1->symtree->n.sym->ts = expr2->ts;
+       return MATCH_ERROR;
+      expr1->symtree->n.sym->ts = expr2->ts;
        expr1->symtree->n.sym->attr.referenced = 1;
        expr1->symtree->n.sym->attr.class_ok = 1;
      }
        expr1->symtree->n.sym->attr.referenced = 1;
        expr1->symtree->n.sym->attr.class_ok = 1;
      }
@@ -4342,20 +4303,27 @@ gfc_match_select_type (void)
      {
        m = gfc_match (" %e ", &expr1);
        if (m != MATCH_YES)
      {
        m = gfc_match (" %e ", &expr1);
        if (m != MATCH_YES)
-       goto cleanup;
+       return m;
      }
  
    m = gfc_match (" )%t");
    if (m != MATCH_YES)
      }
  
    m = gfc_match (" )%t");
    if (m != MATCH_YES)
-    goto cleanup;
+    return m;
  
    /* Check for F03:C811.  */
    if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
      {
        gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
                  "use associate-name=>");
  
    /* Check for F03:C811.  */
    if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
      {
        gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
                  "use associate-name=>");
-      m = MATCH_ERROR;
-      goto cleanup;
+      return MATCH_ERROR;
+    }
+
+  /* Check for F03:C813.  */
+  if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
+    {
+      gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
+                "at %C");
+      return MATCH_ERROR;
      }
  
    new_st.op = EXEC_SELECT_TYPE;
      }
  
    new_st.op = EXEC_SELECT_TYPE;
@@ -4366,10 +4334,6 @@ gfc_match_select_type (void)
    select_type_push (expr1->symtree->n.sym);
  
    return MATCH_YES;
    select_type_push (expr1->symtree->n.sym);
  
    return MATCH_YES;
-  
-cleanup:
-  gfc_current_ns = gfc_current_ns->parent;
-  return m;
  }
  
  
  }
  
  
@@ -4803,7 +4767,7 @@ match_forall_iterator (gfc_forall_iterator **result)
      goto cleanup;
  
    if (gfc_match_char (':') == MATCH_NO)
      goto cleanup;
  
    if (gfc_match_char (':') == MATCH_NO)
-    iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+    iter->stride = gfc_int_expr (1);
    else
      {
        m = gfc_match_expr (&iter->stride);
    else
      {
        m = gfc_match_expr (&iter->stride);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c

index 24ec7a8..8ef347d 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7315,6 +7315,48 @@ find_reachable_labels (gfc_code *block)
      }
  }
  
      }
  }
  
+
+static void
+resolve_sync (gfc_code *code)
+{
+  /* Check imageset. The * case matches expr1 == NULL.  */
+  if (code->expr1)
+    {
+      if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
+       gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
+                  "INTEGER expression", &code->expr1->where);
+      if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
+         && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
+       gfc_error ("Imageset argument at %L must between 1 and num_images()",
+                  &code->expr1->where);
+      else if (code->expr1->expr_type == EXPR_ARRAY
+              && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
+       {
+          gfc_constructor *cons;
+          for (cons = code->expr1->value.constructor; cons; cons = cons->next)
+            if (cons->expr->expr_type == EXPR_CONSTANT
+                &&  mpz_cmp_si (cons->expr->value.integer, 1) < 0)
+              gfc_error ("Imageset argument at %L must between 1 and "
+                         "num_images()", &cons->expr->where);
+       }
+    }
+
+  /* Check STAT.  */
+  if (code->expr2
+      && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+         || code->expr2->expr_type != EXPR_VARIABLE))
+    gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+              &code->expr2->where);
+
+  /* Check ERRMSG.  */
+  if (code->expr3
+      && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+         || code->expr3->expr_type != EXPR_VARIABLE))
+    gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+              &code->expr3->where);
+}
+
+
  /* Given a branch to a label, see if the branch is conforming.
     The code node describes where the branch is located.  */
  
  /* Given a branch to a label, see if the branch is conforming.
     The code node describes where the branch is located.  */
  
@@ -7355,15 +7397,36 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
       the bitmap reachable_labels.  */
  
    if (bitmap_bit_p (cs_base->reachable_labels, label->value))
       the bitmap reachable_labels.  */
  
    if (bitmap_bit_p (cs_base->reachable_labels, label->value))
-    return;
+    {
+      /* Check now whether there is a CRITICAL construct; if so, check
+        whether the label is still visible outside of the CRITICAL block,
+        which is invalid.  */
+      for (stack = cs_base; stack; stack = stack->prev)
+       if (stack->current->op == EXEC_CRITICAL
+           && bitmap_bit_p (stack->reachable_labels, label->value))
+         gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
+                     " at %L", &code->loc, &label->where);
+
+      return;
+    }
  
    /* Step four:  If we haven't found the label in the bitmap, it may
      still be the label of the END of the enclosing block, in which
      case we find it by going up the code_stack.  */
  
    for (stack = cs_base; stack; stack = stack->prev)
  
    /* Step four:  If we haven't found the label in the bitmap, it may
      still be the label of the END of the enclosing block, in which
      case we find it by going up the code_stack.  */
  
    for (stack = cs_base; stack; stack = stack->prev)
-    if (stack->current->next && stack->current->next->here == label)
-      break;
+    {
+      if (stack->current->next && stack->current->next->here == label)
+       break;
+      if (stack->current->op == EXEC_CRITICAL)
+       {
+         /* Note: A label at END CRITICAL does not leave the CRITICAL
+            construct as END CRITICAL is still part of it.  */
+         gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
+                     " at %L", &code->loc, &label->where);
+         return;
+       }
+    }
  
    if (stack)
      {
  
    if (stack)
      {
@@ -7788,6 +7851,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
         case EXEC_FORALL:
         case EXEC_DO:
         case EXEC_DO_WHILE:
         case EXEC_FORALL:
         case EXEC_DO:
         case EXEC_DO_WHILE:
+       case EXEC_CRITICAL:
         case EXEC_READ:
         case EXEC_WRITE:
         case EXEC_IOLENGTH:
         case EXEC_READ:
         case EXEC_WRITE:
         case EXEC_IOLENGTH:
@@ -8068,10 +8132,18 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
         case EXEC_CYCLE:
         case EXEC_PAUSE:
         case EXEC_STOP:
         case EXEC_CYCLE:
         case EXEC_PAUSE:
         case EXEC_STOP:
+       case EXEC_ERROR_STOP:
         case EXEC_EXIT:
         case EXEC_CONTINUE:
         case EXEC_DT_END:
         case EXEC_ASSIGN_CALL:
         case EXEC_EXIT:
         case EXEC_CONTINUE:
         case EXEC_DT_END:
         case EXEC_ASSIGN_CALL:
+       case EXEC_CRITICAL:
+         break;
+
+       case EXEC_SYNC_ALL:
+       case EXEC_SYNC_IMAGES:
+       case EXEC_SYNC_MEMORY:
+         resolve_sync (code);
           break;
  
         case EXEC_ENTRY:
           break;
  
         case EXEC_ENTRY:
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c

index 743c463..60fbf01 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3868,6 +3868,17 @@ gfc_simplify_num_images (void)
  
  
  gfc_expr *
  
  
  gfc_expr *
+gfc_simplify_num_images (void)
+{
+  gfc_expr *result;
+  /* FIXME: gfc_current_locus is wrong.  */
+  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
+  mpz_set_si (result->value.integer, 1);
+  return result;
+}
+
+
+gfc_expr *
  gfc_simplify_or (gfc_expr *x, gfc_expr *y)
  {
    gfc_expr *result;
  gfc_simplify_or (gfc_expr *x, gfc_expr *y)
  {
    gfc_expr *result;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c

index 5bafdcc..53c4b47 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -26,11 +26,11 @@ along with GCC; see the file COPYING3.  If not see
  #include "coretypes.h"
  #include "tree.h"
  #include "tree-dump.h"
  #include "coretypes.h"
  #include "tree.h"
  #include "tree-dump.h"
-#include "gimple.h"    /* For create_tmp_var_raw.  */
+#include "gimple.h"
  #include "ggc.h"
  #include "toplev.h"
  #include "ggc.h"
  #include "toplev.h"
-#include "tm.h"                /* For rtl.h.  */
-#include "rtl.h"       /* For decl_default_tls_model.  */
+#include "tm.h"
+#include "rtl.h"
  #include "target.h"
  #include "function.h"
  #include "flags.h"
  #include "target.h"
  #include "function.h"
  #include "flags.h"
@@ -38,7 +38,6 @@ along with GCC; see the file COPYING3.  If not see
  #include "debug.h"
  #include "gfortran.h"
  #include "pointer-set.h"
  #include "debug.h"
  #include "gfortran.h"
  #include "pointer-set.h"
-#include "constructor.h"
  #include "trans.h"
  #include "trans-types.h"
  #include "trans-array.h"
  #include "trans.h"
  #include "trans-types.h"
  #include "trans-array.h"
@@ -86,7 +85,6 @@ tree gfor_fndecl_pause_numeric;
  tree gfor_fndecl_pause_string;
  tree gfor_fndecl_stop_numeric;
  tree gfor_fndecl_stop_string;
  tree gfor_fndecl_pause_string;
  tree gfor_fndecl_stop_numeric;
  tree gfor_fndecl_stop_string;
-tree gfor_fndecl_error_stop_numeric;
  tree gfor_fndecl_error_stop_string;
  tree gfor_fndecl_runtime_error;
  tree gfor_fndecl_runtime_error_at;
  tree gfor_fndecl_error_stop_string;
  tree gfor_fndecl_runtime_error;
  tree gfor_fndecl_runtime_error_at;
@@ -772,33 +770,19 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
  
        for (dim = sym->as->rank - 1; dim >= 0; dim--)
         {
  
        for (dim = sym->as->rank - 1; dim >= 0; dim--)
         {
-         tree lbound, ubound;
-         lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
-         ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
-         rtype = build_range_type (gfc_array_index_type, lbound, ubound);
+         rtype = build_range_type (gfc_array_index_type,
+                                   GFC_TYPE_ARRAY_LBOUND (type, dim),
+                                   GFC_TYPE_ARRAY_UBOUND (type, dim));
           gtype = build_array_type (gtype, rtype);
           gtype = build_array_type (gtype, rtype);
-         /* Ensure the bound variables aren't optimized out at -O0.
-            For -O1 and above they often will be optimized out, but
-            can be tracked by VTA.  Also clear the artificial
-            lbound.N or ubound.N DECL_NAME, so that it doesn't end up
-            in debug info.  */
-         if (lbound && TREE_CODE (lbound) == VAR_DECL
-             && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
+         /* Ensure the bound variables aren't optimized out at -O0.  */
+         if (!optimize)
             {
             {
-             if (DECL_NAME (lbound)
-                 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
-                            "lbound") != 0)
-               DECL_NAME (lbound) = NULL_TREE;
-             DECL_IGNORED_P (lbound) = 0;
-           }
-         if (ubound && TREE_CODE (ubound) == VAR_DECL
-             && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
-           {
-             if (DECL_NAME (ubound)
-                 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
-                            "ubound") != 0)
-               DECL_NAME (ubound) = NULL_TREE;
-             DECL_IGNORED_P (ubound) = 0;
+             if (GFC_TYPE_ARRAY_LBOUND (type, dim)
+                 && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
+               DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
+             if (GFC_TYPE_ARRAY_UBOUND (type, dim)
+                 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
+               DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
             }
         }
        TYPE_NAME (type) = type_decl = build_decl (input_location,
             }
         }
        TYPE_NAME (type) = type_decl = build_decl (input_location,
@@ -1071,15 +1055,6 @@ gfc_get_symbol_decl (gfc_symbol * sym)
    else
      byref = 0;
  
    else
      byref = 0;
  
-  /* Make sure that the vtab for the declared type is completed.  */
-  if (sym->ts.type == BT_CLASS)
-    {
-      gfc_component *c = gfc_find_component (sym->ts.u.derived,
-                                            "$data", true, true);
-      if (!c->ts.u.derived->backend_decl)
-       gfc_find_derived_vtab (c->ts.u.derived, true);
-    }
-
    if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
      {
        /* Return via extra parameter.  */
    if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
      {
        /* Return via extra parameter.  */
@@ -2284,11 +2259,11 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
  
        if (!sym->attr.mixed_entry_master && sym->attr.function)
                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
  
        if (!sym->attr.mixed_entry_master && sym->attr.function)
-       decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
+       decl = build_decl (input_location,
                            VAR_DECL, get_identifier (name),
                            gfc_sym_type (sym));
        else
                            VAR_DECL, get_identifier (name),
                            gfc_sym_type (sym));
        else
-       decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
+       decl = build_decl (input_location,
                            VAR_DECL, get_identifier (name),
                            TREE_TYPE (TREE_TYPE (this_function_decl)));
        DECL_ARTIFICIAL (decl) = 1;
                            VAR_DECL, get_identifier (name),
                            TREE_TYPE (TREE_TYPE (this_function_decl)));
        DECL_ARTIFICIAL (decl) = 1;
@@ -2318,19 +2293,22 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
  /* Builds a function decl.  The remaining parameters are the types of the
     function arguments.  Negative nargs indicates a varargs function.  */
  
  /* Builds a function decl.  The remaining parameters are the types of the
     function arguments.  Negative nargs indicates a varargs function.  */
  
-static tree
-build_library_function_decl_1 (tree name, const char *spec,
-                              tree rettype, int nargs, va_list p)
+tree
+gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
  {
    tree arglist;
    tree argtype;
    tree fntype;
    tree fndecl;
  {
    tree arglist;
    tree argtype;
    tree fntype;
    tree fndecl;
+  va_list p;
    int n;
  
    /* Library functions must be declared with global scope.  */
    gcc_assert (current_function_decl == NULL_TREE);
  
    int n;
  
    /* Library functions must be declared with global scope.  */
    gcc_assert (current_function_decl == NULL_TREE);
  
+  va_start (p, nargs);
+
+
    /* Create a list of the argument types.  */
    for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
      {
    /* Create a list of the argument types.  */
    for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
      {
@@ -2346,14 +2324,6 @@ build_library_function_decl_1 (tree name, const char *spec,
  
    /* Build the function type and decl.  */
    fntype = build_function_type (rettype, arglist);
  
    /* Build the function type and decl.  */
    fntype = build_function_type (rettype, arglist);
-  if (spec)
-    {
-      tree attr_args = build_tree_list (NULL_TREE,
-                                       build_string (strlen (spec), spec));
-      tree attrs = tree_cons (get_identifier ("fn spec"),
-                             attr_args, TYPE_ATTRIBUTES (fntype));
-      fntype = build_type_attribute_variant (fntype, attrs);
-    }
    fndecl = build_decl (input_location,
                        FUNCTION_DECL, name, fntype);
  
    fndecl = build_decl (input_location,
                        FUNCTION_DECL, name, fntype);
  
@@ -2361,6 +2331,8 @@ build_library_function_decl_1 (tree name, const char *spec,
    DECL_EXTERNAL (fndecl) = 1;
    TREE_PUBLIC (fndecl) = 1;
  
    DECL_EXTERNAL (fndecl) = 1;
    TREE_PUBLIC (fndecl) = 1;
  
+  va_end (p);
+
    pushdecl (fndecl);
  
    rest_of_decl_compilation (fndecl, 1, 0);
    pushdecl (fndecl);
  
    rest_of_decl_compilation (fndecl, 1, 0);
@@ -2368,37 +2340,6 @@ build_library_function_decl_1 (tree name, const char *spec,
    return fndecl;
  }
  
    return fndecl;
  }
  
-/* Builds a function decl.  The remaining parameters are the types of the
-   function arguments.  Negative nargs indicates a varargs function.  */
-
-tree
-gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
-{
-  tree ret;
-  va_list args;
-  va_start (args, nargs);
-  ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
-  va_end (args);
-  return ret;
-}
-
-/* Builds a function decl.  The remaining parameters are the types of the
-   function arguments.  Negative nargs indicates a varargs function.
-   The SPEC parameter specifies the function argument and return type
-   specification according to the fnspec function type attribute.  */
-
-static tree
-gfc_build_library_function_decl_with_spec (tree name, const char *spec,
-                                          tree rettype, int nargs, ...)
-{
-  tree ret;
-  va_list args;
-  va_start (args, nargs);
-  ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
-  va_end (args);
-  return ret;
-}
-
  static void
  gfc_build_intrinsic_function_decls (void)
  {
  static void
  gfc_build_intrinsic_function_decls (void)
  {
@@ -2775,33 +2716,23 @@ gfc_build_builtin_function_decls (void)
    gfor_fndecl_stop_numeric =
      gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
                                      void_type_node, 1, gfc_int4_type_node);
    gfor_fndecl_stop_numeric =
      gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
                                      void_type_node, 1, gfc_int4_type_node);
-  /* STOP doesn't return.  */
+  /* Stop doesn't return.  */
    TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
  
    TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
  
-
    gfor_fndecl_stop_string =
      gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
                                      void_type_node, 2, pchar_type_node,
    gfor_fndecl_stop_string =
      gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
                                      void_type_node, 2, pchar_type_node,
-                                    gfc_int4_type_node);
-  /* STOP doesn't return.  */
+                                     gfc_int4_type_node);
+  /* Stop doesn't return.  */
    TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
  
    TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
  
-
-  gfor_fndecl_error_stop_numeric =
-    gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_numeric")),
-                                    void_type_node, 1, gfc_int4_type_node);
-  /* ERROR STOP doesn't return.  */
-  TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
-
-
    gfor_fndecl_error_stop_string =
      gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
                                      void_type_node, 2, pchar_type_node,
    gfor_fndecl_error_stop_string =
      gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
                                      void_type_node, 2, pchar_type_node,
-                                    gfc_int4_type_node);
+                                     gfc_int4_type_node);
    /* ERROR STOP doesn't return.  */
    TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
  
    /* ERROR STOP doesn't return.  */
    TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
  
-
    gfor_fndecl_pause_numeric =
      gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
                                      void_type_node, 1, gfc_int4_type_node);
    gfor_fndecl_pause_numeric =
      gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
                                      void_type_node, 1, gfc_int4_type_node);
@@ -2809,7 +2740,7 @@ gfc_build_builtin_function_decls (void)
    gfor_fndecl_pause_string =
      gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
                                      void_type_node, 2, pchar_type_node,
    gfor_fndecl_pause_string =
      gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
                                      void_type_node, 2, pchar_type_node,
-                                    gfc_int4_type_node);
+                                     gfc_int4_type_node);
  
    gfor_fndecl_runtime_error =
      gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
  
    gfor_fndecl_runtime_error =
      gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
@@ -2866,12 +2797,12 @@ gfc_build_builtin_function_decls (void)
      gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
                                      void_type_node, 1, integer_type_node);
  
      gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
                                      void_type_node, 1, integer_type_node);
  
-  gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
-        get_identifier (PREFIX("internal_pack")), ".r",
+  gfor_fndecl_in_pack = gfc_build_library_function_decl (
+        get_identifier (PREFIX("internal_pack")),
          pvoid_type_node, 1, pvoid_type_node);
  
          pvoid_type_node, 1, pvoid_type_node);
  
-  gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
-        get_identifier (PREFIX("internal_unpack")), ".wR",
+  gfor_fndecl_in_unpack = gfc_build_library_function_decl (
+        get_identifier (PREFIX("internal_unpack")),
          void_type_node, 2, pvoid_type_node, pvoid_type_node);
  
    gfor_fndecl_associated =
          void_type_node, 2, pvoid_type_node, pvoid_type_node);
  
    gfor_fndecl_associated =
@@ -3270,6 +3201,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
           if (sym_has_alloc_comp && !seen_trans_deferred_array)
             fnbody = gfc_trans_deferred_array (sym, fnbody);
         }
           if (sym_has_alloc_comp && !seen_trans_deferred_array)
             fnbody = gfc_trans_deferred_array (sym, fnbody);
         }
+      else if (sym_has_alloc_comp)
+       fnbody = gfc_trans_deferred_array (sym, fnbody);
        else if (sym->attr.allocatable
                || (sym->ts.type == BT_CLASS
                    && sym->ts.u.derived->components->attr.allocatable))
        else if (sym->attr.allocatable
                || (sym->ts.type == BT_CLASS
                    && sym->ts.u.derived->components->attr.allocatable))
@@ -3307,8 +3240,6 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
               fnbody = gfc_finish_block (&block);
             }
         }
               fnbody = gfc_finish_block (&block);
             }
         }
-      else if (sym_has_alloc_comp)
-       fnbody = gfc_trans_deferred_array (sym, fnbody);
        else if (sym->ts.type == BT_CHARACTER)
         {
           gfc_get_backend_locus (&loc);
        else if (sym->ts.type == BT_CHARACTER)
         {
           gfc_get_backend_locus (&loc);
@@ -3531,8 +3462,7 @@ gfc_create_module_variable (gfc_symbol * sym)
        tree length;
  
        length = sym->ts.u.cl->backend_decl;
        tree length;
  
        length = sym->ts.u.cl->backend_decl;
-      gcc_assert (length || sym->attr.proc_pointer);
-      if (length && !INTEGER_CST_P (length))
+      if (!INTEGER_CST_P (length))
          {
            pushdecl (length);
            rest_of_decl_compilation (length, 1, 0);
          {
            pushdecl (length);
            rest_of_decl_compilation (length, 1, 0);
@@ -3648,8 +3578,7 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
         return check_constant_initializer (expr, ts, false, false);
        else if (expr->expr_type != EXPR_ARRAY)
         return false;
         return check_constant_initializer (expr, ts, false, false);
        else if (expr->expr_type != EXPR_ARRAY)
         return false;
-      for (c = gfc_constructor_first (expr->value.constructor);
-          c; c = gfc_constructor_next (c))
+      for (c = expr->value.constructor; c; c = c->next)
         {
           if (c->iterator)
             return false;
         {
           if (c->iterator)
             return false;
@@ -3669,8 +3598,7 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
        if (expr->expr_type != EXPR_STRUCTURE)
         return false;
        cm = expr->ts.u.derived->components;
        if (expr->expr_type != EXPR_STRUCTURE)
         return false;
        cm = expr->ts.u.derived->components;
-      for (c = gfc_constructor_first (expr->value.constructor);
-          c; c = gfc_constructor_next (c), cm = cm->next)
+      for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
         {
           if (!c->expr || cm->attr.allocatable)
             continue;
         {
           if (!c->expr || cm->attr.allocatable)
             continue;
@@ -3878,29 +3806,20 @@ generate_local_decl (gfc_symbol * sym)
  
        if (sym->attr.referenced)
         gfc_get_symbol_decl (sym);
  
        if (sym->attr.referenced)
         gfc_get_symbol_decl (sym);
-
-      /* Warnings for unused dummy arguments.  */
-      else if (sym->attr.dummy)
+      /* INTENT(out) dummy arguments are likely meant to be set.  */
+      else if (warn_unused_variable
+              && sym->attr.dummy
+              && sym->attr.intent == INTENT_OUT)
         {
         {
-         /* INTENT(out) dummy arguments are likely meant to be set.  */
-         if (gfc_option.warn_unused_dummy_argument
-             && sym->attr.intent == INTENT_OUT)
-           {
-             if (sym->ts.type != BT_DERIVED)
-               gfc_warning ("Dummy argument '%s' at %L was declared "
-                            "INTENT(OUT) but was not set",  sym->name,
-                            &sym->declared_at);
-             else if (!gfc_has_default_initializer (sym->ts.u.derived))
-               gfc_warning ("Derived-type dummy argument '%s' at %L was "
-                            "declared INTENT(OUT) but was not set and "
-                            "does not have a default initializer",
-                            sym->name, &sym->declared_at);
-           }
-         else if (gfc_option.warn_unused_dummy_argument)
-           gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
-                        &sym->declared_at);
+         if (!(sym->ts.type == BT_DERIVED
+               && sym->ts.u.derived->components->initializer))
+           gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
+                        "but was not set",  sym->name, &sym->declared_at);
         }
         }
-
+      /* Specific warning for unused dummy arguments. */
+      else if (warn_unused_variable && sym->attr.dummy)
+       gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
+                    &sym->declared_at);
        /* Warn for unused variables, but not if they're inside a common
          block or are use-associated.  */
        else if (warn_unused_variable
        /* Warn for unused variables, but not if they're inside a common
          block or are use-associated.  */
        else if (warn_unused_variable
@@ -4216,7 +4135,6 @@ create_main_function (tree fndecl)
       language standard parameters.  */
    {
      tree array_type, array, var;
       language standard parameters.  */
    {
      tree array_type, array, var;
-    VEC(constructor_elt,gc) *v = NULL;
  
      /* Passing a new option to the library requires four modifications:
       + add it to the tree_cons list below
  
      /* Passing a new option to the library requires four modifications:
       + add it to the tree_cons list below
@@ -4225,34 +4143,28 @@ create_main_function (tree fndecl)
              gfor_fndecl_set_options
            + modify the library (runtime/compile_options.c)!  */
  
              gfor_fndecl_set_options
            + modify the library (runtime/compile_options.c)!  */
  
-    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
-                            build_int_cst (integer_type_node,
-                                           gfc_option.warn_std));
-    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
-                            build_int_cst (integer_type_node,
-                                           gfc_option.allow_std));
-    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
-                            build_int_cst (integer_type_node, pedantic));
-    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
-                            build_int_cst (integer_type_node,
-                                           gfc_option.flag_dump_core));
-    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
-                            build_int_cst (integer_type_node,
-                                           gfc_option.flag_backtrace));
-    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
-                            build_int_cst (integer_type_node,
-                                           gfc_option.flag_sign_zero));
-    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
-                            build_int_cst (integer_type_node,
-                                           (gfc_option.rtcheck
-                                            & GFC_RTCHECK_BOUNDS)));
-    CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
-                            build_int_cst (integer_type_node,
-                                           gfc_option.flag_range_check));
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                      gfc_option.warn_std), NULL_TREE);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                      gfc_option.allow_std), array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
+                      array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                      gfc_option.flag_dump_core), array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                      gfc_option.flag_backtrace), array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                      gfc_option.flag_sign_zero), array);
+
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                      (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
+
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                      gfc_option.flag_range_check), array);
  
      array_type = build_array_type (integer_type_node,
                        build_index_type (build_int_cst (NULL_TREE, 7)));
  
      array_type = build_array_type (integer_type_node,
                        build_index_type (build_int_cst (NULL_TREE, 7)));
-    array = build_constructor (array_type, v);
+    array = build_constructor_from_list (array_type, nreverse (array));
      TREE_CONSTANT (array) = 1;
      TREE_STATIC (array) = 1;
  
      TREE_CONSTANT (array) = 1;
      TREE_STATIC (array) = 1;
  
@@ -4653,7 +4565,8 @@ gfc_generate_constructors (void)
      return;
  
    fnname = get_file_function_name ("I");
      return;
  
    fnname = get_file_function_name ("I");
-  type = build_function_type_list (void_type_node, NULL_TREE);
+  type = build_function_type (void_type_node,
+                             gfc_chainon_list (NULL_TREE, void_type_node));
  
    fndecl = build_decl (input_location,
                        FUNCTION_DECL, fnname, type);
  
    fndecl = build_decl (input_location,
                        FUNCTION_DECL, fnname, type);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c

index e0fa371..0b215f2 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -25,7 +25,10 @@ along with GCC; see the file COPYING3.  If not see
  #include "system.h"
  #include "coretypes.h"
  #include "tree.h"
  #include "system.h"
  #include "coretypes.h"
  #include "tree.h"
+#include "gimple.h"
+#include "ggc.h"
  #include "toplev.h"
  #include "toplev.h"
+#include "real.h"
  #include "gfortran.h"
  #include "flags.h"
  #include "trans.h"
  #include "gfortran.h"
  #include "flags.h"
  #include "trans.h"
@@ -549,17 +552,9 @@ gfc_trans_pause (gfc_code * code)
  
    if (code->expr1 == NULL)
      {
  
    if (code->expr1 == NULL)
      {
-      tmp = build_int_cst (gfc_int4_type_node, 0);
+      tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
        tmp = build_call_expr_loc (input_location,
        tmp = build_call_expr_loc (input_location,
-                                gfor_fndecl_pause_string, 2,
-                                build_int_cst (pchar_type_node, 0), tmp);
-    }
-  else if (code->expr1->ts.type == BT_INTEGER)
-    {
-      gfc_conv_expr (&se, code->expr1);
-      tmp = build_call_expr_loc (input_location,
-                                gfor_fndecl_pause_numeric, 1,
-                                fold_convert (gfc_int4_type_node, se.expr));
+                            gfor_fndecl_pause_numeric, 1, tmp);
      }
    else
      {
      }
    else
      {
@@ -593,27 +588,17 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
  
    if (code->expr1 == NULL)
      {
  
    if (code->expr1 == NULL)
      {
-      tmp = build_int_cst (gfc_int4_type_node, 0);
+      tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
        tmp = build_call_expr_loc (input_location,
        tmp = build_call_expr_loc (input_location,
-                                error_stop ? gfor_fndecl_error_stop_string
-                                : gfor_fndecl_stop_string,
-                                2, build_int_cst (pchar_type_node, 0), tmp);
-    }
-  else if (code->expr1->ts.type == BT_INTEGER)
-    {
-      gfc_conv_expr (&se, code->expr1);
-      tmp = build_call_expr_loc (input_location,
-                                error_stop ? gfor_fndecl_error_stop_numeric
-                                : gfor_fndecl_stop_numeric, 1,
-                                fold_convert (gfc_int4_type_node, se.expr));
+                            gfor_fndecl_stop_numeric, 1, tmp);
      }
    else
      {
        gfc_conv_expr_reference (&se, code->expr1);
        tmp = build_call_expr_loc (input_location,
      }
    else
      {
        gfc_conv_expr_reference (&se, code->expr1);
        tmp = build_call_expr_loc (input_location,
-                                error_stop ? gfor_fndecl_error_stop_string
-                                : gfor_fndecl_stop_string,
-                                2, se.expr, se.string_length);
+                            error_stop ? gfor_fndecl_error_stop_string
+                                     : gfor_fndecl_stop_string,
+                            2, se.expr, se.string_length);
      }
  
    gfc_add_expr_to_block (&se.pre, tmp);
      }
  
    gfc_add_expr_to_block (&se.pre, tmp);
@@ -1608,13 +1593,12 @@ gfc_trans_logical_select (gfc_code * code)
  static tree
  gfc_trans_character_select (gfc_code *code)
  {
  static tree
  gfc_trans_character_select (gfc_code *code)
  {
-  tree init, end_label, tmp, type, case_num, label, fndecl;
+  tree init, node, end_label, tmp, type, case_num, label, fndecl;
    stmtblock_t block, body;
    gfc_case *cp, *d;
    gfc_code *c;
    gfc_se se;
    int n, k;
    stmtblock_t block, body;
    gfc_case *cp, *d;
    gfc_code *c;
    gfc_se se;
    int n, k;
-  VEC(constructor_elt,gc) *inits = NULL;
  
    /* The jump table types are stored in static variables to avoid
       constructing them from scratch every single time.  */
  
    /* The jump table types are stored in static variables to avoid
       constructing them from scratch every single time.  */
@@ -1694,50 +1678,52 @@ gfc_trans_character_select (gfc_code *code)
      }
  
    /* Generate the structure describing the branches */
      }
  
    /* Generate the structure describing the branches */
+  init = NULL_TREE;
+
    for(d = cp; d; d = d->right)
      {
    for(d = cp; d; d = d->right)
      {
-      VEC(constructor_elt,gc) *node = NULL;
+      node = NULL_TREE;
  
        gfc_init_se (&se, NULL);
  
        if (d->low == NULL)
          {
  
        gfc_init_se (&se, NULL);
  
        if (d->low == NULL)
          {
-          CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
-          CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
+          node = tree_cons (ss_string1[k], null_pointer_node, node);
+          node = tree_cons (ss_string1_len[k], integer_zero_node, node);
          }
        else
          {
            gfc_conv_expr_reference (&se, d->low);
  
          }
        else
          {
            gfc_conv_expr_reference (&se, d->low);
  
-          CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
-          CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
+          node = tree_cons (ss_string1[k], se.expr, node);
+          node = tree_cons (ss_string1_len[k], se.string_length, node);
          }
  
        if (d->high == NULL)
          {
          }
  
        if (d->high == NULL)
          {
-          CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
-          CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
+          node = tree_cons (ss_string2[k], null_pointer_node, node);
+          node = tree_cons (ss_string2_len[k], integer_zero_node, node);
          }
        else
          {
            gfc_init_se (&se, NULL);
            gfc_conv_expr_reference (&se, d->high);
  
          }
        else
          {
            gfc_init_se (&se, NULL);
            gfc_conv_expr_reference (&se, d->high);
  
-          CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
-          CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
+          node = tree_cons (ss_string2[k], se.expr, node);
+          node = tree_cons (ss_string2_len[k], se.string_length, node);
          }
  
          }
  
-      CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
-                              build_int_cst (integer_type_node, d->n));
+      node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n),
+                       node);
  
  
-      tmp = build_constructor (select_struct[k], node);
-      CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
+      tmp = build_constructor_from_list (select_struct[k], nreverse (node));
+      init = tree_cons (NULL_TREE, tmp, init);
      }
  
    type = build_array_type (select_struct[k],
                            build_index_type (build_int_cst (NULL_TREE, n-1)));
  
      }
  
    type = build_array_type (select_struct[k],
                            build_index_type (build_int_cst (NULL_TREE, n-1)));
  
-  init = build_constructor (type, inits);
+  init = build_constructor_from_list (type, nreverse(init));
    TREE_CONSTANT (init) = 1;
    TREE_STATIC (init) = 1;
    /* Create a static variable to hold the jump table.  */
    TREE_CONSTANT (init) = 1;
    TREE_STATIC (init) = 1;
    /* Create a static variable to hold the jump table.  */
@@ -2836,7 +2822,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
  
        /* Make a new descriptor.  */
        parmtype = gfc_get_element_type (TREE_TYPE (desc));
  
        /* Make a new descriptor.  */
        parmtype = gfc_get_element_type (TREE_TYPE (desc));
-      parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
+      parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
                                              loop.from, loop.to, 1,
                                             GFC_ARRAY_UNKNOWN, true);
  
                                              loop.from, loop.to, 1,
                                             GFC_ARRAY_UNKNOWN, true);
  
@@ -4292,9 +4278,8 @@ gfc_trans_allocate (gfc_code * code)
  
               if (ts->type == BT_DERIVED)
                 {
  
               if (ts->type == BT_DERIVED)
                 {
-                 vtab = gfc_find_derived_vtab (ts->u.derived, true);
+                 vtab = gfc_find_derived_vtab (ts->u.derived);
                   gcc_assert (vtab);
                   gcc_assert (vtab);
-                 gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab);
                   gfc_init_se (&lse, NULL);
                   lse.want_pointer = 1;
                   gfc_conv_expr (&lse, lhs);
                   gfc_init_se (&lse, NULL);
                   lse.want_pointer = 1;
                   gfc_conv_expr (&lse, lhs);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h

index 9ee8148..fe34f69 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -126,9 +126,8 @@ typedef enum
       scalarization loop.  */
    GFC_SS_SCALAR,
  
       scalarization loop.  */
    GFC_SS_SCALAR,
  
-  /* Like GFC_SS_SCALAR it evaluates the expression outside the
-     loop. Is always evaluated as a reference to the temporary.
-     Used for elemental function arguments.  */
+  /* Like GFC_SS_SCALAR except it evaluates a pointer to the expression.
+     Used for elemental function parameters.  */
    GFC_SS_REFERENCE,
  
    /* An array section.  Scalarization indices will be substituted during
    GFC_SS_REFERENCE,
  
    /* An array section.  Scalarization indices will be substituted during
@@ -451,7 +450,7 @@ extern GTY(()) tree gfc_static_ctors;
  void gfc_generate_constructors (void);
  
  /* Get the string length of an array constructor.  */
  void gfc_generate_constructors (void);
  
  /* Get the string length of an array constructor.  */
-bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
+bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *);
  
  /* Generate a runtime error call.  */
  tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
  
  /* Generate a runtime error call.  */
  tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
@@ -492,9 +491,6 @@ tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
  /* Generate code for a pointer assignment.  */
  tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
  
  /* Generate code for a pointer assignment.  */
  tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
  
-/* Generate code to assign typebound procedures to a derived vtab.  */
-void gfc_trans_assign_vtab_procs (stmtblock_t*, gfc_symbol*, gfc_symbol*);
-
  /* Initialize function decls for library functions.  */
  void gfc_build_intrinsic_lib_fndecls (void);
  /* Create function decls for IO library functions.  */
  /* Initialize function decls for library functions.  */
  void gfc_build_intrinsic_lib_fndecls (void);
  /* Create function decls for IO library functions.  */
@@ -538,7 +534,6 @@ extern GTY(()) tree gfor_fndecl_pause_numeric;
  extern GTY(()) tree gfor_fndecl_pause_string;
  extern GTY(()) tree gfor_fndecl_stop_numeric;
  extern GTY(()) tree gfor_fndecl_stop_string;
  extern GTY(()) tree gfor_fndecl_pause_string;
  extern GTY(()) tree gfor_fndecl_stop_numeric;
  extern GTY(()) tree gfor_fndecl_stop_string;
-extern GTY(()) tree gfor_fndecl_error_stop_numeric;
  extern GTY(()) tree gfor_fndecl_error_stop_string;
  extern GTY(()) tree gfor_fndecl_runtime_error;
  extern GTY(()) tree gfor_fndecl_runtime_error_at;
  extern GTY(()) tree gfor_fndecl_error_stop_string;
  extern GTY(()) tree gfor_fndecl_runtime_error;
  extern GTY(()) tree gfor_fndecl_runtime_error_at;
@@ -778,6 +773,7 @@ void gfc_apply_interface_mapping (gfc_interface_mapping *,
  
  
  /* Standard error messages used in all the trans-*.c files.  */
  
  
  /* Standard error messages used in all the trans-*.c files.  */
+extern const char gfc_msg_bounds[];
  extern const char gfc_msg_fault[];
  extern const char gfc_msg_wrong_return[];
  
  extern const char gfc_msg_fault[];
  extern const char gfc_msg_wrong_return[];
  
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog

index 66018c5..a65ba45 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/39997
+       * gfortran.dg/coarray_1.f90: New test.
+       * gfortran.dg/coarray_2.f90: New test.
+       * gfortran.dg/coarray_3.f90: New test.
+
  2010-04-06  Jason Merrill  <jason@redhat.com>
  
         PR c++/43648
  2010-04-06  Jason Merrill  <jason@redhat.com>
  
         PR c++/43648
diff --git a/gcc/testsuite/gfortran.dg/coarray_1.f90 b/gcc/testsuite/gfortran.dg/coarray_1.f90

index 7fd4c84..ba10d64 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_1.f90
@@ -13,6 +13,6 @@ sync memory  ! { dg-error "Fortran 2008:" }
  sync images(*)  ! { dg-error "Fortran 2008:" }
  
  ! num_images is implicitly defined:
  sync images(*)  ! { dg-error "Fortran 2008:" }
  
  ! num_images is implicitly defined:
-n = num_images()  ! { dg-error "has no IMPLICIT type" }
+n = num_images()  ! { dg-error "convert UNKNOWN to INTEGER" }
  error stop 'stop'  ! { dg-error "Fortran 2008:" }
  end
  error stop 'stop'  ! { dg-error "Fortran 2008:" }
  end
diff --git a/gcc/testsuite/gfortran.dg/coarray_2.f90 b/gcc/testsuite/gfortran.dg/coarray_2.f90

index 902a0dd..1fcb9b8 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_2.f90
@@ -1,5 +1,4 @@
  ! { dg-do run }
  ! { dg-do run }
-! { dg-options "-fcoarray=single" }
  ! { dg-shouldfail "error stop" }
  ! 
  ! Coarray support
  ! { dg-shouldfail "error stop" }
  ! 
  ! Coarray support
diff --git a/gcc/testsuite/gfortran.dg/coarray_3.f90 b/gcc/testsuite/gfortran.dg/coarray_3.f90

index 63c3bd3..648f2fa 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray_3.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_3.f90
@@ -1,5 +1,4 @@
  ! { dg-do compile }
  ! { dg-do compile }
-! { dg-options "-fcoarray=single" }
  ! 
  ! Coarray support
  ! PR fortran/18918
  ! 
  ! Coarray support
  ! PR fortran/18918
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog

index 70700a3..78c6b04 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,9 @@
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/39997
+       * runtime/stop.c (error_stop_string): New function.
+       * gfortran.map (_gfortran_error_stop_string): Add.
+
  2010-04-02  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
  
         * Makefile.in: Regenerate.
  2010-04-02  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
  
         * Makefile.in: Regenerate.
@@ -7,7 +13,7 @@
  
         PR libfortran/43605
         * io/intrinsics.c (gf_ftell): New function, seek to correct offset.
  
         PR libfortran/43605
         * io/intrinsics.c (gf_ftell): New function, seek to correct offset.
-        (ftell): Call gf_ftell.
+       (ftell): Call gf_ftell.
         (FTELL_SUB): Likewise.
  
  2010-04-01  Paul Thomas  <pault@gcc.gnu.org>
         (FTELL_SUB): Likewise.
  
  2010-04-01  Paul Thomas  <pault@gcc.gnu.org>
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map

index 3e854eb..bcca957 100644 (file)
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -1103,11 +1103,6 @@ GFORTRAN_1.3 {
      _gfortran_error_stop_string;
  } GFORTRAN_1.2; 
  
      _gfortran_error_stop_string;
  } GFORTRAN_1.2; 
  
-GFORTRAN_1.4 {
-  global:
-    _gfortran_error_stop_numeric;
-} GFORTRAN_1.3; 
-
  F2C_1.0 {
    global:
      _gfortran_f2c_specific__abs_c4;
  F2C_1.0 {
    global:
      _gfortran_f2c_specific__abs_c4;
diff --git a/libgfortran/runtime/stop.c b/libgfortran/runtime/stop.c

index f2a1233..e154c20 100644 (file)
--- a/libgfortran/runtime/stop.c
+++ b/libgfortran/runtime/stop.c
@@ -87,3 +87,22 @@ error_stop_numeric (GFC_INTEGER_4 code)
    st_printf ("ERROR STOP %d\n", (int) code);
    sys_exit (code);
  }
    st_printf ("ERROR STOP %d\n", (int) code);
    sys_exit (code);
  }
+
+extern void error_stop_string (const char *, GFC_INTEGER_4);
+export_proto(error_stop_string);
+
+
+/* Per Fortran 2008, section 8.4:  "Execution of a STOP statement initiates
+   normal termination of execution. Execution of an ERROR STOP statement
+   initiates error termination of execution."  Thus, error_stop_string returns
+   a nonzero exit status code.  */
+void
+error_stop_string (const char *string, GFC_INTEGER_4 len)
+{
+  st_printf ("ERROR STOP ");
+  while (len--)
+    st_printf ("%c", *(string++));
+  st_printf ("\n");
+
+  sys_exit (1);
+}
author	burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
	Tue, 6 Apr 2010 16:26:02 +0000 (16:26 +0000)
committer	Masaki Muranaka <monaka@monami-software.com>
	Sun, 23 May 2010 00:46:06 +0000 (09:46 +0900)
gcc/fortran/ChangeLog		patch \| blob \| history
gcc/fortran/intrinsic.texi		patch \| blob \| history
gcc/fortran/match.c		patch \| blob \| history
gcc/fortran/resolve.c		patch \| blob \| history
gcc/fortran/simplify.c		patch \| blob \| history
gcc/fortran/trans-decl.c		patch \| blob \| history
gcc/fortran/trans-stmt.c		patch \| blob \| history
gcc/fortran/trans.h		patch \| blob \| history
gcc/testsuite/ChangeLog		patch \| blob \| history
gcc/testsuite/gfortran.dg/coarray_1.f90		patch \| blob \| history
gcc/testsuite/gfortran.dg/coarray_2.f90		patch \| blob \| history
gcc/testsuite/gfortran.dg/coarray_3.f90		patch \| blob \| history
libgfortran/ChangeLog		patch \| blob \| history
libgfortran/gfortran.map		patch \| blob \| history
libgfortran/runtime/stop.c		patch \| blob \| history