From 1de1b1a9e40b5aa064d5e3d032dd43ce14f6d2ad Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 30 Sep 2009 19:55:45 +0000 Subject: fortran/ 2009-09-30 Janus Weil * check.c (gfc_check_same_type_as): New function for checking SAME_TYPE_AS and EXTENDS_TYPE_OF. * decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class container, if the contained type has it. Add an initializer for the class container. (add_init_expr_to_sym): Handle BT_CLASS. (vindex_counter): New counter for setting vindices. (gfc_match_derived_decl): Set vindex for all derived types, not only those which are being extended. * expr.c (gfc_check_assign_symbol): Handle NULL initialization of class pointers. * gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and GFC_ISYM_EXTENDS_TYPE_OF. (gfc_type_is_extensible): New prototype. * intrinsic.h (gfc_check_same_type_as): New prototype. * intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF. * primary.c (gfc_expr_attr): Handle CLASS-valued functions. * resolve.c (resolve_structure_cons): Handle BT_CLASS. (type_is_extensible): Make non-static and rename to 'gfc_type_is_extensible. (resolve_select_type): Renamed type_is_extensible. (resolve_class_assign): Handle NULL pointers. (resolve_fl_variable_derived): Renamed type_is_extensible. (resolve_fl_derived): Ditto. * trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL initialization of class pointer components. (gfc_conv_structure): Handle BT_CLASS. * trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of): New functions. (gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF. 2009-09-30 Janus Weil * gfortran.h (type_selector, select_type_tmp): New global variables. * match.c (type_selector, select_type_tmp): New global variables, used for SELECT TYPE statements. (gfc_match_select_type): Better error handling. Remember selector. (gfc_match_type_is): Create temporary variable. * module.c (ab_attribute): New value 'AB_IS_CLASS'. (attr_bits): New string. (mio_symbol_attribute): Handle 'is_class'. * resolve.c (resolve_select_type): Insert pointer assignment statement, to assign temporary to selector. * symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary in SELECT TYPE statements. 2009-09-30 Janus Weil * dump-parse-tree.c (show_code_node): Renamed 'alloc_list'. * gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'. (gfc_expr_to_initialize): New prototype. * match.c (alloc_opt_list): Correctly check type compatibility. Renamed 'alloc_list'. (dealloc_opt_list): Renamed 'alloc_list'. * resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize' and make it non-static. (resolve_allocate_expr): Set vindex for CLASS variables correctly. Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'. (resolve_allocate_deallocate): Renamed 'alloc_list'. (check_class_pointer_assign): Rename to 'resolve_class_assign'. Change argument type. Adjust to work with ordinary assignments. (resolve_code): Call 'resolve_class_assign' for ordinary assignments. Renamed 'check_class_pointer_assign'. * st.c (gfc_free_statement): Renamed 'alloc_list'. * trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle size determination and initialization of CLASS variables. Bugfix for ALLOCATE statements with default initialization and SOURCE block. (gfc_trans_deallocate): Renamed 'alloc_list'. 2009-09-30 Paul Thomas * trans-expr.c (gfc_conv_procedure_call): Convert a derived type actual to a class object if the formal argument is a class. 2009-09-30 Janus Weil PR fortran/40996 * decl.c (build_struct): Handle allocatable scalar components. * expr.c (gfc_add_component_ref): Correctly set typespec of expression, after inserting component reference. * match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no variables are being used uninitialized. * primary.c (gfc_match_varspec): Handle CLASS array components. * resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to EXEC_SELECT. * trans-array.c (structure_alloc_comps,gfc_trans_deferred_array): Handle allocatable scalar components. * trans-expr.c (gfc_conv_component_ref): Ditto. * trans-types.c (gfc_get_derived_type): Ditto. 2009-09-30 Janus Weil * decl.c (encapsulate_class_symbol): Modify names of class container components by prefixing with '$'. (gfc_match_end): Handle COMP_SELECT_TYPE. * expr.c (gfc_add_component_ref): Modify names of class container components by prefixing with '$'. * gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and ST_CLASS_IS. (gfc_case): New field 'ts'. (gfc_exec_op): Add EXEC_SELECT_TYPE. (gfc_type_is_extension_of): New prototype. * match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is): New prototypes. * match.c (match_derived_type_spec): New function. (match_type_spec): Use 'match_derived_type_spec'. (match_case_eos): Modify error message. (gfc_match_select_type): New function. (gfc_match_case): Modify error message. (gfc_match_type_is): New function. (gfc_match_class_is): Ditto. * parse.h (gfc_compile_state): Add COMP_SELECT_TYPE. * parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS statements. (next_statement): Handle ST_SELECT_TYPE. (gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS. (parse_select_type_block): New function. (parse_executable): Handle ST_SELECT_TYPE. * resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of class container components by prefixing with '$'. (resolve_allocate_expr): Ditto. (resolve_select_type): New function. (gfc_resolve_blocks): Handle EXEC_SELECT_TYPE. (check_class_pointer_assign): Modify names of class container components by prefixing with '$'. (resolve_code): Ditto. * st.c (gfc_free_statement): Ditto. * symbol.c (gfc_type_is_extension_of): New function. (gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix. * trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE. 2009-09-30 Janus Weil Paul Thomas * check.c (gfc_check_move_alloc): Arguments don't have to be arrays. The second argument needs to be type-compatible with the first (not the other way around, which makes a difference for CLASS entities). * decl.c (encapsulate_class_symbol): New function. (build_sym,build_struct): Handle BT_CLASS, call 'encapsulate_class_symbol'. (gfc_match_decl_type_spec): Remove warning, use BT_CLASS. (gfc_match_derived_decl): Set vindex; * expr.c (gfc_add_component_ref): New function. (gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol): Handle BT_CLASS. * dump-parse-tree.c (show_symbol): Print vindex. * gfortran.h (bt): New basic type BT_CLASS. (symbol_attribute): New field 'is_class'. (gfc_typespec): Remove field 'is_class'. (gfc_symbol): New field 'vindex'. (gfc_get_ultimate_derived_super_type): New prototype. (gfc_add_component_ref): Ditto. * interface.c (gfc_compare_derived_types): Pointer equality check moved here from gfc_compare_types. (gfc_compare_types): Handle BT_CLASS and use gfc_type_compatible. * match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call): Handle BT_CLASS. * misc.c (gfc_clear_ts): Removed is_class. (gfc_basic_typename,gfc_typename): Handle BT_CLASS. * module.c (bt_types,mio_typespec): Handle BT_CLASS. (mio_symbol): Handle vindex. * primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS. * resolve.c (find_array_spec,check_typebound_baseobject): Handle BT_CLASS. (resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp' inside 'gcc_assert'. (resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS. (check_class_pointer_assign): New function. (resolve_code): Handle BT_CLASS, call check_class_pointer_assign. (resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived, resolve_fl_variable): Handle BT_CLASS. (check_generic_tbp_ambiguity): Add special case. (resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS. * symbol.c (gfc_get_ultimate_derived_super_type): New function. (gfc_type_compatible): Handle BT_CLASS. * trans-expr.c (conv_parent_component_references): Handle CLASS containers. (gfc_conv_initializer): Handle BT_CLASS. * trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type): Handle BT_CLASS. testsuite/ 2009-09-30 Janus Weil * gfortran.dg/same_type_as_1.f03: New test. * gfortran.dg/same_type_as_2.f03: Ditto. 2009-09-30 Janus Weil * gfortran.dg/select_type_1.f03: Extended. * gfortran.dg/select_type_3.f03: New test. 2009-09-30 Janus Weil * gfortran.dg/class_allocate_1.f03: New test. 2009-09-30 Janus Weil PR fortran/40996 * gfortran.dg/allocatable_scalar_3.f90: New test. * gfortran.dg/select_type_2.f03: Ditto. * gfortran.dg/typebound_proc_5.f03: Changed error messages. 2009-09-30 Janus Weil * gfortran.dg/block_name_2.f90: Modified error message. * gfortran.dg/select_6.f90: Ditto. * gfortran.dg/select_type_1.f03: New test. 2009-09-30 Janus Weil * gfortran.dg/allocate_derived_1.f90: Remove -w option. * gfortran.dg/class_1.f03: Ditto. * gfortran.dg/class_2.f03: Ditto. * gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto. * gfortran.dg/typebound_call_10.f03: Ditto. * gfortran.dg/typebound_call_2.f03: Ditto. * gfortran.dg/typebound_call_3.f03: Ditto. * gfortran.dg/typebound_call_4.f03: Ditto. * gfortran.dg/typebound_call_9.f03: Ditto. * gfortran.dg/typebound_generic_3.f03: Ditto. * gfortran.dg/typebound_generic_4.f03: Ditto. * gfortran.dg/typebound_operator_1.f03: Ditto. * gfortran.dg/typebound_operator_2.f03: Ditto. * gfortran.dg/typebound_operator_3.f03: Ditto. * gfortran.dg/typebound_operator_4.f03: Ditto. * gfortran.dg/typebound_proc_1.f08: Ditto. * gfortran.dg/typebound_proc_5.f03: Ditto. * gfortran.dg/typebound_proc_6.f03: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152345 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/match.c | 333 ++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 272 insertions(+), 61 deletions(-) (limited to 'gcc/fortran/match.c') diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 919d5d148fc..3e969e78ca2 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -29,6 +29,10 @@ along with GCC; see the file COPYING3. If not see int gfc_matching_procptr_assignment = 0; bool gfc_matching_prefix = false; +/* Used for SELECT TYPE statements. */ +gfc_symbol *type_selector; +gfc_symtree *select_type_tmp; + /* For debugging and diagnostic purposes. Return the textual representation of the intrinsic operator OP. */ const char * @@ -2245,6 +2249,39 @@ gfc_free_alloc_list (gfc_alloc *p) } +/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of + an accessible derived type. */ + +static match +match_derived_type_spec (gfc_typespec *ts) +{ + locus old_locus; + gfc_symbol *derived; + + old_locus = gfc_current_locus; + + if (gfc_match_symbol (&derived, 1) == MATCH_YES) + { + if (derived->attr.flavor == FL_DERIVED) + { + ts->type = BT_DERIVED; + ts->u.derived = derived; + return MATCH_YES; + } + else + { + /* Enforce F03:C476. */ + gfc_error ("'%s' at %L is not an accessible derived type", + derived->name, &gfc_current_locus); + return MATCH_ERROR; + } + } + + gfc_current_locus = old_locus; + return MATCH_NO; +} + + /* Match a Fortran 2003 type-spec (F03:R401). This is similar to gfc_match_decl_type_spec() from decl.c, with the following exceptions: It only includes the intrinsic types from the Fortran 2003 standard @@ -2256,7 +2293,6 @@ static match match_type_spec (gfc_typespec *ts) { match m; - gfc_symbol *derived; locus old_locus; gfc_clear_ts (ts); @@ -2303,43 +2339,27 @@ match_type_spec (gfc_typespec *ts) goto kind_selector; } - if (gfc_match_symbol (&derived, 1) == MATCH_YES) + m = match_derived_type_spec (ts); + if (m == MATCH_YES) { - if (derived->attr.flavor == FL_DERIVED) - { - old_locus = gfc_current_locus; - if (gfc_match (" :: ") != MATCH_YES) - return MATCH_ERROR; - gfc_current_locus = old_locus; - ts->type = BT_DERIVED; - ts->u.derived = derived; - /* Enfore F03:C401. */ - if (derived->attr.abstract) - { - gfc_error ("Derived type '%s' at %L may not be ABSTRACT", - derived->name, &old_locus); - return MATCH_ERROR; - } - return MATCH_YES; - } - else + old_locus = gfc_current_locus; + if (gfc_match (" :: ") != MATCH_YES) + return MATCH_ERROR; + gfc_current_locus = old_locus; + /* Enfore F03:C401. */ + if (ts->u.derived->attr.abstract) { - if (gfc_match (" :: ") == MATCH_YES) - { - /* Enforce F03:C476. */ - gfc_error ("'%s' at %L is not an accessible derived type", - derived->name, &old_locus); - return MATCH_ERROR; - } - else - { - gfc_current_locus = old_locus; - return MATCH_NO; - } + gfc_error ("Derived type '%s' at %L may not be ABSTRACT", + ts->u.derived->name, &old_locus); + return MATCH_ERROR; } + return MATCH_YES; } + else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES) + return MATCH_ERROR; - /* If a type is not matched, simply return MATCH_NO. */ + /* If a type is not matched, simply return MATCH_NO. */ + gfc_current_locus = old_locus; return MATCH_NO; kind_selector: @@ -2429,6 +2449,7 @@ gfc_match_allocate (void) gfc_alloc *head, *tail; gfc_expr *stat, *errmsg, *tmp, *source; gfc_typespec ts; + gfc_symbol *sym; match m; locus old_locus; bool saw_stat, saw_errmsg, saw_source, b1, b2, b3; @@ -2513,19 +2534,20 @@ gfc_match_allocate (void) tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); /* FIXME: disable the checking on derived types and arrays. */ + sym = tail->expr->symtree->n.sym; b1 = !(tail->expr->ref && (tail->expr->ref->type == REF_COMPONENT || tail->expr->ref->type == REF_ARRAY)); - b2 = tail->expr->symtree->n.sym - && !(tail->expr->symtree->n.sym->attr.allocatable - || tail->expr->symtree->n.sym->attr.pointer - || tail->expr->symtree->n.sym->attr.proc_pointer); - b3 = tail->expr->symtree->n.sym - && tail->expr->symtree->n.sym->ns - && tail->expr->symtree->n.sym->ns->proc_name - && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable - || tail->expr->symtree->n.sym->ns->proc_name->attr.pointer - || tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer); + if (sym && sym->ts.type == BT_CLASS) + b2 = !(sym->ts.u.derived->components->attr.allocatable + || sym->ts.u.derived->components->attr.pointer); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + b3 = sym && sym->ns && sym->ns->proc_name + && (sym->ns->proc_name->attr.allocatable + || sym->ns->proc_name->attr.pointer + || sym->ns->proc_name->attr.proc_pointer); if (b1 && b2 && !b3) { gfc_error ("Allocate-object at %C is not a nonprocedure pointer " @@ -2616,7 +2638,7 @@ alloc_opt_list: gfc_resolve_expr (tmp); - if (head->expr->ts.type != tmp->ts.type) + if (!gfc_type_compatible (&head->expr->ts, &tmp->ts)) { gfc_error ("Type of entity at %L is type incompatible with " "source-expr at %L", &head->expr->where, &tmp->where); @@ -2657,7 +2679,8 @@ alloc_opt_list: new_st.expr1 = stat; new_st.expr2 = errmsg; new_st.expr3 = source; - new_st.ext.alloc_list = head; + new_st.ext.alloc.list = head; + new_st.ext.alloc.ts = ts; return MATCH_YES; @@ -2754,8 +2777,9 @@ gfc_match_deallocate (void) { gfc_alloc *head, *tail; gfc_expr *stat, *errmsg, *tmp; + gfc_symbol *sym; match m; - bool saw_stat, saw_errmsg; + bool saw_stat, saw_errmsg, b1, b2; head = tail = NULL; stat = errmsg = tmp = NULL; @@ -2783,20 +2807,25 @@ gfc_match_deallocate (void) if (gfc_check_do_variable (tail->expr->symtree)) goto cleanup; - if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym)) + sym = tail->expr->symtree->n.sym; + + if (gfc_pure (NULL) && gfc_impure_variable (sym)) { gfc_error ("Illegal allocate-object at %C for a PURE procedure"); goto cleanup; } /* FIXME: disable the checking on derived types. */ - if (!(tail->expr->ref + b1 = !(tail->expr->ref && (tail->expr->ref->type == REF_COMPONENT - || tail->expr->ref->type == REF_ARRAY)) - && tail->expr->symtree->n.sym - && !(tail->expr->symtree->n.sym->attr.allocatable - || tail->expr->symtree->n.sym->attr.pointer - || tail->expr->symtree->n.sym->attr.proc_pointer)) + || tail->expr->ref->type == REF_ARRAY)); + if (sym && sym->ts.type == BT_CLASS) + b2 = !(sym->ts.u.derived->components->attr.allocatable + || sym->ts.u.derived->components->attr.pointer); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + if (b1 && b2) { gfc_error ("Allocate-object at %C is not a nonprocedure pointer " "or an allocatable variable"); @@ -2865,7 +2894,7 @@ dealloc_opt_list: new_st.op = EXEC_DEALLOCATE; new_st.expr1 = stat; new_st.expr2 = errmsg; - new_st.ext.alloc_list = head; + new_st.ext.alloc.list = head; return MATCH_YES; @@ -3021,7 +3050,8 @@ gfc_match_call (void) /* If this is a variable of derived-type, it probably starts a type-bound procedure call. */ - if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED) + if (sym->attr.flavor != FL_PROCEDURE + && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) return match_typebound_call (st); /* If it does not seem to be callable (include functions so that the @@ -3949,10 +3979,7 @@ match_case_eos (void) /* If the case construct doesn't have a case-construct-name, we should have matched the EOS. */ if (!gfc_current_block ()) - { - gfc_error ("Expected the name of the SELECT CASE construct at %C"); - return MATCH_ERROR; - } + return MATCH_NO; gfc_gobble_whitespace (); @@ -3962,7 +3989,7 @@ match_case_eos (void) if (strcmp (name, gfc_current_block ()->name) != 0) { - gfc_error ("Expected case name of '%s' at %C", + gfc_error ("Expected block name '%s' of SELECT construct at %C", gfc_current_block ()->name); return MATCH_ERROR; } @@ -3994,6 +4021,61 @@ gfc_match_select (void) } +/* Match a SELECT TYPE statement. */ + +match +gfc_match_select_type (void) +{ + gfc_expr *expr; + match m; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + m = gfc_match (" select type ( %e ", &expr); + if (m != MATCH_YES) + return m; + + /* TODO: Implement ASSOCIATE. */ + m = gfc_match (" => "); + if (m == MATCH_YES) + { + gfc_error ("Associate-name in SELECT TYPE statement at %C " + "is not yet supported"); + return MATCH_ERROR; + } + + m = gfc_match (" )%t"); + if (m != MATCH_YES) + return m; + + /* Check for F03:C811. + TODO: Change error message once ASSOCIATE is implemented. */ + if (expr->expr_type != EXPR_VARIABLE || expr->ref != NULL) + { + gfc_error ("Selector must be a named variable in SELECT TYPE statement " + "at %C"); + return MATCH_ERROR; + } + + /* Check for F03:C813. */ + if (expr->ts.type != BT_CLASS) + { + gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " + "at %C"); + return MATCH_ERROR; + } + + new_st.op = EXEC_SELECT_TYPE; + new_st.expr1 = expr; + + type_selector = expr->symtree->n.sym; + + return MATCH_YES; +} + + /* Match a CASE statement. */ match @@ -4058,13 +4140,142 @@ gfc_match_case (void) return MATCH_YES; syntax: - gfc_error ("Syntax error in CASE-specification at %C"); + gfc_error ("Syntax error in CASE specification at %C"); cleanup: gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ return MATCH_ERROR; } + +/* Match a TYPE IS statement. */ + +match +gfc_match_type_is (void) +{ + gfc_case *c = NULL; + match m; + char name[GFC_MAX_SYMBOL_LEN]; + + if (gfc_current_state () != COMP_SELECT_TYPE) + { + gfc_error ("Unexpected TYPE IS statement at %C"); + return MATCH_ERROR; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + /* TODO: Once unlimited polymorphism is implemented, we will need to call + match_type_spec here. */ + if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + new_st.ext.case_list = c; + + /* Create temporary variable. */ + sprintf (name, "tmp$%s", c->ts.u.derived->name); + gfc_get_sym_tree (name, gfc_current_ns, &select_type_tmp, false); + select_type_tmp->n.sym->ts = c->ts; + select_type_tmp->n.sym->attr.referenced = 1; + select_type_tmp->n.sym->attr.pointer = 1; + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in TYPE IS specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + + +/* Match a CLASS IS or CLASS DEFAULT statement. */ + +match +gfc_match_class_is (void) +{ + gfc_case *c = NULL; + match m; + + if (gfc_current_state () != COMP_SELECT_TYPE) + return MATCH_NO; + + if (gfc_match ("% default") == MATCH_YES) + { + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + c = gfc_get_case (); + c->where = gfc_current_locus; + c->ts.type = BT_UNKNOWN; + new_st.ext.case_list = c; + return MATCH_YES; + } + + m = gfc_match ("% is"); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + goto cleanup; + + if (c->ts.type == BT_DERIVED) + c->ts.type = BT_CLASS; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + new_st.ext.case_list = c; + + gfc_error_now ("CLASS IS specification at %C is not yet supported"); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in CLASS IS specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + + /********************* WHERE subroutines ********************/ /* Match the rest of a simple WHERE statement that follows an IF statement. -- cgit v1.2.3