gcc/fortran/interface.c

2553 is_procptr_result (gfc_expr *expr)
2555   gfc_component *c = gfc_get_proc_ptr_comp (expr);
2559     return ((expr->symtree->n.sym->result != expr->symtree->n.sym)
2560 	    && (expr->symtree->n.sym->result->attr.proc_pointer == 1));
2617 			   "the procedure", a->name, &a->expr->where);
2626 			   &a->expr->where);
2640       if (f->sym == NULL && a->expr == NULL)
2651       if (a->expr == NULL)
2662 	  && a->expr->ts.type != BT_DERIVED
2663 	  && a->expr->ts.type != BT_CLASS)
2664 	gfc_find_vtab (&a->expr->ts);
2666       if (a->expr->expr_type == EXPR_NULL
2690       if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
2696 	  && (a->expr->ts.type == BT_DERIVED
2697 	      || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
2701 	  f2k_derived = a->expr->ts.type == BT_DERIVED
2702 			? a->expr->ts.u.derived->f2k_derived
2703 			: CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
2710 			 &a->expr->where);
2718       if (a->expr->ts.type == BT_CHARACTER
2719 	   && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2720 	   && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2725 	   && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2733 			  mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2735 			  f->sym->name, &a->expr->where);
2741 			  mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2743 			  f->sym->name, &a->expr->where);
2748 	    && f->sym->ts.deferred != a->expr->ts.deferred
2749 	    && a->expr->ts.type == BT_CHARACTER)
2755 		       &a->expr->where, f->sym->name);
2762       actual_size = get_expr_storage_size (a->expr);
2765 	  && a->expr->ts.type != BT_PROCEDURE
2768 	  if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2772 			 &a->expr->where);
2777 			 &a->expr->where);
2786 	  && !((a->expr->expr_type == EXPR_VARIABLE
2787 		&& (a->expr->symtree->n.sym->attr.proc_pointer
2788 		    || gfc_is_proc_ptr_comp (a->expr)))
2789 	       || (a->expr->expr_type == EXPR_FUNCTION
2790 		   && is_procptr_result (a->expr))))
2794 		       f->sym->name, &a->expr->where);
2801 	  && !((a->expr->expr_type == EXPR_VARIABLE
2802 		&& (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE
2803 		    || a->expr->symtree->n.sym->attr.proc_pointer
2804 		    || gfc_is_proc_ptr_comp (a->expr)))
2805 	       || (a->expr->expr_type == EXPR_FUNCTION
2806 		   && is_procptr_result (a->expr))))
2810 		       f->sym->name, &a->expr->where);
2815 	  && a->expr->expr_type == EXPR_VARIABLE
2816 	  && a->expr->symtree->n.sym->as
2817 	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2818 	  && (a->expr->ref == NULL
2819 	      || (a->expr->ref->type == REF_ARRAY
2820 		  && a->expr->ref->u.ar.type == AR_FULL)))
2828       if (a->expr->expr_type != EXPR_NULL
2829 	  && compare_pointer (f->sym, a->expr) == 0)
2833 		       f->sym->name, &a->expr->where);
2837       if (a->expr->expr_type != EXPR_NULL
2839 	  && compare_pointer (f->sym, a->expr) == 2)
2843 		       "pointer dummy %qs", &a->expr->where,f->sym->name);
2849       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2854 		       &a->expr->where, f->sym->name);
2859       if (a->expr->expr_type == EXPR_VARIABLE
2862 	  && gfc_is_coindexed (a->expr))
2867 		       &a->expr->where, f->sym->name);
2872       if (a->expr->expr_type == EXPR_VARIABLE
2874 	  && gfc_is_coindexed (a->expr)
2875 	  && (a->expr->symtree->n.sym->attr.volatile_
2876 	      || a->expr->symtree->n.sym->attr.asynchronous))
2881 		       "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2887       if (a->expr->expr_type == EXPR_VARIABLE
2889 	  && gfc_is_coindexed (a->expr)
2890 	  && gfc_has_ultimate_allocatable (a->expr))
2895 		       "or INTENT(IN)", &a->expr->where, f->sym->name);
2901 	   && gfc_is_class_array_ref (a->expr, &full_array)
2906 		       "array at %L", f->sym->name, &a->expr->where);
2911       if (a->expr->expr_type != EXPR_NULL
2912 	  && compare_allocatable (f->sym, a->expr) == 0)
2916 		       f->sym->name, &a->expr->where);
2931 	      && !gfc_check_vardef_context (a->expr, true, false, false, context))
2933 	  if (!gfc_check_vardef_context (a->expr, false, false, false, context))
2941 	  && gfc_has_vector_subscript (a->expr))
2948 		       &a->expr->where, f->sym->name);
2957 	  && a->expr->symtree->n.sym->as
2958 	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2965 		       &a->expr->where,f->sym->name);
2970 	  && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2977 		       &a->expr->where,f->sym->name);
2986 	  && a->expr->symtree->n.sym->attr.pointer
2987 	  && a->expr->symtree->n.sym->as
2996 		       &a->expr->where,f->sym->name);
3057     if (a->expr == NULL && a->label == NULL)
3073     - p->a->expr == NULL
3074     - p->a->expr->expr_type != EXPR_VARIABLE
3075     - growing p->a->expr->symbol.  */
3085   if (!a1->expr)
3087       if (!a2->expr)
3091   if (!a2->expr)
3093   if (a1->expr->expr_type != EXPR_VARIABLE)
3095       if (a2->expr->expr_type != EXPR_VARIABLE)
3099   if (a2->expr->expr_type != EXPR_VARIABLE)
3101   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
3120   /* TODO: improve comparison, see expr.c:show_ref().  */
3191       if (!p[i].a->expr
3192 	  || p[i].a->expr->expr_type != EXPR_VARIABLE
3193 	  || p[i].a->expr->ts.type == BT_PROCEDURE)
3199 	  if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
3203 	  if (!compare_actual_expr (p[i].a->expr, p[j].a->expr))
3214 			   &p[i].a->expr->where);
3235       gfc_expr *expr;
3242       if (a->expr && a->expr->expr_type == EXPR_FUNCTION
3243 	  && a->expr->value.function.isym
3244 	  && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
3245 	expr = a->expr->value.function.actual->expr;
3247 	expr = a->expr;
3249       if (expr == NULL || expr->expr_type != EXPR_VARIABLE)
3254       if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym))
3262 			 &expr->where);
3268        if (gfc_pure (NULL) && gfc_is_coindexed (expr))
3274 			 &expr->where, gfc_intent_string (f_intent));
3284 			 &expr->where);
3290        if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
3291 	   && gfc_is_coindexed (expr))
3295 			 &expr->where, f->sym->name);
3368 			 "for procedure %qs at %L", sym->name, &a->expr->where);
3373 	  if (a->expr && a->expr->ts.type == BT_ASSUMED
3377 			 "interface", a->expr->symtree->n.sym->name,
3378 			 &a->expr->where);
3383 	  if (a->expr
3384 	      && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
3385 	      && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3386 		   && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3387 		  || gfc_expr_attr (a->expr).lock_comp))
3391 			 "procedure %qs", &a->expr->where, sym->name);
3395 	  if (a->expr
3396 	      && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
3397 	      && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3398 		   && a->expr->ts.u.derived->intmod_sym_id
3400 		  || gfc_expr_attr (a->expr).event_comp))
3404 			 "procedure %qs", &a->expr->where, sym->name);
3408 	  if (a->expr && a->expr->expr_type == EXPR_NULL
3409 	      && a->expr->ts.type == BT_UNKNOWN)
3411 	      gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
3416 	  if (a->expr && a->expr->expr_type == EXPR_VARIABLE
3417 	      && symbol_rank (a->expr->symtree->n.sym) == -1)
3420 			 "at %L", &a->expr->where);
3470 			 comp->name, &a->expr->where);
3531     if (a->expr && a->expr->expr_type == EXPR_NULL
3532 	&& a->expr->ts.type == BT_UNKNOWN)
3535 	null_expr_loc = a->expr->where;
3642     if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
3648 	while (base->expr->expr_type == EXPR_OP
3649 	       && base->expr->value.op.op == INTRINSIC_PARENTHESES)
3650 	  base->expr = base->expr->value.op.op1;
3652 	if (base->expr->ts.type == BT_CLASS)
3654 	    if (CLASS_DATA (base->expr) == NULL
3655 		|| !gfc_expr_attr (base->expr).class_ok)
3657 	    derived = CLASS_DATA (base->expr)->ts.u.derived;
3660 	  derived = base->expr->ts.u.derived;
3711 		    *tb_base = base->expr;
3776   actual->expr = e->value.op.op1;
3783       actual->next->expr = e->value.op.op2;
3926   actual->expr = lhs;
3929   actual->next->expr = rhs;