* primary.c (match_boz_constant): Allow kind parameter suffixes.
Move standard warning further to the front.
testsuite/
* gfortran.fortran-torture/execute/intrinsic_mvbits.f90,
gfortran.dg/ishft.f90: Add more tests.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@88690
138bc75d-0d04-0410-961f-
82ee72b054a4
+2004-10-07 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
+
+ * primary.c (match_boz_constant): Allow kind parameter suffixes.
+ Move standard warning further to the front.
+
2004-10-07 Kazu Hirata <kazu@cs.umass.edu>
* trans-stmt.c: Fix a comment typo.
2004-10-07 Kazu Hirata <kazu@cs.umass.edu>
* trans-stmt.c: Fix a comment typo.
static match
match_boz_constant (gfc_expr ** result)
{
static match
match_boz_constant (gfc_expr ** result)
{
- int radix, delim, length, x_hex;
+ int radix, delim, length, x_hex, kind;
locus old_loc;
char *buffer;
gfc_expr *e;
locus old_loc;
char *buffer;
gfc_expr *e;
if (delim != '\'' && delim != '\"')
goto backup;
if (delim != '\'' && delim != '\"')
goto backup;
+ if (x_hex && pedantic
+ && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
+ "constant at %C uses non-standard syntax.")
+ == FAILURE))
+ return MATCH_ERROR;
+
old_loc = gfc_current_locus;
length = match_digits (0, radix, NULL);
old_loc = gfc_current_locus;
length = match_digits (0, radix, NULL);
memset (buffer, '\0', length + 1);
match_digits (0, radix, buffer);
memset (buffer, '\0', length + 1);
match_digits (0, radix, buffer);
+ gfc_next_char (); /* Eat delimiter. */
+
+ kind = get_kind ();
+ if (kind == -1)
+ return MATCH_ERROR;
+ if (kind == -2)
+ kind = gfc_default_integer_kind;
+ else if (pedantic
+ && (gfc_notify_std (GFC_STD_GNU, "Extension: Kind parameter "
+ "suffix to boz literal constant at %C.")
+ == FAILURE))
+ return MATCH_ERROR;
- e = gfc_convert_integer (buffer, gfc_default_integer_kind, radix,
- &gfc_current_locus);
+ e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
if (gfc_range_check (e) != ARITH_OK)
{
if (gfc_range_check (e) != ARITH_OK)
{
- gfc_error ("Integer too big for default integer kind at %C");
-
- gfc_free_expr (e);
- return MATCH_ERROR;
- }
+ gfc_error ("Integer too big for integer kind %i at %C", kind);
- if (x_hex
- && pedantic
- && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
- "constant at %C uses non-standard syntax.")
- == FAILURE))
- {
gfc_free_expr (e);
return MATCH_ERROR;
}
gfc_free_expr (e);
return MATCH_ERROR;
}
+2004-10-07 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
+
+ * gfortran.fortran-torture/execute/intrinsic_mvbits.f90,
+ gfortran.dg/ishft.f90: Add more tests.
+
2004-10-07 Andrew Pinski <pinskia@physics.uc.edu>
* g++.dg/ext/asm6.C: Remove extraneous semicolon.
2004-10-07 Andrew Pinski <pinskia@physics.uc.edu>
* g++.dg/ext/asm6.C: Remove extraneous semicolon.
if (ishft (3_1, 1) /= 6) call abort
if (ishft (-1_1, 1) /= -2) call abort
if (ishft (-1_1, -1) /= 127) call abort
if (ishft (3_1, 1) /= 6) call abort
if (ishft (-1_1, 1) /= -2) call abort
if (ishft (-1_1, -1) /= 127) call abort
-if (ishft (96_1, 2) /= -128_2) call abort
+if (ishft (96_1, 2) /= -128) call abort
if (ishft (1_2, 0) /= 1) call abort
if (ishft (1_2, 1) /= 2) call abort
if (ishft (1_2, 0) /= 1) call abort
if (ishft (1_2, 1) /= 2) call abort
if (ishft (-1_4, -1) /= 2147483647) call abort
if (ishft (1073741824_4 + 536870912_4, 2) /= -2147483648_8) call abort
if (ishft (-1_4, -1) /= 2147483647) call abort
if (ishft (1073741824_4 + 536870912_4, 2) /= -2147483648_8) call abort
+if (ishft (1_8, 0) /= 1) call abort
+if (ishft (1_8, 1) /= 2) call abort
+if (ishft (3_8, 1) /= 6) call abort
+if (ishft (-1_8, 1) /= -2) call abort
+if (ishft (-1_8, -60) /= z'F'_8) call abort
+
if (ishftc (1_1, 0) /= 1) call abort
if (ishftc (1_1, 1) /= 2) call abort
if (ishftc (3_1, 1) /= 6) call abort
if (ishftc (1_1, 0) /= 1) call abort
if (ishftc (1_1, 1) /= 2) call abort
if (ishftc (3_1, 1) /= 6) call abort
if (ishftc (-1_4, 1) /= -1) call abort
if (ishftc (-1_4, -1) /= -1) call abort
if (ishftc (ishftc (1325876_4, 2), -2) /= 1325876) call abort
if (ishftc (-1_4, 1) /= -1) call abort
if (ishftc (-1_4, -1) /= -1) call abort
if (ishftc (ishftc (1325876_4, 2), -2) /= 1325876) call abort
+
+if (ishftc (1_8, 0) /= 1) call abort
+if (ishftc (1_8, 1) /= 2) call abort
+if (ishftc (3_8, 1) /= 6) call abort
+if (ishftc (-1_8, 1) /= -1) call abort
+if (ishftc (-1_8, -1) /= -1) call abort
+if (ishftc (ishftc (1325876_8, 2), -2) /= 1325876) call abort
! Test the MVBITS intrinsic subroutine
INTEGER*4 :: from, to, result
! Test the MVBITS intrinsic subroutine
INTEGER*4 :: from, to, result
DATA from / z'0003FFFC' /
DATA to / z'77760000' /
DATA from / z'0003FFFC' /
DATA to / z'77760000' /
CALL mvbits(from, 2, 16, to, 1)
if (to /= result) CALL abort()
CALL mvbits(from, 2, 16, to, 1)
if (to /= result) CALL abort()
+
+to8 = 0
+call mvbits (b'1011'_8*2_8**32, 33, 3, to8, 2)
+if (to8 /= b'10100'_8) call abort