From 06469efd1a409d723093cfaa75ab9d39653e6463 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 3 Dec 2006 07:18:22 +0000 Subject: [PATCH] re PR fortran/29642 (Fortran 2003: VALUE Attribute (call by value not call by reference for actual arguments)) 2006-12-03 Paul Thomas PR fortran/29642 * trans-expr.c (gfc_conv_variable): A character expression with the VALUE attribute needs an address expression; otherwise all other expressions with this attribute must not be dereferenced. (gfc_conv_function_call): Pass expressions with the VALUE attribute by value, using gfc_conv_expr. * symbol.c (check_conflict): Add strings for INTENT OUT, INOUT and VALUE. Apply all the constraints associated with the VALUE attribute. (gfc_add_value): New function. (gfc_copy_attr): Call it for VALUE attribute. * decl.c (match_attr_spec): Include the VALUE attribute. (gfc_match_value): New function. * dump-parse-tree.c (gfc_show_attr): Include VALUE. * gfortran.h : Add value to the symbol_attribute structure and add a prototype for gfc_add_value * module.c (mio_internal_string): Include AB_VALUE in enum. (attr_bits): Provide the VALUE string for it. (mio_symbol_attribute): Read or apply the VLUE attribute. * trans-types.c (gfc_sym_type): Variables with the VLAUE attribute are not passed by reference! * resolve.c (was_declared): Add value to those that return 1. (resolve_symbol): Value attribute requires dummy attribute. * match.h : Add prototype for gfc_match_public. * parse.c (decode_statement): Try to match a VALUE statement. 2006-12-03 Paul Thomas PR fortran/29642 * gfortran.dg/value_1.f90 : New test. * gfortran.dg/value_2.f90 : New test. * gfortran.dg/value_3.f90 : New test. * gfortran.dg/value_4.f90 : New test. * gfortran.dg/value_4.c : Called from value_4.f90. From-SVN: r119461 --- gcc/fortran/ChangeLog | 28 +++++++++ gcc/fortran/decl.c | 66 ++++++++++++++++++++- gcc/fortran/dump-parse-tree.c | 2 + gcc/fortran/gfortran.h | 3 +- gcc/fortran/match.h | 1 + gcc/fortran/module.c | 16 +++-- gcc/fortran/parse.c | 1 + gcc/fortran/resolve.c | 10 +++- gcc/fortran/symbol.c | 42 +++++++++++++- gcc/fortran/trans-expr.c | 41 ++++++++----- gcc/fortran/trans-types.c | 2 +- gcc/testsuite/ChangeLog | 9 +++ gcc/testsuite/gfortran.dg/value_1.f90 | 84 +++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/value_2.f90 | 21 +++++++ gcc/testsuite/gfortran.dg/value_3.f90 | 53 +++++++++++++++++ gcc/testsuite/gfortran.dg/value_4.c | 48 +++++++++++++++ gcc/testsuite/gfortran.dg/value_4.f90 | 84 +++++++++++++++++++++++++++ 17 files changed, 487 insertions(+), 24 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/value_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/value_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/value_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/value_4.c create mode 100644 gcc/testsuite/gfortran.dg/value_4.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index be3e91e5dac..d17b047aa82 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,31 @@ +2006-12-03 Paul Thomas + + PR fortran/29642 + * trans-expr.c (gfc_conv_variable): A character expression with + the VALUE attribute needs an address expression; otherwise all + other expressions with this attribute must not be dereferenced. + (gfc_conv_function_call): Pass expressions with the VALUE + attribute by value, using gfc_conv_expr. + * symbol.c (check_conflict): Add strings for INTENT OUT, INOUT + and VALUE. Apply all the constraints associated with the VALUE + attribute. + (gfc_add_value): New function. + (gfc_copy_attr): Call it for VALUE attribute. + * decl.c (match_attr_spec): Include the VALUE attribute. + (gfc_match_value): New function. + * dump-parse-tree.c (gfc_show_attr): Include VALUE. + * gfortran.h : Add value to the symbol_attribute structure and + add a prototype for gfc_add_value + * module.c (mio_internal_string): Include AB_VALUE in enum. + (attr_bits): Provide the VALUE string for it. + (mio_symbol_attribute): Read or apply the VLUE attribute. + * trans-types.c (gfc_sym_type): Variables with the VLAUE + attribute are not passed by reference! + * resolve.c (was_declared): Add value to those that return 1. + (resolve_symbol): Value attribute requires dummy attribute. + * match.h : Add prototype for gfc_match_public. + * parse.c (decode_statement): Try to match a VALUE statement. + 2006-12-01 Thomas Koenig PR libfortran/29568 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 25fa6b58b85..46c49ba9e8c 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2117,7 +2117,7 @@ match_attr_spec (void) DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL, DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE, - DECL_TARGET, DECL_VOLATILE, DECL_COLON, DECL_NONE, + DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_COLON, DECL_NONE, GFC_DECL_END /* Sentinel */ } decl_types; @@ -2140,6 +2140,7 @@ match_attr_spec (void) minit (", public", DECL_PUBLIC), minit (", save", DECL_SAVE), minit (", target", DECL_TARGET), + minit (", value", DECL_VALUE), minit (", volatile", DECL_VOLATILE), minit ("::", DECL_COLON), minit (NULL, DECL_NONE) @@ -2261,6 +2262,9 @@ match_attr_spec (void) case DECL_TARGET: attr = "TARGET"; break; + case DECL_VALUE: + attr = "VALUE"; + break; case DECL_VOLATILE: attr = "VOLATILE"; break; @@ -2378,6 +2382,15 @@ match_attr_spec (void) t = gfc_add_target (¤t_attr, &seen_at[d]); break; + case DECL_VALUE: + if (gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: VALUE attribute at %C") + == FAILURE) + t = FAILURE; + else + t = gfc_add_value (¤t_attr, NULL, &seen_at[d]); + break; + case DECL_VOLATILE: if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE attribute at %C") @@ -4050,6 +4063,57 @@ syntax: } +match +gfc_match_value (void) +{ + gfc_symbol *sym; + match m; + + if (gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: VALUE statement at %C") + == FAILURE) + return MATCH_ERROR; + + if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) + { + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + goto syntax; + + for(;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (gfc_add_value (&sym->attr, sym->name, + &gfc_current_locus) == FAILURE) + return MATCH_ERROR; + goto next_item; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + + next_item: + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in VALUE statement at %C"); + return MATCH_ERROR; +} + match gfc_match_volatile (void) { diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index dd08d1fc64d..f53ee2e8598 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -552,6 +552,8 @@ gfc_show_attr (symbol_attribute * attr) gfc_status (" POINTER"); if (attr->save) gfc_status (" SAVE"); + if (attr->value) + gfc_status (" VALUE"); if (attr->volatile_) gfc_status (" VOLATILE"); if (attr->threadprivate) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 9a18e7851d7..3a3b680f88f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -479,7 +479,7 @@ typedef struct { /* Variable attributes. */ unsigned allocatable:1, dimension:1, external:1, intrinsic:1, - optional:1, pointer:1, save:1, target:1, volatile_:1, + optional:1, pointer:1, save:1, target:1, value:1, volatile_:1, dummy:1, result:1, assign:1, threadprivate:1; unsigned data:1, /* Symbol is named in a DATA statement. */ @@ -1871,6 +1871,7 @@ try gfc_add_pure (symbol_attribute *, locus *); try gfc_add_recursive (symbol_attribute *, locus *); try gfc_add_function (symbol_attribute *, const char *, locus *); try gfc_add_subroutine (symbol_attribute *, const char *, locus *); +try gfc_add_value (symbol_attribute *, const char *, locus *); try gfc_add_volatile (symbol_attribute *, const char *, locus *); try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *); diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 8a8ab99d437..cc0207b9916 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -147,6 +147,7 @@ match gfc_match_public (gfc_statement *); match gfc_match_save (void); match gfc_match_modproc (void); match gfc_match_target (void); +match gfc_match_value (void); match gfc_match_volatile (void); /* primary.c */ diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index cd83ff9b270..6956fc980c5 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1487,11 +1487,11 @@ mio_internal_string (char *string) typedef enum { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL, - AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT, - AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, - AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE, - AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER, - AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, AB_VOLATILE + AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA, + AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, + AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, + AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, + AB_VALUE, AB_VOLATILE } ab_attribute; @@ -1504,6 +1504,7 @@ static const mstring attr_bits[] = minit ("OPTIONAL", AB_OPTIONAL), minit ("POINTER", AB_POINTER), minit ("SAVE", AB_SAVE), + minit ("VALUE", AB_VALUE), minit ("VOLATILE", AB_VOLATILE), minit ("TARGET", AB_TARGET), minit ("THREADPRIVATE", AB_THREADPRIVATE), @@ -1575,6 +1576,8 @@ mio_symbol_attribute (symbol_attribute * attr) MIO_NAME(ab_attribute) (AB_POINTER, attr_bits); if (attr->save) MIO_NAME(ab_attribute) (AB_SAVE, attr_bits); + if (attr->value) + MIO_NAME(ab_attribute) (AB_VALUE, attr_bits); if (attr->volatile_) MIO_NAME(ab_attribute) (AB_VOLATILE, attr_bits); if (attr->target) @@ -1655,6 +1658,9 @@ mio_symbol_attribute (symbol_attribute * attr) case AB_SAVE: attr->save = 1; break; + case AB_VALUE: + attr->value = 1; + break; case AB_VOLATILE: attr->volatile_ = 1; break; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index eebe4483373..d23737356ab 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -284,6 +284,7 @@ decode_statement (void) break; case 'v': + match ("value", gfc_match_value, ST_ATTR_DECL); match ("volatile", gfc_match_volatile, ST_ATTR_DECL); break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fd544c9a33b..d682b223b45 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -675,7 +675,7 @@ was_declared (gfc_symbol * sym) return 1; if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic - || a.optional || a.pointer || a.save || a.target || a.volatile_ + || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN) return 1; @@ -5961,6 +5961,14 @@ resolve_symbol (gfc_symbol * sym) return; } + if (sym->attr.value && !sym->attr.dummy) + { + gfc_error ("'%s' at %L cannot have the VALUE attribute because " + "it is not a dummy", sym->name, &sym->declared_at); + return; + } + + /* If a derived type symbol has reached this point, without its type being declared, we have an error. Notice that most conditions that produce undefined derived types have already diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 7982920b4fa..228567bd5e8 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -266,6 +266,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC", + *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)", *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE", *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", @@ -273,7 +274,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) *function = "FUNCTION", *subroutine = "SUBROUTINE", *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", - *cray_pointee = "CRAY POINTEE", *data = "DATA", *volatile_ = "VOLATILE"; + *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", + *volatile_ = "VOLATILE"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -402,6 +404,21 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf (data, allocatable); conf (data, use_assoc); + conf (value, pointer) + conf (value, allocatable) + conf (value, subroutine) + conf (value, function) + conf (value, volatile_) + conf (value, dimension) + conf (value, external) + + if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT)) + { + a1 = value; + a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout; + goto conflict; + } + conf (volatile_, intrinsic) conf (volatile_, external) @@ -524,6 +541,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) conf2 (dummy); conf2 (in_common); conf2 (save); + conf2 (value); conf2 (volatile_); conf2 (threadprivate); break; @@ -804,6 +822,26 @@ gfc_add_save (symbol_attribute * attr, const char *name, locus * where) return check_conflict (attr, name, where); } +try +gfc_add_value (symbol_attribute * attr, const char *name, locus * where) +{ + + if (check_used (attr, name, where)) + return FAILURE; + + if (attr->value) + { + if (gfc_notify_std (GFC_STD_LEGACY, + "Duplicate VALUE attribute specified at %L", + where) + == FAILURE) + return FAILURE; + } + + attr->value = 1; + return check_conflict (attr, name, where); +} + try gfc_add_volatile (symbol_attribute * attr, const char *name, locus * where) { @@ -1257,6 +1295,8 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) goto fail; if (src->save && gfc_add_save (dest, NULL, where) == FAILURE) goto fail; + if (src->value && gfc_add_value (dest, NULL, where) == FAILURE) + goto fail; if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE) goto fail; if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d5040431f1c..3505236ab47 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -447,15 +447,21 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) separately. */ if (sym->ts.type == BT_CHARACTER) { - /* Dereference character pointer dummy arguments + /* Dereference character pointer dummy arguments or results. */ if ((sym->attr.pointer || sym->attr.allocatable) && (sym->attr.dummy || sym->attr.function || sym->attr.result)) se->expr = build_fold_indirect_ref (se->expr); + + /* A character with VALUE attribute needs an address + expression. */ + if (sym->attr.value) + se->expr = build_fold_addr_expr (se->expr); + } - else + else if (!sym->attr.value) { /* Dereference non-character scalar dummy arguments. */ if (sym->attr.dummy && !sym->attr.dimension) @@ -2005,19 +2011,26 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, argss = gfc_walk_expr (e); if (argss == gfc_ss_terminator) - { - gfc_conv_expr_reference (&parmse, e); + { parm_kind = SCALAR; - if (fsym && fsym->attr.pointer - && e->expr_type != EXPR_NULL) - { - /* Scalar pointer dummy args require an extra level of - indirection. The null pointer already contains - this level of indirection. */ - parm_kind = SCALAR_POINTER; - parmse.expr = build_fold_addr_expr (parmse.expr); - } - } + if (fsym && fsym->attr.value) + { + gfc_conv_expr (&parmse, e); + } + else + { + gfc_conv_expr_reference (&parmse, e); + if (fsym && fsym->attr.pointer + && e->expr_type != EXPR_NULL) + { + /* Scalar pointer dummy args require an extra level of + indirection. The null pointer already contains + this level of indirection. */ + parm_kind = SCALAR_POINTER; + parmse.expr = build_fold_addr_expr (parmse.expr); + } + } + } else { /* If the procedure requires an explicit interface, the actual diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index b1eeffcbbab..381e007ab3c 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1343,7 +1343,7 @@ gfc_sym_type (gfc_symbol * sym) sym->ts.kind = gfc_default_real_kind; } - if (sym->attr.dummy && !sym->attr.function) + if (sym->attr.dummy && !sym->attr.function && !sym->attr.value) byref = 1; else byref = 0; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a3f3d640418..d39d5bcc767 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2006-12-03 Paul Thomas + + PR fortran/29642 + * gfortran.dg/value_1.f90 : New test. + * gfortran.dg/value_2.f90 : New test. + * gfortran.dg/value_3.f90 : New test. + * gfortran.dg/value_4.f90 : New test. + * gfortran.dg/value_4.c : Called from value_4.f90. + 2006-12-02 Andrew Pinski PR C++/30033 diff --git a/gcc/testsuite/gfortran.dg/value_1.f90 b/gcc/testsuite/gfortran.dg/value_1.f90 new file mode 100644 index 00000000000..526a028ec3a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_1.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! { dg-options "-std=f2003 -fall-intrinsics" } +! Tests the functionality of the patch for PR29642, which requested the +! implementation of the F2003 VALUE attribute for gfortran. +! +! Contributed by Paul Thomas +! +module global + type :: mytype + real(4) :: x + character(4) :: c + end type mytype +contains + subroutine typhoo (dt) + type(mytype), value :: dt + if (dtne (dt, mytype (42.0, "lmno"))) call abort () + dt = mytype (21.0, "wxyz") + if (dtne (dt, mytype (21.0, "wxyz"))) call abort () + end subroutine typhoo + + logical function dtne (a, b) + type(mytype) :: a, b + dtne = .FALSE. + if ((a%x /= b%x) .or. (a%c /= b%c)) dtne = .TRUE. + end function dtne +end module global + +program test_value + use global + integer(8) :: i = 42 + real(8) :: r = 42.0 + character(2) :: c = "ab" + complex(8) :: z = (-99.0, 199.0) + type(mytype) :: dt = mytype (42.0, "lmno") + + call foo (c) + if (c /= "ab") call abort () + + call bar (i) + if (i /= 42) call abort () + + call foobar (r) + if (r /= 42.0) call abort () + + call complex_foo (z) + if (z /= (-99.0, 199.0)) call abort () + + call typhoo (dt) + if (dtne (dt, mytype (42.0, "lmno"))) call abort () + + r = 20.0 + call foobar (r*2.0 + 2.0) + +contains + subroutine foo (c) + character(2), value :: c + if (c /= "ab") call abort () + c = "cd" + if (c /= "cd") call abort () + end subroutine foo + + subroutine bar (i) + integer(8), value :: i + if (i /= 42) call abort () + i = 99 + if (i /= 99) call abort () + end subroutine bar + + subroutine foobar (r) + real(8), value :: r + if (r /= 42.0) call abort () + r = 99.0 + if (r /= 99.0) call abort () + end subroutine foobar + + subroutine complex_foo (z) + COMPLEX(8), value :: z + if (z /= (-99.0, 199.0)) call abort () + z = (77.0, -42.0) + if (z /= (77.0, -42.0)) call abort () + end subroutine complex_foo + +end program test_value +! { dg-final { cleanup-modules "global" } } diff --git a/gcc/testsuite/gfortran.dg/value_2.f90 b/gcc/testsuite/gfortran.dg/value_2.f90 new file mode 100644 index 00000000000..d25683c2e50 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Tests the standard check in the patch for PR29642, which requested the +! implementation of the F2003 VALUE attribute for gfortran. +! +! Contributed by Paul Thomas +! +program test_value + integer(8) :: i = 42 + + call bar (i) + if (i /= 42) call abort () +contains + subroutine bar (i) + integer(8) :: i + value :: i ! { dg-error "Fortran 2003: VALUE" } + if (i /= 42) call abort () + i = 99 + if (i /= 99) call abort () + end subroutine bar +end program test_value diff --git a/gcc/testsuite/gfortran.dg/value_3.f90 b/gcc/testsuite/gfortran.dg/value_3.f90 new file mode 100644 index 00000000000..c5d2d1f27df --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_3.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! Tests the constraints in the patch for PR29642, which requested the +! implementation of the F2003 VALUE attribute for gfortran. +! +! Contributed by Paul Thomas +! +program test_value + integer(8) :: i = 42, j ! { dg-error "not a dummy" } + integer(8), value :: k ! { dg-error "not a dummy" } + value :: j + +contains + subroutine bar_1 (i) + integer(8) :: i + dimension i(8) + value :: i ! { dg-error "conflicts with DIMENSION" } + i = 0 + end subroutine bar_1 + + subroutine bar_2 (i) + integer(8) :: i + pointer :: i + value :: i ! { dg-error "conflicts with POINTER" } + i = 0 + end subroutine bar_2 + + integer function bar_3 (i) + integer(8) :: i + dimension i(8) + value :: bar_3 ! { dg-error "conflicts with FUNCTION" } + i = 0 + bar_3 = 0 + end function bar_3 + + subroutine bar_4 (i, j) + integer(8), intent(inout) :: i + integer(8), intent(out) :: j + value :: i ! { dg-error "conflicts with INTENT" } + value :: j ! { dg-error "conflicts with INTENT" } + i = 0 + j = 0 + end subroutine bar_4 + + integer function bar_5 () + integer(8) :: i + external :: i + integer, parameter :: j = 99 + value :: i ! { dg-error "conflicts with EXTERNAL" } + value :: j ! { dg-error "PARAMETER attribute conflicts with" } + bar_5 = 0 + end function bar_5 + +end program test_value diff --git a/gcc/testsuite/gfortran.dg/value_4.c b/gcc/testsuite/gfortran.dg/value_4.c new file mode 100644 index 00000000000..1eff965a029 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_4.c @@ -0,0 +1,48 @@ +/* Passing from fortran to C by value, using VALUE. This is identical + to c_by_val_1.c, which performs the same function for %VAL. + + Contributed by Paul Thomas */ + +typedef struct { float r, i; } complex; +extern float *f_to_f__ (float, float*); +extern int *i_to_i__ (int, int*); +extern void c_to_c__ (complex*, complex, complex*); +extern void abort (void); + +/* In f_to_f and i_to_i we return the second argument, so that we do + not have to worry about keeping track of memory allocation between + fortran and C. All three functions check that the argument passed + by value is the same as that passed by reference. Then the passed + by value argument is modified so that the caller can check that + its version has not changed.*/ + +float * +f_to_f__(float a1, float *a2) +{ + if ( a1 != *a2 ) abort(); + *a2 = a1 * 2.0; + a1 = 0.0; + return a2; +} + +int * +i_to_i__(int i1, int *i2) +{ + if ( i1 != *i2 ) abort(); + *i2 = i1 * 3; + i1 = 0; + return i2; +} + +void +c_to_c__(complex *retval, complex c1, complex *c2) +{ + if ( c1.r != c2->r ) abort(); + if ( c1.i != c2->i ) abort(); + c1.r = 0.0; + c1.i = 0.0; + retval->r = c2->r * 4.0; + retval->i = c2->i * 4.0; + return; +} + diff --git a/gcc/testsuite/gfortran.dg/value_4.f90 b/gcc/testsuite/gfortran.dg/value_4.f90 new file mode 100644 index 00000000000..969e4acc9e9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_4.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! { dg-additional-sources value_4.c } +! { dg-options "-ff2c -w -O0" } +! +! Tests the functionality of the patch for PR29642, which requested the +! implementation of the F2003 VALUE attribute for gfortran, by calling +! external C functions by value and by reference. This is effectively +! identical to c_by_val_1.f, which does the same for %VAL. +! +! Contributed by Paul Thomas +! +module global + interface delta + module procedure deltai, deltar, deltac + end interface delta + real(4) :: epsi = epsilon (1.0_4) +contains + function deltai (a, b) result (c) + integer(4) :: a, b + logical :: c + c = (a /= b) + end function deltai + + function deltar (a, b) result (c) + real(4) :: a, b + logical :: c + c = (abs (a-b) > epsi) + end function deltar + + function deltac (a, b) result (c) + complex(4) :: a, b + logical :: c + c = ((abs (real (a-b)) > epsi).or.(abs (aimag (a-b)) > epsi)) + end function deltac +end module global + +program value_4 + use global + interface + function f_to_f (x, y) + real(4), pointer :: f_to_f + real(4) :: x, y + value :: x + end function f_to_f + end interface + + interface + function i_to_i (x, y) + integer(4), pointer :: i_to_i + integer(4) :: x, y + value :: x + end function i_to_i + end interface + + interface + complex(4) function c_to_c (x, y) + complex(4) :: x, y + value :: x + end function c_to_c + end interface + + real(4) a, b, c + integer(4) i, j, k + complex(4) u, v, w + + a = 42.0 + b = 0.0 + c = a + b = f_to_f (a, c) + if (delta ((2.0 * a), b)) call abort () + + i = 99 + j = 0 + k = i + j = i_to_i (i, k) + if (delta ((3 * i), j)) call abort () + + u = (-1.0, 2.0) + v = (1.0, -2.0) + w = u + v = c_to_c (u, w) + if (delta ((4.0 * u), v)) call abort () +end program value_4 +! { dg-final { cleanup-modules "global" } } -- 2.30.2