From patchwork Fri Mar 2 11:28:27 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 144223 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 0B13E1007D3 for ; Fri, 2 Mar 2012 22:29:03 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1331292545; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=M7EIhOM 8jcdJvRsS6yyKwF2AXD0=; b=ArPM/i6G09SAO7ikI5Wnxx+o9ZxI8r9ZYPM0Ss4 96eTGFU9FM6YSS/WP7bis3odEYX56f15mYsLV5jVhVD8nrQ1OWdXSVySPWJs+dwl pIInmrRLgKn8YlKwsNJUznsMQXw0Quido6j/gzYDke9AyDWNZObsiaMsVFt3VtKg 2niY= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=Vjy85erGKN4z1SLrc7iOWF18Nz9As8eIr28eo4afEfVbh30V5c/FMpNmnZDEIa SVtpajs5mQBXD4aOE92Ul+eSSMEhF2uVLSwGmvovtCrH4O299n5f+EupJv998O7u e+d8gE4pSfmhk7z7AZsXglJ6XPJLWZhn5B0bCtQrOXG88=; Received: (qmail 14128 invoked by alias); 2 Mar 2012 11:28:56 -0000 Received: (qmail 14087 invoked by uid 22791); 2 Mar 2012 11:28:50 -0000 X-SWARE-Spam-Status: No, hits=-1.7 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_CP X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 02 Mar 2012 11:28:31 +0000 Received: from [192.168.178.22] (port-92-204-104-94.dynamic.qsc.de [92.204.104.94]) by mx01.qsc.de (Postfix) with ESMTP id DAAE33D2DF; Fri, 2 Mar 2012 12:28:28 +0100 (CET) Message-ID: <4F50AEDB.2010008@net-b.de> Date: Fri, 02 Mar 2012 12:28:27 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:10.0.2) Gecko/20120215 Thunderbird/10.0.2 MIME-Version: 1.0 To: gcc patches FOR , gfortran Subject: [4.8, Fortran, Patch] PR 48820 - Support TYPE(*) of TS29113 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org TYPE(*) is Fortran's equivalent to C's "void *buffer". It may only be used for dummy arguments and essentially might only either be passed on, or appear in PRESENT, LBOUND/UBOUND/SHAPE/SIZE/IS_CONTIGUOUS - and most useful: in C_LOC. Note: For scalar TYPE(*) and for assumed-size dummies, only the address is passed on. But for dimension(:) and TS29113's new (but unimplemented) dimension(..) an array descriptor is passed. In that case, one might recover the type from the array descriptor - at least for intrinsic types. TYPE(*) is useful for, e.g., MPI (and used in the MPI v3 draft spec): There, one simply takes an argument of any type and transfers some bytes from it - without needing to know the type. TYPE(*) avoids to create hundreds of useless explicit interfaces for all kind of data types (and missing derived types that way) - or TS29113 avoids the alternative: Not using explicit interfaces (causing argument checking issues and prevents the use of BIND(C).) See PR (or first test case) for a usage example. For a pure Fortran use, one could imagine: subroutine send(buf, size) use iso_c_binding, only: c_signed_char, c_size_t type(*) :: buf(*) integer(c_size_t) :: size integer(c_signed_char) :: ibuf(size) call c_f_pointer (c_loc(buf), ibuf, shape=[size]) ! ... use ibuf ... end [This example currently fails as "c_loc(buf)" is rejected. Several BIND(C) restrictions were removed in F2008 and especially in TS29113, but gfortran has not yet removed them.] For more details, see: * TS 29113 draft: ftp://ftp.nag.co.uk/sc22wg5/N1901-N1950/N1904.pdf (Status: Went as PDTR through one round of voting by the ISO members, was updated at the last J3 meeting and is now the subject of a one-month WG5 ballot that ends on 19 March 2012. The schedule is that it will then be forwarded to SC22, which initiates a DTS ballot such that the final version will be published in September by ISO.) * MPIv3 draft (of 2011-12-15): https://svn.mpi-forum.org/trac/mpi-forum-web/attachment/ticket/229/mpi-report-F2008-2011-12-15-changeonlyplustickets_majorpages.pdf Build and regtested on x86-64-linux. OK for the 4.8 trunk? Tobias 2012-03-02 Tobias Burnus PR fortran/48820 * decl.c (gfc_match_decl_type_spec): Support type(*). (gfc_verify_c_interop): Allow type(*). * dump-parse-tree.c (show_typespec): Handle type(*). * expr.c (gfc_copy_expr): Ditto. * interface.c (compare_type_rank, compare_parameter, compare_actual_formal, gfc_procedure_use): Ditto. * libgfortran.h (bt): Add BT_ASSUMED. * misc.c (gfc_basic_typename, gfc_typename): Handle type(*). * module.c (bt_types): Ditto. * resolve.c (assumed_type_expr_allowed): New static variable. (resolve_actual_arglist, resolve_variable, resolve_symbol): Handle type(*). * trans-expr.c (gfc_conv_procedure_call): Ditto. * trans-types.c (gfc_typenode_for_spec, gfc_get_dtype): Ditto. 2012-03-02 Tobias Burnus PR fortran/48820 * gfortran.dg/assumed_type_1.f90: New. * gfortran.dg/assumed_type_2.f90: New. * gfortran.dg/assumed_type_3.f90: New. * gfortran.dg/assumed_type_4.f90: New. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 43c558a..bdb8c39 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2600,9 +2600,31 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) } - m = gfc_match (" type ( %n", name); + m = gfc_match (" type ("); matched_type = (m == MATCH_YES); - + if (matched_type) + { + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == '*') + { + if ((m = gfc_match ("*)")) != MATCH_YES) + return m; + if (gfc_current_state () == COMP_DERIVED) + { + gfc_error ("Assumed type at %C is not allowed for components"); + return MATCH_ERROR; + } + if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed type " + "at %C") == FAILURE) + return MATCH_ERROR; + ts->type = BT_ASSUMED; + return MATCH_YES; + } + + m = gfc_match ("%n", name); + matched_type = (m == MATCH_YES); + } + if ((matched_type && strcmp ("integer", name) == 0) || (!matched_type && gfc_match (" integer") == MATCH_YES)) { @@ -3854,9 +3876,9 @@ gfc_verify_c_interop (gfc_typespec *ts) ? SUCCESS : FAILURE; else if (ts->type == BT_CLASS) return FAILURE; - else if (ts->is_c_interop != 1) + else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED) return FAILURE; - + return SUCCESS; } diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index c715b30..7f1d28f 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -94,6 +94,12 @@ show_indent (void) static void show_typespec (gfc_typespec *ts) { + if (ts->type == BT_ASSUMED) + { + fputs ("(TYPE(*))", dumpfile); + return; + } + fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type)); switch (ts->type) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 129ece3..1521318 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -336,6 +336,7 @@ gfc_copy_expr (gfc_expr *p) case BT_LOGICAL: case BT_DERIVED: case BT_CLASS: + case BT_ASSUMED: break; /* Already done. */ case BT_PROCEDURE: diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index e1f0cb6..ada9ea1 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -514,7 +514,8 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) if (r1 != r2) return 0; /* Ranks differ. */ - return gfc_compare_types (&s1->ts, &s2->ts); + return gfc_compare_types (&s1->ts, &s2->ts) + || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED; } @@ -1695,6 +1696,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) && actual->ts.type != BT_HOLLERITH + && formal->ts.type != BT_ASSUMED && !gfc_compare_types (&formal->ts, &actual->ts) && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS && gfc_compare_derived_types (formal->ts.u.derived, @@ -2271,6 +2273,27 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, is_elemental, where)) return 0; + /* TS 29113, 6.3p2. */ + if (f->sym->ts.type == BT_ASSUMED + && (a->expr->ts.type == BT_DERIVED + || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr)))) + { + gfc_namespace *f2k_derived; + + f2k_derived = a->expr->ts.type == BT_DERIVED + ? a->expr->ts.u.derived->f2k_derived + : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived; + + if (f2k_derived + && (f2k_derived->finalizers || f2k_derived->tb_sym_root)) + { + gfc_error ("Actual argument at %L to assumed-type dummy is of " + "derived type with type-bound or FINAL procedures", + &a->expr->where); + return FAILURE; + } + } + /* Special case for character arguments. For allocatable, pointer and assumed-shape dummies, the string length needs to match exactly. */ @@ -2882,7 +2905,6 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) void gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { - /* Warn about calls with an implicit interface. Special case for calling a ISO_C_BINDING becase c_loc and c_funloc are pseudo-unknown. Additionally, warn about procedures not @@ -2935,6 +2957,16 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) break; } + /* TS 29113, 6.2. */ + if (a->expr && a->expr->ts.type == BT_ASSUMED + && sym->intmod_sym_id != ISOCBINDING_LOC) + { + gfc_error ("Assumed-type argument %s at %L requires an explicit " + "interface", a->expr->symtree->n.sym->name, + &a->expr->where); + break; + } + /* F2008, C1303 and C1304. */ if (a->expr && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 3f36fe8..62afc21 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -129,6 +129,7 @@ libgfortran_stat_codes; used in the run-time library for IO. */ typedef enum { BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX, - BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID + BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID, + BT_ASSUMED } bt; diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 05aef9f..012364a 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -107,6 +107,9 @@ gfc_basic_typename (bt type) case BT_UNKNOWN: p = "UNKNOWN"; break; + case BT_ASSUMED: + p = "TYPE(*)"; + break; default: gfc_internal_error ("gfc_basic_typename(): Undefined type"); } @@ -157,6 +160,9 @@ gfc_typename (gfc_typespec *ts) sprintf (buffer, "CLASS(%s)", ts->u.derived->components->ts.u.derived->name); break; + case BT_ASSUMED: + sprintf (buffer, "TYPE(*)"); + break; case BT_PROCEDURE: strcpy (buffer, "PROCEDURE"); break; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 5e0f26e..36ef4f8 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2244,6 +2244,7 @@ static const mstring bt_types[] = { minit ("PROCEDURE", BT_PROCEDURE), minit ("UNKNOWN", BT_UNKNOWN), minit ("VOID", BT_VOID), + minit ("ASSUMED", BT_ASSUMED), minit (NULL, -1) }; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4dcf9b1..4104924 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -63,6 +63,8 @@ static code_stack *cs_base = NULL; static int forall_flag; static int do_concurrent_flag; +static bool assumed_type_expr_allowed = false; + /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ static int omp_workshare_flag; @@ -1597,6 +1599,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_expr *e; int save_need_full_assumed_size; + assumed_type_expr_allowed = true; + for (; arg; arg = arg->next) { e = arg->expr; @@ -1829,6 +1833,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, return FAILURE; } } + assumed_type_expr_allowed = true; return SUCCESS; } @@ -5057,6 +5062,24 @@ resolve_variable (gfc_expr *e) return FAILURE; sym = e->symtree->n.sym; + /* TS 29113, 407b. */ + if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed) + { + gfc_error ("Invalid expression with assumed-type variable %s at %L", + sym->name, &e->where); + return FAILURE; + } + + /* TS 29113, 407b. */ + if (e->ts.type == BT_ASSUMED && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) + { + gfc_error ("Assumed-type variable %s with designator at %L", + sym->name, &e->ref->u.ar.where); + return FAILURE; + } + /* If this is an associate-name, it may be parsed with an array reference in error even though the target is scalar. Fail directly in this case. */ if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) @@ -12435,6 +12459,31 @@ resolve_symbol (gfc_symbol *sym) } } + if (sym->ts.type == BT_ASSUMED) + { + /* TS 29113, C407a. */ + if (!sym->attr.dummy) + { + gfc_error ("Assumed type of variable %s at %L is only permitted " + "for dummy variables", sym->name, &sym->declared_at); + return; + } + if (sym->attr.allocatable || sym->attr.codimension + || sym->attr.pointer || sym->attr.value) + { + gfc_error ("Assumed-type variable %s at %L may not have the " + "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute", + sym->name, &sym->declared_at); + return; + } + if (sym->attr.dimension && sym->as->type == AS_EXPLICIT) + { + gfc_error ("Assumed-type variable %s at %L shall not be an " + "explicit-shape array", sym->name, &sym->declared_at); + return; + } + } + /* If the symbol is marked as bind(c), verify it's type and kind. Do not do this for something that was implicitly typed because that is handled in gfc_set_default_type. Handle dummy arguments and procedure diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3552da3..d69399c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3619,7 +3619,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && CLASS_DATA (e)->attr.dimension) gfc_conv_class_to_class (&parmse, e, fsym->ts, false); - if (fsym && fsym->ts.type == BT_DERIVED + if (fsym && (fsym->ts.type == BT_DERIVED + || fsym->ts.type == BT_ASSUMED) && e->ts.type == BT_CLASS && !CLASS_DATA (e)->attr.dimension && !CLASS_DATA (e)->attr.codimension) diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 2579e23..6ff1d33 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1118,6 +1118,7 @@ gfc_typenode_for_spec (gfc_typespec * spec) } break; case BT_VOID: + case BT_ASSUMED: /* This is for the second arg to c_f_pointer and c_f_procpointer of the iso_c_binding module, to accept any ptr type. */ basetype = ptr_type_node; @@ -1416,6 +1417,10 @@ gfc_get_dtype (tree type) n = BT_CHARACTER; break; + case POINTER_TYPE: + n = BT_ASSUMED; + break; + default: /* TODO: Don't do dtype for temporary descriptorless arrays. */ /* We can strange array types for temporary arrays. */ --- /dev/null 2012-03-02 07:37:33.883806634 +0100 +++ gcc/gcc/testsuite/gfortran.dg/assumed_type_1.f90 2012-03-01 10:13:39.000000000 +0100 @@ -0,0 +1,57 @@ +! { dg-do compile } +! +! PR fortran/48820 +! +! Test TYPE(*) +! +! Based on a contributed test case by Walter Spector +! +module mpi_interface + implicit none + + interface mpi_send + subroutine MPI_Send (buf, count, datatype, dest, tag, comm, ierr) + type(*), intent(in) :: buf(:) + integer, intent(in) :: count + integer, intent(in) :: datatype + integer, intent(in) :: dest + integer, intent(in) :: tag + integer, intent(in) :: comm + integer, intent(out):: ierr + end subroutine + end interface + + interface mpi_send2 + subroutine MPI_Send2 (buf, count, datatype, dest, tag, comm, ierr) + type(*), intent(in) :: buf(*) + integer, intent(in) :: count + integer, intent(in) :: datatype + integer, intent(in) :: dest + integer, intent(in) :: tag + integer, intent(in) :: comm + integer, intent(out):: ierr + end subroutine + end interface + +end module + +use mpi_interface + real :: a(3) + integer :: b(3) + call foo(a) + call foo(b) + call foo(a(1:2)) + call foo(b(1:2)) + call MPI_Send(a, 1, 1,1,1,j,i) + call MPI_Send(b, 1, 1,1,1,j,i) + call MPI_Send2(a, 1, 1,1,1,j,i) + call MPI_Send2(b, 1, 1,1,1,j,i) +contains + subroutine foo(x) + type(*):: x(*) + call MPI_Send(x, 1, 1,1,1,j,i) + call MPI_Send2(x, 1, 1,1,1,j,i) + end +end + +! { dg-final { cleanup-modules "mpi_interface" } } --- /dev/null 2012-03-02 07:37:33.883806634 +0100 +++ gcc/gcc/testsuite/gfortran.dg/assumed_type_2.f90 2012-03-02 11:28:22.000000000 +0100 @@ -0,0 +1,181 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/48820 +! +! Test TYPE(*) +! + +module mod + use iso_c_binding, only: c_loc, c_ptr, c_bool + implicit none + interface my_c_loc + function my_c_loc1(x) bind(C) + import c_ptr + type(*) :: x + type(c_ptr) :: my_c_loc1 + end function + function my_c_loc2(x) bind(C) + import c_ptr + type(*) :: x(*) + type(c_ptr) :: my_c_loc2 + end function + end interface my_c_loc +contains + subroutine sub_scalar (arg1, presnt) + type(*), target, optional :: arg1 + logical :: presnt + type(c_ptr) :: cpt + if (presnt .neqv. present (arg1)) call abort () + cpt = c_loc (arg1) + end subroutine sub_scalar + + subroutine sub_array_shape (arg2, lbounds, ubounds) + type(*), target :: arg2(:,:) + type(c_ptr) :: cpt + integer :: lbounds(2), ubounds(2) + if (any (lbound(arg2) /= lbounds)) call abort () + if (any (ubound(arg2) /= ubounds)) call abort () + if (any (shape(arg2) /= ubounds-lbounds+1)) call abort () + if (size(arg2) /= product (ubounds-lbounds+1)) call abort () + if (rank (arg2) /= 2) call abort () +! if (.not. is_continuous (arg2)) call abort () !<< Not yet implemented +! cpt = c_loc (arg2) ! << FIXME: Valid since TS29113 + call sub_array_assumed (arg2) + end subroutine sub_array_shape + + subroutine sub_array_assumed (arg3) + type(*), target :: arg3(*) + type(c_ptr) :: cpt + cpt = c_loc (arg3) + end subroutine sub_array_assumed +end module + +use mod +use iso_c_binding, only: c_int, c_null_ptr +implicit none +type t1 + integer :: a +end type t1 +type :: t2 + sequence + integer :: b +end type t2 +type, bind(C) :: t3 + integer(c_int) :: c +end type t3 + +integer :: scalar_int +real, allocatable :: scalar_real_alloc +character, pointer :: scalar_char_ptr + +integer :: array_int(3) +real, allocatable :: array_real_alloc(:,:) +character, pointer :: array_char_ptr(:,:) + +type(t1) :: scalar_t1 +type(t2), allocatable :: scalar_t2_alloc +type(t3), pointer :: scalar_t3_ptr + +type(t1) :: array_t1(4) +type(t2), allocatable :: array_t2_alloc(:,:) +type(t3), pointer :: array_t3_ptr(:,:) + +class(t1), allocatable :: scalar_class_t1_alloc +class(t1), pointer :: scalar_class_t1_ptr + +class(t1), allocatable :: array_class_t1_alloc(:,:) +class(t1), pointer :: array_class_t1_ptr(:,:) + +scalar_char_ptr => null() +scalar_t3_ptr => null() + +call sub_scalar (presnt=.false.) +call sub_scalar (scalar_real_alloc, .false.) +call sub_scalar (scalar_char_ptr, .false.) +call sub_scalar (null (), .false.) +call sub_scalar (scalar_t2_alloc, .false.) +call sub_scalar (scalar_t3_ptr, .false.) + +allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr) +allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc) +allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2)) +allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2)) +allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4)) + +call sub_scalar (scalar_int, .true.) +call sub_scalar (scalar_real_alloc, .true.) +call sub_scalar (scalar_char_ptr, .true.) +call sub_scalar (array_int(2), .true.) +call sub_scalar (array_real_alloc(3,2), .true.) +call sub_scalar (array_char_ptr(0,1), .true.) +call sub_scalar (scalar_t1, .true.) +call sub_scalar (scalar_t2_alloc, .true.) +call sub_scalar (scalar_t3_ptr, .true.) +call sub_scalar (array_t1(2), .true.) +call sub_scalar (array_t2_alloc(3,2), .true.) +call sub_scalar (array_t3_ptr(0,1), .true.) +call sub_scalar (array_class_t1_alloc(2,1), .true.) +call sub_scalar (array_class_t1_ptr(3,3), .true.) + +call sub_array_assumed (array_int) +call sub_array_assumed (array_real_alloc) +call sub_array_assumed (array_char_ptr) +call sub_array_assumed (array_t1) +call sub_array_assumed (array_t2_alloc) +call sub_array_assumed (array_t3_ptr) +call sub_array_assumed (array_class_t1_alloc) +call sub_array_assumed (array_class_t1_ptr) + +call sub_array_shape (array_real_alloc, [1,1], shape(array_real_alloc)) +call sub_array_shape (array_char_ptr, [1,1], shape(array_char_ptr)) +call sub_array_shape (array_t2_alloc, [1,1], shape(array_t2_alloc)) +call sub_array_shape (array_t3_ptr, [1,1], shape(array_t3_ptr)) +call sub_array_shape (array_class_t1_alloc, [1,1], shape(array_class_t1_alloc)) +call sub_array_shape (array_class_t1_ptr, [1,1], shape(array_class_t1_ptr)) + +deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr) +deallocate (array_class_t1_ptr, array_t3_ptr) + +end + +! { dg-final { cleanup-modules "mod" } } + +! { dg-final { scan-tree-dump-times "sub_scalar .0B," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_real_alloc," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_char_ptr," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t2_alloc," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t3_ptr" 2 "original" } } + +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_int," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&array_int.1.," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } + +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_ptr._data.dat" 1 "original" } }a + +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(D" 2 "original" } } +! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&parm" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(&array_int\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&array_char_ptr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "\\.data = \\(void .\\) &array_t1.0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) parm" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t3.0:. .\\) array_t3_ptr.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.data\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_real_alloc," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_char_ptr," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t2_alloc," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t3_ptr," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_alloc._data," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_ptr._data," 1 "original" } } + +! { dg-final { cleanup-tree-dump "original" } } --- /dev/null 2012-03-02 07:37:33.883806634 +0100 +++ gcc/gcc/testsuite/gfortran.dg/assumed_type_3.f90 2012-03-02 00:51:48.000000000 +0100 @@ -0,0 +1,119 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/48820 +! +! Test TYPE(*) + +subroutine one(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } + type(*), value :: a +end subroutine one + +subroutine two(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } + type(*), pointer :: a +end subroutine two + +subroutine three(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } + type(*), allocatable :: a +end subroutine three + +subroutine four(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } + type(*) :: a[*] +end subroutine four + +subroutine five(a) ! { dg-error "shall not be an explicit-shape array" } + type(*) :: a(3) +end subroutine five + +subroutine six() + type(*) :: nodum ! { dg-error "is only permitted for dummy variables" } +end subroutine six + +subroutine seven(y) + type(*) :: y(:) + call a7(y(3:5)) ! { dg-error "Assumed-type variable y with designator" } +contains + subroutine a7(x) + type(*) :: x(*) + end subroutine a7 +end subroutine seven + +subroutine eight() + type t + type(*) :: x ! { dg-error "is not allowed for components" } + end type t +end subroutine eight + +subroutine nine() + interface one + subroutine okay(x) + type(*) :: x + end subroutine okay + subroutine okay2(x) + type(*) :: x(*) + end subroutine okay2 + subroutine okay2(x,y) + integer :: x + type(*) :: y + end subroutine okay2 + end interface + interface two + subroutine okok1(x) + type(*) :: x + end subroutine okok1 + subroutine okok2(x) + integer :: x(*) + end subroutine okok2 + end interface + interface three + subroutine ambig1(x) + type(*) :: x + end subroutine ambig1 + subroutine ambig2(x) + integer :: x + end subroutine ambig2 ! { dg-error "Ambiguous interfaces 'ambig2' and 'ambig1' in generic interface 'three'" } + end interface +end subroutine nine + +subroutine ten() + interface + subroutine bar() + end subroutine + end interface + type t + contains + procedure, nopass :: proc => bar + end type + type(t) :: xx + call sub(xx) ! { dg-error "is of derived type with type-bound or FINAL procedures" } +contains + subroutine sub(a) + type(*) :: a + end subroutine sub +end subroutine ten + +subroutine eleven(x) + external bar + type(*) :: x + call bar(x) ! { dg-error "Assumed-type argument x at .1. requires an explicit interface" } +end subroutine eleven + +subroutine twelf(x) + type(*) :: x + call bar(x) +contains + subroutine bar(x) + integer :: x ! { dg-error "Type mismatch in argument" } + end subroutine bar +end subroutine twelf + +subroutine thirteen(x, y) + type(*) :: x + integer :: y(:) + print *, ubound(y, dim=x) ! { dg-error "must be INTEGER" } +end subroutine thirteen + +subroutine fourteen(x) + type(*) :: x + x = x ! { dg-error "Invalid expression with assumed-type variable" } +end subroutine fourteen --- /dev/null 2012-03-02 07:37:33.883806634 +0100 +++ gcc/gcc/testsuite/gfortran.dg/assumed_type_4.f90 2012-03-02 00:53:21.000000000 +0100 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/48820 +! +! Test TYPE(*) + +subroutine one(a) ! { dg-error "TS 29113: Assumed type" } + type(*) :: a +end subroutine one