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.
* @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{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{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{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{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{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{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
@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
@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}:
@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
@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
@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}:
-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}:
-@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 @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
-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{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 @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 @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 @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
@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
@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 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{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
@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 @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
@end smallexample
@item @emph{See also}:
-@ref{REAL}
+@ref{DFLOAT}, @ref{FLOAT}, @ref{REAL}
@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
@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
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
+
@node DREAL
@section @code{DREAL} --- Double real part function
@fnindex DREAL
@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
+@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
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
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{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
+
@node INT2
@section @code{INT2} --- Convert to 16-bit integer type
@fnindex INT2
-@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
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
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
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
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
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
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{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}:
@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}:
@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 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 smallexample
@item @emph{See also}:
-@ref{THIS_IMAGE}, @ref{IMAGE_INDEX}
+@c FIXME: ref{THIS_IMAGE}
@end table
@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
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}:
-@ref{DBLE}
+@ref{DBLE}, @ref{DFLOAT}, @ref{FLOAT}
@end table
@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
@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}:
@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
+@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
@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 @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}:
@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
-@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
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
@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
-@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.
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
-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
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.
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
-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
/* 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
locus start;
match m;
- e1 = e2 = e3 = NULL;
-
/* Match the start of an iterator without affecting the symbol table. */
start = gfc_current_locus;
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)
{
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);
if (gfc_match_char (',') != MATCH_YES)
{
- e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+ e3 = gfc_int_expr (1);
goto done;
}
== 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_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;
}
static match
gfc_match_stopcode (gfc_statement st)
{
+ int stop_code;
gfc_expr *e;
match m;
+ int cnt;
+ stop_code = -1;
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_YES && cnt > 5)
+ {
+ gfc_error ("Too many digits in STOP code at %C");
+ goto cleanup;
+ }
+
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;
}
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
-
if (gfc_pure (NULL))
{
gfc_error ("%s statement not allowed in PURE procedure at %C",
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)
}
new_st.expr1 = e;
- new_st.ext.stop_code = -1;
+ new_st.ext.stop_code = stop_code;
return MATCH_YES;
== 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");
}
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;
}
/* 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)
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 ();
/* 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 (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;
}
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;
}
{
m = gfc_match (" %e ", &expr1);
if (m != MATCH_YES)
- goto cleanup;
+ return m;
}
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=>");
- 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;
select_type_push (expr1->symtree->n.sym);
return MATCH_YES;
-
-cleanup:
- gfc_current_ns = gfc_current_ns->parent;
- return m;
}
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);
}
}
+
+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. */
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)
- 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)
{
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
+ case EXEC_CRITICAL:
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
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_CRITICAL:
+ break;
+
+ case EXEC_SYNC_ALL:
+ case EXEC_SYNC_IMAGES:
+ case EXEC_SYNC_MEMORY:
+ resolve_sync (code);
break;
case EXEC_ENTRY:
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;
#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 "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 "debug.h"
#include "gfortran.h"
#include "pointer-set.h"
-#include "constructor.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-array.h"
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;
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);
- /* 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,
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. */
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
- 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;
/* 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;
+ va_list p;
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--)
{
/* 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);
DECL_EXTERNAL (fndecl) = 1;
TREE_PUBLIC (fndecl) = 1;
+ va_end (p);
+
pushdecl (fndecl);
rest_of_decl_compilation (fndecl, 1, 0);
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)
{
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;
-
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;
-
- 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,
- gfc_int4_type_node);
+ gfc_int4_type_node);
/* 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_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")),
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);
- 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 =
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))
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);
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);
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 (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 (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
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
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 = build_constructor (array_type, v);
+ array = build_constructor_from_list (array_type, nreverse (array));
TREE_CONSTANT (array) = 1;
TREE_STATIC (array) = 1;
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);
#include "system.h"
#include "coretypes.h"
#include "tree.h"
+#include "gimple.h"
+#include "ggc.h"
#include "toplev.h"
+#include "real.h"
#include "gfortran.h"
#include "flags.h"
#include "trans.h"
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,
- 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
{
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,
- 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,
- 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);
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;
- VEC(constructor_elt,gc) *inits = NULL;
/* The jump table types are stored in static variables to avoid
constructing them from scratch every single time. */
}
/* Generate the structure describing the branches */
+ init = NULL_TREE;
+
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)
{
- 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);
- 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)
{
- 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);
- 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)));
- 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. */
/* 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);
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);
- gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, lhs);
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
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 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. */
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;
/* 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[];
+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
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
! { dg-do run }
-! { dg-options "-fcoarray=single" }
! { dg-shouldfail "error stop" }
!
! Coarray support
! { dg-do compile }
-! { dg-options "-fcoarray=single" }
!
! Coarray support
! PR fortran/18918
+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.
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>
_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;
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);
+}