gcc/fortran/trans.c

   1 /* Code translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
   3    Foundation, Inc.
   4    Contributed by Paul Brook
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "coretypes.h"
  26 #include "tree.h"
  27 #include "tree-gimple.h"
  28 #include "ggc.h"
  29 #include "toplev.h"
  30 #include "defaults.h"
  31 #include "real.h"
  32 #include "flags.h"
  33 #include "gfortran.h"
  34 #include "trans.h"
  35 #include "trans-stmt.h"
  36 #include "trans-array.h"
  37 #include "trans-types.h"
  38 #include "trans-const.h"
  39
  40 /* Naming convention for backend interface code:
  41
  42    gfc_trans_*  translate gfc_code into STMT trees.
  43
  44    gfc_conv_*   expression conversion
  45
  46    gfc_get_*    get a backend tree representation of a decl or type  */
  47
  48 static gfc_file *gfc_current_backend_file;
  49
  50 char gfc_msg_bounds[] = N_("Array bound mismatch");
  51 char gfc_msg_fault[] = N_("Array reference out of bounds");
  52 char gfc_msg_wrong_return[] = N_("Incorrect function return value");
  53
  54
  55 /* Advance along TREE_CHAIN n times.  */
  56
  57 tree
  58 gfc_advance_chain (tree t, int n)
  59 {
  60   for (; n > 0; n--)
  61     {
  62       gcc_assert (t != NULL_TREE);
  63       t = TREE_CHAIN (t);
  64     }
  65   return t;
  66 }
  67
  68
  69 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
  70
  71 tree
  72 gfc_chainon_list (tree list, tree add)
  73 {
  74   tree l;
  75
  76   l = tree_cons (NULL_TREE, add, NULL_TREE);
  77
  78   return chainon (list, l);
  79 }
  80
  81
  82 /* Strip off a legitimate source ending from the input
  83    string NAME of length LEN.  */
  84
  85 static inline void
  86 remove_suffix (char *name, int len)
  87 {
  88   int i;
  89
  90   for (i = 2; i < 8 && len > i; i++)
  91     {
  92       if (name[len - i] == '.')
  93         {
  94           name[len - i] = '\0';
  95           break;
  96         }
  97     }
  98 }
  99
 100
 101 /* Creates a variable declaration with a given TYPE.  */
 102
 103 tree
 104 gfc_create_var_np (tree type, const char *prefix)
 105 {
 106   return create_tmp_var_raw (type, prefix);
 107 }
 108
 109
 110 /* Like above, but also adds it to the current scope.  */
 111
 112 tree
 113 gfc_create_var (tree type, const char *prefix)
 114 {
 115   tree tmp;
 116
 117   tmp = gfc_create_var_np (type, prefix);
 118
 119   pushdecl (tmp);
 120
 121   return tmp;
 122 }
 123
 124
 125 /* If the an expression is not constant, evaluate it now.  We assign the
 126    result of the expression to an artificially created variable VAR, and
 127    return a pointer to the VAR_DECL node for this variable.  */
 128
 129 tree
 130 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 131 {
 132   tree var;
 133
 134   if (CONSTANT_CLASS_P (expr))
 135     return expr;
 136
 137   var = gfc_create_var (TREE_TYPE (expr), NULL);
 138   gfc_add_modify_expr (pblock, var, expr);
 139
 140   return var;
 141 }
 142
 143
 144 /* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
 145    given statement block PBLOCK.  A MODIFY_EXPR is an assignment:
 146    LHS <- RHS.  */
 147
 148 void
 149 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs,
 150                 bool tuples_p)
 151 {
 152   tree tmp;
 153
 154 #ifdef ENABLE_CHECKING
 155   /* Make sure that the types of the rhs and the lhs are the same
 156      for scalar assignments.  We should probably have something
 157      similar for aggregates, but right now removing that check just
 158      breaks everything.  */
 159   gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
 160               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
 161 #endif
 162
 163   tmp = fold_build2 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
 164                      void_type_node, lhs, rhs);
 165   gfc_add_expr_to_block (pblock, tmp);
 166 }
 167
 168
 169 /* Create a new scope/binding level and initialize a block.  Care must be
 170    taken when translating expressions as any temporaries will be placed in
 171    the innermost scope.  */
 172
 173 void
 174 gfc_start_block (stmtblock_t * block)
 175 {
 176   /* Start a new binding level.  */
 177   pushlevel (0);
 178   block->has_scope = 1;
 179
 180   /* The block is empty.  */
 181   block->head = NULL_TREE;
 182 }
 183
 184
 185 /* Initialize a block without creating a new scope.  */
 186
 187 void
 188 gfc_init_block (stmtblock_t * block)
 189 {
 190   block->head = NULL_TREE;
 191   block->has_scope = 0;
 192 }
 193
 194
 195 /* Sometimes we create a scope but it turns out that we don't actually
 196    need it.  This function merges the scope of BLOCK with its parent.
 197    Only variable decls will be merged, you still need to add the code.  */
 198
 199 void
 200 gfc_merge_block_scope (stmtblock_t * block)
 201 {
 202   tree decl;
 203   tree next;
 204
 205   gcc_assert (block->has_scope);
 206   block->has_scope = 0;
 207
 208   /* Remember the decls in this scope.  */
 209   decl = getdecls ();
 210   poplevel (0, 0, 0);
 211
 212   /* Add them to the parent scope.  */
 213   while (decl != NULL_TREE)
 214     {
 215       next = TREE_CHAIN (decl);
 216       TREE_CHAIN (decl) = NULL_TREE;
 217
 218       pushdecl (decl);
 219       decl = next;
 220     }
 221 }
 222
 223
 224 /* Finish a scope containing a block of statements.  */
 225
 226 tree
 227 gfc_finish_block (stmtblock_t * stmtblock)
 228 {
 229   tree decl;
 230   tree expr;
 231   tree block;
 232
 233   expr = stmtblock->head;
 234   if (!expr)
 235     expr = build_empty_stmt ();
 236
 237   stmtblock->head = NULL_TREE;
 238
 239   if (stmtblock->has_scope)
 240     {
 241       decl = getdecls ();
 242
 243       if (decl)
 244         {
 245           block = poplevel (1, 0, 0);
 246           expr = build3_v (BIND_EXPR, decl, expr, block);
 247         }
 248       else
 249         poplevel (0, 0, 0);
 250     }
 251
 252   return expr;
 253 }
 254
 255
 256 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 257    natural type is used.  */
 258
 259 tree
 260 gfc_build_addr_expr (tree type, tree t)
 261 {
 262   tree base_type = TREE_TYPE (t);
 263   tree natural_type;
 264
 265   if (type && POINTER_TYPE_P (type)
 266       && TREE_CODE (base_type) == ARRAY_TYPE
 267       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 268          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 269     {
 270       tree min_val = size_zero_node;
 271       tree type_domain = TYPE_DOMAIN (base_type);
 272       if (type_domain && TYPE_MIN_VALUE (type_domain))
 273         min_val = TYPE_MIN_VALUE (type_domain);
 274       t = build4 (ARRAY_REF, TREE_TYPE (type), t, min_val,
 275                   NULL_TREE, NULL_TREE);
 276       natural_type = type;
 277     }
 278   else
 279     natural_type = build_pointer_type (base_type);
 280
 281   if (TREE_CODE (t) == INDIRECT_REF)
 282     {
 283       if (!type)
 284         type = natural_type;
 285       t = TREE_OPERAND (t, 0);
 286       natural_type = TREE_TYPE (t);
 287     }
 288   else
 289     {
 290       if (DECL_P (t))
 291         TREE_ADDRESSABLE (t) = 1;
 292       t = build1 (ADDR_EXPR, natural_type, t);
 293     }
 294
 295   if (type && natural_type != type)
 296     t = convert (type, t);
 297
 298   return t;
 299 }
 300
 301
 302 /* Build an ARRAY_REF with its natural type.  */
 303
 304 tree
 305 gfc_build_array_ref (tree base, tree offset)
 306 {
 307   tree type = TREE_TYPE (base);
 308   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
 309   type = TREE_TYPE (type);
 310
 311   if (DECL_P (base))
 312     TREE_ADDRESSABLE (base) = 1;
 313
 314   /* Strip NON_LVALUE_EXPR nodes.  */
 315   STRIP_TYPE_NOPS (offset);
 316
 317   return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 318 }
 319
 320
 321 /* Generate a runtime error if COND is true.  */
 322
 323 void
 324 gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
 325                          locus * where)
 326 {
 327   stmtblock_t block;
 328   tree body;
 329   tree tmp;
 330   tree arg, arg2;
 331   char *message;
 332   int line;
 333
 334   if (integer_zerop (cond))
 335     return;
 336
 337   /* The code to generate the error.  */
 338   gfc_start_block (&block);
 339
 340   if (where)
 341     {
 342 #ifdef USE_MAPPED_LOCATION
 343       line = LOCATION_LINE (where->lb->location);
 344 #else
 345       line = where->lb->linenum;
 346 #endif
 347       asprintf (&message, "At line %d of file %s",  line,
 348                 where->lb->file->filename);
 349     }
 350   else
 351     asprintf (&message, "In file '%s', around line %d",
 352               gfc_source_file, input_line + 1);
 353
 354   arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
 355   gfc_free(message);
 356
 357   asprintf (&message, "%s", _(msgid));
 358   arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
 359   gfc_free(message);
 360
 361   tmp = build_call_expr (gfor_fndecl_runtime_error_at, 2, arg, arg2);
 362   gfc_add_expr_to_block (&block, tmp);
 363
 364   body = gfc_finish_block (&block);
 365
 366   if (integer_onep (cond))
 367     {
 368       gfc_add_expr_to_block (pblock, body);
 369     }
 370   else
 371     {
 372       /* Tell the compiler that this isn't likely.  */
 373       cond = fold_convert (long_integer_type_node, cond);
 374       tmp = build_int_cst (long_integer_type_node, 0);
 375       cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
 376       cond = fold_convert (boolean_type_node, cond);
 377
 378       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 379       gfc_add_expr_to_block (pblock, tmp);
 380     }
 381 }
 382
 383
 384 /* Call malloc to allocate size bytes of memory, with special conditions:
 385       + if size < 0, generate a runtime error,
 386       + if size == 0, return a NULL pointer,
 387       + if malloc returns NULL, issue a runtime error.  */
 388 tree
 389 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 390 {
 391   tree tmp, msg, negative, zero, malloc_result, null_result, res;
 392   stmtblock_t block2;
 393
 394   size = gfc_evaluate_now (size, block);
 395
 396   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 397     size = fold_convert (size_type_node, size);
 398
 399   /* Create a variable to hold the result.  */
 400   res = gfc_create_var (pvoid_type_node, NULL);
 401
 402   /* size < 0 ?  */
 403   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 404                           build_int_cst (size_type_node, 0));
 405   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 406       ("Attempt to allocate a negative amount of memory."));
 407   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 408                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
 409                      build_empty_stmt ());
 410   gfc_add_expr_to_block (block, tmp);
 411
 412   /* Call malloc and check the result.  */
 413   gfc_start_block (&block2);
 414   gfc_add_modify_expr (&block2, res,
 415                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
 416                        size));
 417   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 418                              build_int_cst (pvoid_type_node, 0));
 419   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 420       ("Memory allocation failed"));
 421   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 422                      build_call_expr (gfor_fndecl_os_error, 1, msg),
 423                      build_empty_stmt ());
 424   gfc_add_expr_to_block (&block2, tmp);
 425   malloc_result = gfc_finish_block (&block2);
 426
 427   /* size == 0  */
 428   zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
 429                       build_int_cst (size_type_node, 0));
 430   tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res,
 431                      build_int_cst (pvoid_type_node, 0));
 432   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result);
 433   gfc_add_expr_to_block (block, tmp);
 434
 435   if (type != NULL)
 436     res = fold_convert (type, res);
 437   return res;
 438 }
 439
 440
 441 /* Free a given variable, if it's not NULL.  */
 442 tree
 443 gfc_call_free (tree var)
 444 {
 445   stmtblock_t block;
 446   tree tmp, cond, call;
 447
 448   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 449     var = fold_convert (pvoid_type_node, var);
 450
 451   gfc_start_block (&block);
 452   var = gfc_evaluate_now (var, &block);
 453   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
 454                       build_int_cst (pvoid_type_node, 0));
 455   call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
 456   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
 457                      build_empty_stmt ());
 458   gfc_add_expr_to_block (&block, tmp);
 459
 460   return gfc_finish_block (&block);
 461 }
 462
 463
 464 /* Add a statement to a block.  */
 465
 466 void
 467 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 468 {
 469   gcc_assert (block);
 470
 471   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 472     return;
 473
 474   if (block->head)
 475     {
 476       if (TREE_CODE (block->head) != STATEMENT_LIST)
 477         {
 478           tree tmp;
 479
 480           tmp = block->head;
 481           block->head = NULL_TREE;
 482           append_to_statement_list (tmp, &block->head);
 483         }
 484       append_to_statement_list (expr, &block->head);
 485     }
 486   else
 487     /* Don't bother creating a list if we only have a single statement.  */
 488     block->head = expr;
 489 }
 490
 491
 492 /* Add a block the end of a block.  */
 493
 494 void
 495 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 496 {
 497   gcc_assert (append);
 498   gcc_assert (!append->has_scope);
 499
 500   gfc_add_expr_to_block (block, append->head);
 501   append->head = NULL_TREE;
 502 }
 503
 504
 505 /* Get the current locus.  The structure may not be complete, and should
 506    only be used with gfc_set_backend_locus.  */
 507
 508 void
 509 gfc_get_backend_locus (locus * loc)
 510 {
 511   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 512 #ifdef USE_MAPPED_LOCATION
 513   loc->lb->location = input_location;
 514 #else
 515   loc->lb->linenum = input_line;
 516 #endif
 517   loc->lb->file = gfc_current_backend_file;
 518 }
 519
 520
 521 /* Set the current locus.  */
 522
 523 void
 524 gfc_set_backend_locus (locus * loc)
 525 {
 526   gfc_current_backend_file = loc->lb->file;
 527 #ifdef USE_MAPPED_LOCATION
 528   input_location = loc->lb->location;
 529 #else
 530   input_line = loc->lb->linenum;
 531   input_filename = loc->lb->file->filename;
 532 #endif
 533 }
 534
 535
 536 /* Translate an executable statement.  */
 537
 538 tree
 539 gfc_trans_code (gfc_code * code)
 540 {
 541   stmtblock_t block;
 542   tree res;
 543
 544   if (!code)
 545     return build_empty_stmt ();
 546
 547   gfc_start_block (&block);
 548
 549   /* Translate statements one by one to GIMPLE trees until we reach
 550      the end of this gfc_code branch.  */
 551   for (; code; code = code->next)
 552     {
 553       if (code->here != 0)
 554         {
 555           res = gfc_trans_label_here (code);
 556           gfc_add_expr_to_block (&block, res);
 557         }
 558
 559       switch (code->op)
 560         {
 561         case EXEC_NOP:
 562           res = NULL_TREE;
 563           break;
 564
 565         case EXEC_ASSIGN:
 566           res = gfc_trans_assign (code);
 567           break;
 568
 569         case EXEC_LABEL_ASSIGN:
 570           res = gfc_trans_label_assign (code);
 571           break;
 572
 573         case EXEC_POINTER_ASSIGN:
 574           res = gfc_trans_pointer_assign (code);
 575           break;
 576
 577         case EXEC_INIT_ASSIGN:
 578           res = gfc_trans_init_assign (code);
 579           break;
 580
 581         case EXEC_CONTINUE:
 582           res = NULL_TREE;
 583           break;
 584
 585         case EXEC_CYCLE:
 586           res = gfc_trans_cycle (code);
 587           break;
 588
 589         case EXEC_EXIT:
 590           res = gfc_trans_exit (code);
 591           break;
 592
 593         case EXEC_GOTO:
 594           res = gfc_trans_goto (code);
 595           break;
 596
 597         case EXEC_ENTRY:
 598           res = gfc_trans_entry (code);
 599           break;
 600
 601         case EXEC_PAUSE:
 602           res = gfc_trans_pause (code);
 603           break;
 604
 605         case EXEC_STOP:
 606           res = gfc_trans_stop (code);
 607           break;
 608
 609         case EXEC_CALL:
 610           res = gfc_trans_call (code, false);
 611           break;
 612
 613         case EXEC_ASSIGN_CALL:
 614           res = gfc_trans_call (code, true);
 615           break;
 616
 617         case EXEC_RETURN:
 618           res = gfc_trans_return (code);
 619           break;
 620
 621         case EXEC_IF:
 622           res = gfc_trans_if (code);
 623           break;
 624
 625         case EXEC_ARITHMETIC_IF:
 626           res = gfc_trans_arithmetic_if (code);
 627           break;
 628
 629         case EXEC_DO:
 630           res = gfc_trans_do (code);
 631           break;
 632
 633         case EXEC_DO_WHILE:
 634           res = gfc_trans_do_while (code);
 635           break;
 636
 637         case EXEC_SELECT:
 638           res = gfc_trans_select (code);
 639           break;
 640
 641         case EXEC_FLUSH:
 642           res = gfc_trans_flush (code);
 643           break;
 644
 645         case EXEC_FORALL:
 646           res = gfc_trans_forall (code);
 647           break;
 648
 649         case EXEC_WHERE:
 650           res = gfc_trans_where (code);
 651           break;
 652
 653         case EXEC_ALLOCATE:
 654           res = gfc_trans_allocate (code);
 655           break;
 656
 657         case EXEC_DEALLOCATE:
 658           res = gfc_trans_deallocate (code);
 659           break;
 660
 661         case EXEC_OPEN:
 662           res = gfc_trans_open (code);
 663           break;
 664
 665         case EXEC_CLOSE:
 666           res = gfc_trans_close (code);
 667           break;
 668
 669         case EXEC_READ:
 670           res = gfc_trans_read (code);
 671           break;
 672
 673         case EXEC_WRITE:
 674           res = gfc_trans_write (code);
 675           break;
 676
 677         case EXEC_IOLENGTH:
 678           res = gfc_trans_iolength (code);
 679           break;
 680
 681         case EXEC_BACKSPACE:
 682           res = gfc_trans_backspace (code);
 683           break;
 684
 685         case EXEC_ENDFILE:
 686           res = gfc_trans_endfile (code);
 687           break;
 688
 689         case EXEC_INQUIRE:
 690           res = gfc_trans_inquire (code);
 691           break;
 692
 693         case EXEC_REWIND:
 694           res = gfc_trans_rewind (code);
 695           break;
 696
 697         case EXEC_TRANSFER:
 698           res = gfc_trans_transfer (code);
 699           break;
 700
 701         case EXEC_DT_END:
 702           res = gfc_trans_dt_end (code);
 703           break;
 704
 705         case EXEC_OMP_ATOMIC:
 706         case EXEC_OMP_BARRIER:
 707         case EXEC_OMP_CRITICAL:
 708         case EXEC_OMP_DO:
 709         case EXEC_OMP_FLUSH:
 710         case EXEC_OMP_MASTER:
 711         case EXEC_OMP_ORDERED:
 712         case EXEC_OMP_PARALLEL:
 713         case EXEC_OMP_PARALLEL_DO:
 714         case EXEC_OMP_PARALLEL_SECTIONS:
 715         case EXEC_OMP_PARALLEL_WORKSHARE:
 716         case EXEC_OMP_SECTIONS:
 717         case EXEC_OMP_SINGLE:
 718         case EXEC_OMP_WORKSHARE:
 719           res = gfc_trans_omp_directive (code);
 720           break;
 721
 722         default:
 723           internal_error ("gfc_trans_code(): Bad statement code");
 724         }
 725
 726       gfc_set_backend_locus (&code->loc);
 727
 728       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 729         {
 730           if (TREE_CODE (res) == STATEMENT_LIST)
 731             annotate_all_with_locus (&res, input_location);
 732           else
 733             SET_EXPR_LOCATION (res, input_location);
 734
 735           /* Add the new statement to the block.  */
 736           gfc_add_expr_to_block (&block, res);
 737         }
 738     }
 739
 740   /* Return the finished block.  */
 741   return gfc_finish_block (&block);
 742 }
 743
 744
 745 /* This function is called after a complete program unit has been parsed
 746    and resolved.  */
 747
 748 void
 749 gfc_generate_code (gfc_namespace * ns)
 750 {
 751   if (ns->is_block_data)
 752     {
 753       gfc_generate_block_data (ns);
 754       return;
 755     }
 756
 757   gfc_generate_function_code (ns);
 758 }
 759
 760
 761 /* This function is called after a complete module has been parsed
 762    and resolved.  */
 763
 764 void
 765 gfc_generate_module_code (gfc_namespace * ns)
 766 {
 767   gfc_namespace *n;
 768
 769   gfc_generate_module_vars (ns);
 770
 771   /* We need to generate all module function prototypes first, to allow
 772      sibling calls.  */
 773   for (n = ns->contained; n; n = n->sibling)
 774     {
 775       if (!n->proc_name)
 776         continue;
 777
 778       gfc_create_function_decl (n);
 779     }
 780
 781   for (n = ns->contained; n; n = n->sibling)
 782     {
 783       if (!n->proc_name)
 784         continue;
 785
 786       gfc_generate_function_code (n);
 787     }
 788 }
 789