kernel/fiasco/tool/preprocess/src/preprocess

   1 #! /usr/bin/perl -w
   2 # -*- perl -*-
   3
   4 #
   5 # Please find extensive documentation of this program at
   6 # <http://os.inf.tu-dresden.de/~hohmuth/prj/preprocess/>
   7 #
   8
   9 # Things this script does:
  10 #
  11 # - Expand class declarations as necessary using member-function
  12 #   definitions found in the file.  Function labelled PUBLIC,
  13 #   PROTECTED and PRIVATE are put into the corresponding section of
  14 #   the class.
  15 #
  16 # - Put "INTERFACE:" regions in public header file.
  17 #
  18 # - Put "inline" functions and all types they need into public header
  19 #   file as well.
  20 #
  21 # - Put all remaining, private types and their inline functions into a
  22 #   separate header file.  This file can be used by a debugger
  23 #   interface to display the data.
  24 #
  25 # - Place include directives to top of public header file and private
  26 #   header file.
  27 #
  28
  29 #
  30 # Declarations
  31 #
  32
  33 require 5.006;
  34 use Getopt::Std;
  35 use strict;
  36
  37 sub print_expand($);
  38 sub print_funcdecl($);
  39 sub print_funcdef($);
  40 sub print_classdecl($);
  41 sub print_code($);
  42 sub func_prototype($);
  43
  44 #
  45 # Get options
  46 #
  47
  48 our $opt_c = '';                # Base name for generated include directives
  49 our $opt_o = '';                # Base name of output files (defaults to -c,
  50                                 # overrides -p)
  51 our $opt_p = '';                # Prepend to base name of output files (-c)
  52 our $opt_h = '';                # Name of public header; overrides -c
  53 our $opt_i = 0;                 # Doing inlines?
  54 our $opt_v = 0;                 # Verboseness?
  55 our $opt_l = 0;                 # Avoid generating #line directives?
  56 our $opt_L = 0;                 # Avoid generatung #line dirs in headers only?
  57 # Support for new style FIASCO config
  58 our $opt_e = '';                # List of part tags
  59 our $opt_s = 0;
  60 our $opt_d = 0;                 # verbose drop
  61
  62 our $opt_w = 0;                 # warn if no inline code for needs is found
  63
  64 # Added 2003.01.12  by RCB
  65 # Support for changing the names of headers
  66 our $opt_H = "h";               # Default extenstion for header files
  67 our $opt_C = "cc";              # Default extention for source files
  68 our $opt_t = 0;
  69
  70 getopts('e:o:c:p:h:H:C:ivlLsdwt');
  71
  72 sub usage
  73 {
  74   print <<EOF
  75 C and C++ preprocessor (c) by Michael Hohmuth
  76 Usage: preprocess [-dilLstvw] -c <base_name> [-C <source_ext>]
  77          [-e <tag_list>] [-h <head_name>] [-H <head_ext>]
  78          [-o <source_base>] [-p <prefix>] <files>
  79 OPTIONS
  80   -c <base_name>  Base name for generated include directives, generated
  81                   header files, and generated source files.
  82   -C <source_ext> File extension for generated source files (default 'cc').
  83   -d              Verbose drop sections (only in conjunction with -e).
  84   -e <tag_list>   Use explicit section selection, and set the given tag
  85                   list. <tag_list> is a qouted and space separated list of
  86                   tags that should be enabled. (Useful in conjunction
  87                   with -s)
  88   -h <head_name>  Name of generated public header (overrides -c)
  89   -H <head_ext>   File extension for generated header files (default 'h').
  90   -i              Do inlines, make inline functions real inline.
  91   -l              Avoid generating #line directives.
  92   -L              Avoid generating #line directives in headers only.
  93   -o <src_base>   Base name for generated source files (defaults to -c, and
  94                   overrides -p)
  95   -p              Prefix for names of output files.
  96   -s              Generate a single source file per .cpp file (not a file
  97                   per section).
  98   -t              Truncate empty implementation files to zero length (so
  99                   that even the includ directives are ommitted)
 100   -v              Be verbose (very).
 101   -w              Do warnings.
 102 EOF
 103 }
 104
 105 if ($opt_c eq '')
 106   {
 107     usage;
 108     die "Need to specify option -c Classfile_basename;";
 109   }
 110
 111 my $incfile_base = $opt_c;
 112 my $public_base = (($opt_h eq '') ? $incfile_base : $opt_h);
 113 my $outfile_base;
 114 my $headerfile_base;
 115 my $doing_inlines = $opt_i;
 116 my $verbose = $opt_v;
 117 my $doing_linenumbers = (! $opt_l) && (! $opt_L);
 118 my $wno_inline = $opt_w;
 119 my $status = 0;
 120
 121 my $parts_re = '';
 122 my %parts = ( '{' => '(',
 123               '}' => ')',
 124               ',' => '||',
 125               '-' => '&&',
 126               '|' => '|',
 127               '&' => '&',
 128               '(' => '(',
 129               ')' => ')',
 130               '!' => '!');
 131
 132 my $ARGV = $ARGV[0];
 133
 134 if ($opt_e ne '')
 135   {
 136     foreach my $p (split(' ',$opt_e))
 137       {
 138         $parts{$p} = '1';
 139       }
 140   }
 141
 142 # Added 2003.01.12  by RCB
 143 # Support for changing the names of headers
 144 my $source_ext = $opt_C;
 145 my $header_ext = $opt_H;
 146
 147 if ($opt_o eq '')
 148   {
 149     $outfile_base = $opt_p . $incfile_base;
 150     $headerfile_base = $opt_p . $public_base;
 151   }
 152 else
 153   {
 154     $outfile_base = $opt_o;
 155     $headerfile_base = $outfile_base;
 156   }
 157
 158 #
 159 # Variable initializations
 160 #
 161 parse_init();
 162
 163 our $print_indent = 0;
 164 clear_head();
 165
 166 my %classes = ();
 167 my %sections = ();
 168 my %impl_parts = ();
 169 my %includes = ();
 170 my @comments = ();
 171 my %public_inline = ();
 172 my %private_inline = ();
 173 my %unit_inline = ();
 174 my @inline_order_public = ();
 175 my @inline_order_private = ();
 176 my @inline_order_unit = ();
 177
 178 #
 179 # Parse input file
 180 #
 181
 182 parse_file ();
 183
 184 #
 185 # Print header file
 186 #
 187
 188 # Fixup incfile_base preproc macro if it contains invalid chars.
 189 my $incfile_base_macro;
 190
 191 $incfile_base_macro = $incfile_base;
 192 $incfile_base_macro =~ s/[+-]/_/g;
 193
 194 open(OUT, ">${headerfile_base}.$header_ext")
 195   || die "Cannot open ${headerfile_base}.$header_ext for writing!";
 196 print OUT "// AUTOMATICALLY GENERATED -- DO NOT EDIT!         -*- c++ -*-\n\n";
 197 print OUT "#ifndef ${incfile_base_macro}_$header_ext\n" .
 198           "#define ${incfile_base_macro}_$header_ext\n";
 199
 200 foreach my $i (grep {$_->{type} eq 'include'} @{$sections{"INTERFACE"}})
 201   {
 202     print_code $i;
 203   }
 204
 205 print_head ("\n" .
 206             "//\n" .
 207             "// INTERFACE definition follows \n" .
 208             "//\n\n");
 209
 210 foreach my $i ( (grep {$_->{type} eq 'classdef'
 211                  && $_->{syntax} eq 'forwarddecl'}
 212                    @{$sections{"INTERFACE"}}),
 213              (grep {$_->{type} ne 'classdef' || $_->{syntax} ne 'forwarddecl'}
 214                    @{$sections{"INTERFACE"}}) )
 215   {
 216     if ($i->{type} eq 'code')
 217       {
 218         print_code $i;
 219       }
 220     elsif ($i->{type} eq 'classdef')
 221       {
 222         print_classdecl ($i);
 223       }
 224   }
 225
 226 foreach my $i (grep {$_->{type} eq 'function' && $_->{class} eq ''
 227                                               && ! $_->{static}}
 228                  @{$sections{"IMPLEMENTATION"}})
 229   {
 230     print_funcdecl $i;
 231   }
 232
 233 my @public_templates = grep
 234   {
 235     $_->{type} eq 'function' && $_->{template} ne '' # template func
 236     && $_->{fully_specialized_template} eq ''
 237     && ! defined $public_inline{$_} # not public inline -- handled elsewhere
 238     && ($_->{visibility} eq "free"  # free func
 239         || ($_->{class} ne ''   # or member func of public or published class
 240             && ($classes{$_->{class}}->{section} eq 'INTERFACE'
 241                 || defined $public_inline{$classes{$_->{class}}})))
 242   }
 243                     @{$sections{"IMPLEMENTATION"}};
 244
 245 my $impl_includes_imported = 0;
 246
 247 if (scalar keys %public_inline || scalar @public_templates)
 248   {
 249     if (scalar @public_templates)
 250       {
 251         $impl_includes_imported = 1;
 252       }
 253
 254     clear_head();
 255     print_head
 256       ("\n" .
 257        "//\n" .
 258        "// IMPLEMENTATION includes follow " .
 259        "(for use by inline functions/templates)\n" .
 260        "//\n\n");
 261
 262     foreach my $i (grep { $_->{type} eq 'include'
 263                             && ($impl_includes_imported || $_->{inline}) }
 264                    @{$sections{"IMPLEMENTATION"}})
 265       {
 266         print_code $i;
 267       }
 268
 269     clear_head();
 270     print_head
 271       ("\n" .
 272        "//\n" .
 273        "// IMPLEMENTATION of inline functions (and needed classes)\n" .
 274        "//\n\n");
 275
 276     print_inlines (@inline_order_public);
 277   }
 278
 279 clear_head();
 280 print_head ("\n" .
 281             "//\n" .
 282             "// IMPLEMENTATION of function templates\n" .
 283             "//\n\n");
 284 foreach my $i (@public_templates)
 285   {
 286     print_funcdef $i;
 287   }
 288
 289 clear_head();
 290
 291 print OUT "\n#endif // ${incfile_base_macro}_$header_ext\n";
 292 close OUT;
 293
 294 #
 295 # Print "internal data structures" header file
 296 #
 297
 298 open(OUT, ">${outfile_base}_i.$header_ext")
 299   || die "Cannot open ${outfile_base}_i.$header_ext for writing!";
 300 print OUT "// AUTOMATICALLY GENERATED -- DO NOT EDIT!         -*- c++ -*-\n\n";
 301 print OUT "#ifndef ${incfile_base_macro}_i_$header_ext\n" .
 302           "#define ${incfile_base_macro}_i_$header_ext\n";
 303
 304 foreach my $i (grep { $_->{type} eq 'include' }
 305                @{$sections{"IMPLEMENTATION"}})
 306   {
 307     print_code $i;
 308   }
 309
 310 foreach my $i
 311   ( (grep {$_->{type} eq 'classdef' && $_->{syntax} eq 'forwarddecl'}
 312      @{$sections{"IMPLEMENTATION"}}),  # first all forward declarations,
 313     (grep {$_->{type} eq 'classdef' && $_->{syntax} ne 'forwarddecl'}
 314      @{$sections{"IMPLEMENTATION"}}) ) # then all other class / type decls
 315   {
 316     print_classdecl ($i);
 317   }
 318
 319
 320 # XXX should we print #defines here?
 321
 322 print_head ("\n" .
 323             "//\n" .
 324             "// IMPLEMENTATION of inline functions follows\n".
 325             "//\n\n");
 326 print_inlines (@inline_order_private);
 327
 328 clear_head();
 329 print_head ("\n" .
 330             "//\n" .
 331             "// IMPLEMENTATION of function templates\n" .
 332             "//\n\n");
 333 foreach my $i (grep
 334               {
 335                 $_->{type} eq 'function' && $_->{template} ne ''
 336                 && $_->{fully_specialized_template} eq ''
 337                 && ! defined $public_inline{$_}
 338                 && ! defined $private_inline{$_}
 339                 && ($_->{visibility} eq 'static'
 340                     || ($_->{class} ne ''
 341                         && ($classes{$_->{class}}->{section} ne 'INTERFACE' &&
 342                             !defined $public_inline{$classes{$_->{class}}})))
 343               } @{$sections{"IMPLEMENTATION"}})
 344   {
 345     print_funcdef $i;
 346   }
 347
 348 clear_head();
 349
 350 print OUT "\n#endif // ${incfile_base_macro}_i_$header_ext\n";
 351 close OUT;
 352
 353 $doing_linenumbers = (! $opt_l);
 354
 355 #
 356 # Print implementation file(s)
 357 #
 358
 359 foreach my $part (keys %impl_parts)
 360   {
 361     my $filename = $outfile_base.($part eq '' ? '' : ('-' . $part)) . ".$source_ext";
 362     my $empty = 1;
 363     #print "==> $filename\n";
 364     open(OUT, ">$filename") || die "Could not open $filename for writing!";
 365     print OUT "// AUTOMATICALLY GENERATED -- DO NOT EDIT!         -*- c++ -*-\n\n";
 366     print OUT "#include \"${public_base}.$header_ext\"\n" .
 367               "#include \"${incfile_base}_i.$header_ext\"\n\n";
 368
 369     foreach my $i (grep {$_->{type} eq 'function' && $_->{class} eq ''
 370                         && $_->{static}}
 371                      grep {$_->{part_ext} eq $part} @{$sections{"IMPLEMENTATION"}})
 372       {
 373         print_funcdecl $i;
 374       }
 375
 376     # Print unparsed code first -- make private inline functions see
 377     # static variables
 378
 379     foreach my $i (grep {$_->{part_ext} eq $part
 380                          && $_->{type} eq 'code'}
 381                    @{$sections{"IMPLEMENTATION"}})
 382       {
 383         print_code $i;
 384         $empty = 0;
 385       }
 386
 387     print_inlines (grep {$_->{part_ext} eq $part} @inline_order_unit);
 388
 389     foreach my $i (grep {$_->{part_ext} eq $part
 390                          && $_->{type} eq 'function'}
 391                    @{$sections{"IMPLEMENTATION"}})
 392       {
 393         next if $i->{template} ne ''
 394           && $i->{fully_specialized_template} eq '';
 395
 396         print_funcdef $i;
 397         $empty = 0;
 398       }
 399
 400     truncate OUT,0 if $empty && $opt_t;
 401     close OUT;
 402   }
 403
 404
 405 exit 0;
 406
 407 #############################################################################
 408
 409 #
 410 # Parser code.
 411 #
 412
 413 my $s_once;          # Regexp for whitespace; the \001 stuff is for comments
 414 my $s;               # Zero or more whitespace
 415 my $identifier;      # Identifier
 416 my $operator_name;   # Operator name
 417 my $paren_group;
 418 my $paren_expr;
 419 my $tparen_group;
 420 my $template;        # Template declaration tag
 421 my $template_arg;    # Template argument list
 422
 423 my $lineno;          # current line to be parsed
 424 my $blockfile;       # file that contains the currently pares block
 425 my $blockstart;      # first line of the current block
 426 my $current_section; # current section
 427 my $current_part;
 428 my $current_part_ext;
 429 my @ifstack;         # stack of #if clauses
 430
 431
 432 sub parse_init                  # Initialize parser variables.
 433 {
 434   # Regexp for whitespace; the \001 stuff is for comments
 435   $s_once = '(?:[\n\s]|\001[0-9]+\001)';
 436
 437   # Zero or more whitespace
 438   $s = $s_once . '*';
 439
 440   # Identifier
 441   $identifier = "(?:[A-Za-z_][A-Za-z_0-9]*)";
 442
 443   # Operator name
 444   $operator_name = "(?:operator$s(?:"
 445                   .'(?:[~,]|[+\-*/%^&|!=<>]=?|[<>]{2}=?|[&|+\-]{2}|->\*?'
 446                   .'|\(\)|(?:new|delete)?'.$s.'\[\])'."|$identifier))";
 447
 448
 449   $paren_group = qr{
 450                       \(
 451                       (?:
 452                          (?> [^()]+ )    # Non-parens without backtracking
 453                        |
 454                          (??{ $paren_group })     # Group with matching parens
 455                       )*
 456                       \)
 457                   }x;
 458
 459   $paren_expr = qr{ (?> $paren_group | [^()]+ )* }x;
 460
 461   # Template argument list -- similar to paren_group above
 462   $tparen_group = qr { < (?: (?> [^<>]+ ) | (??{ $tparen_group }) )* > }x;
 463
 464   # Template argument list
 465   $template_arg = qr{ (?> $tparen_group) }x;
 466
 467   # Template declaration tag
 468   $template = qr{template$s$template_arg$s};
 469
 470 }
 471
 472 sub match_e_opt
 473 {
 474   my $tag = shift;
 475   my $cp = '';
 476
 477   my $t = '\(\)&|,\{\}!-';
 478   my $orig_tag = $tag;
 479
 480   while ($tag =~ /^\s*([$t]|(?:[^\s$t]+))\s*(.*?)$/)
 481     {
 482       my $r = $parts{$1};
 483       $cp .= defined $r ? $r : 0;
 484       $tag = $2;
 485     }
 486
 487   my $match = eval $cp;
 488   #print "TAG: $tag -> $cp = $match\n";
 489   if (!defined $match)
 490     {
 491       die "${ARGV}:$lineno: error: syntax error in tag '$tag'\n";
 492     }
 493
 494   if (($verbose || $opt_d) && (!defined $match || !$match))
 495     {
 496       print "Drop SECTION: [$orig_tag] from".
 497         " file ${ARGV}\n";
 498     }
 499
 500   return $match;
 501 }
 502
 503 sub parse_file
 504 {
 505   $lineno = 0;
 506   @ifstack = ();
 507
 508   $current_section = "IMPLEMENTATION";
 509   $current_part = "";
 510   my $skip_to_next_section = 0;
 511
 512  NEXTLINE:
 513   while (1)
 514     {
 515 #print "PARSED: $_\n";
 516       $_ = '';
 517       $blockstart = $lineno + 1;
 518       $blockfile = $ARGV;
 519
 520     MORE:
 521       while (1)
 522         {
 523           if (! read_more())
 524             {
 525               last NEXTLINE;
 526             }
 527
 528           if (/^$s\/\/-[\s\n]*$/s)
 529             {
 530               handle_source_code ();
 531               next NEXTLINE;
 532             }
 533
 534           if (s/^($s)
 535                 (?:(INTERFACE
 536                     | IMPLEMENTATION)
 537                       (?:$s \[ $s ([A-Za-z0-9_,\{\}!\s&|\(\)-]+) $s \] $s)? : )
 538                /$1/sx)
 539             {
 540               check_empty_ifstack();
 541               $skip_to_next_section = 0;
 542               $current_section = $2;
 543               if ($opt_e ne '' || $current_section eq "IMPLEMENTATION")
 544                 {
 545                   if (defined $3)
 546                     {
 547                       $current_part = $3;
 548                       if ($opt_e ne '')
 549                         {
 550                           $skip_to_next_section = !match_e_opt($current_part);
 551                           next NEXTLINE if $skip_to_next_section;
 552                         }
 553                     }
 554                   else
 555                     {
 556                       $current_part = '';
 557                     }
 558                 }
 559               else
 560                 {
 561                   if (defined $3 && $opt_h ne $3)
 562                     {
 563                       die "${ARGV}:${lineno}: all INTERFACE arguments and "
 564                         . "option -h must be consistent;"
 565                           if ($opt_h ne '');
 566
 567                       $public_base = $3;
 568                       $opt_h = $3;
 569                       if ($opt_o eq '')
 570                         {
 571                           $headerfile_base = $opt_p . $public_base
 572                         }
 573                     }
 574                 }
 575               handle_source_code ();
 576               next NEXTLINE;
 577             }
 578           elsif ($skip_to_next_section)
 579             {
 580               next NEXTLINE;
 581             }
 582
 583           # Preprocessor directive?
 584           if (/^$s\#/s)
 585             {
 586               while (/\\\n$/s)
 587                 {
 588                   last NEXTLINE if ! read_more();
 589                 }
 590
 591               handle_preproc();
 592               next NEXTLINE;
 593             }
 594
 595           next NEXTLINE if ignoring();
 596
 597           # Read until we can decide what we have: Read till next block end
 598           # or semicolon.
 599           if (/\{/)
 600             {
 601               # Have a block.
 602               my $foo = $_;
 603               do {} while ($foo =~ s/\{[^\{\}]*\}//sg); # kill blocks
 604               if ($foo =~ /\{/)
 605                 {
 606 #print "MORE: $foo\n";
 607                   next MORE;    # Still unfinished blocks.
 608                 }
 609             }
 610           elsif (! /;/) # no unclosed blocks & semicolon?
 611             {
 612               next MORE;
 613             }
 614
 615           # Type declaration?
 616           if (/^$s(?:$template)?(enum|struct|class|typedef)/s)
 617             {
 618               my $syntax = $1;
 619
 620               if (/^$s(?:$template)?
 621                     (?:enum|struct|class)
 622                     $s ($identifier (?:$s $template_arg)?)
 623                     $s (?::(?!:)|\{)/sx)
 624                 {
 625                   # Have a block -> this is a definition.
 626
 627                   my $name = $1;
 628
 629                   if (/^(.*)(\}.*)$/s)
 630                     {
 631                       my $class = { name => $name,
 632                                     syntax => $syntax,
 633                                     pretext => $1,
 634                                     posttext => $2 };
 635 #print "CLASS " . $class->{name} . ">" .$class->{pretext} . "###" . $class->{posttext};
 636                       handle_classdef ($class);
 637                     }
 638                 }
 639               else
 640                 {
 641                   # No block or no name -- handle as declaration.
 642                   if (/^$s(?:$template)?(?:enum|struct|class)$s\{/s)
 643                     {
 644                       # no name but block -- make this a global variable decl.
 645                       handle_source_code ();
 646                     }
 647                   elsif (/^$s(?:$template)?(?:enum|struct|class)/s)
 648                     {
 649                       # no block -- this seems to be a forward
 650                       # decl. or a variable decl.
 651
 652                       if (/^$s(?:$template)?(?:enum|struct|class)$s
 653                           ($identifier) $s ;/sx)
 654                         {
 655                           my $class = { syntax => 'forwarddecl',
 656                                         name => $1 };
 657                           handle_classdef ($class);
 658                         }
 659                       else
 660                         {
 661                           handle_source_code ();
 662                         }
 663                     }
 664                   elsif (/^${s} typedef \b /sx) # It's a typedef
 665                     {
 666                       # strip off function args and array spec
 667                       my $l = $_;
 668                       $l =~ s/; $s $//sx;
 669                       $l =~ s/\([^\)]*\) (?:${s}const)? $s $//sx;
 670                       $l =~ s/(?: \[ [^\[]* \] $s | \) $s )+ $//sx;
 671                       $l =~ m/($identifier) $s $/sx;
 672
 673                       my $class = { syntax => 'typedef',
 674                                     name => $1 };
 675                       handle_classdef ($class);
 676                     }
 677                   else
 678                     {
 679                       die "${ARGV}:$lineno: Parse error";
 680                     }
 681                 }
 682
 683               next NEXTLINE;
 684             }
 685
 686           # Type declaration extension?
 687           if (/^$s EXTENSION $s (?:struct|class) $s ($identifier)
 688                $s (?::(?!:) $s ([^\{]*))?\{ (.*) \} $s ; $s $/sx)
 689             {
 690               my $super = $2;
 691               my $name = $1;
 692               my $string = $3;
 693
 694               if (! exists $classes{$name})
 695                 {
 696                   die "${ARGV}:$lineno: Class extension for undefined class " .
 697                       $name;
 698                 }
 699
 700               # XXX XXX we should not handle line directives here --
 701               # this is the job of the output functions.  However, as
 702               # we don't generate a new codechunk for this extension,
 703               # we just add the extension's line number here.
 704
 705               if ($doing_linenumbers)
 706                 {
 707                   $classes{$name}->{pretext} .=
 708                     "\n#line " . $blockstart . " \"" . $ARGV . "\"\n";
 709                 }
 710
 711                 my $txt = \($classes{$name}->{pretext});
 712
 713                 if (defined $super)
 714                   {
 715                     if ($$txt =~ /^([^\{]*)/sx)
 716                       {
 717                         my $pre = $1;
 718                         if ($pre =~ /^.*:(?!:)(.*)$/sx)
 719                           {
 720                             $$txt =~ s/^$pre/$pre\n, $super/s;
 721 #                           print "ADD super classes: , $super\n";
 722                           }
 723                         else
 724                           {
 725                             $$txt =~ s/^$pre/$pre\n: $super/s;
 726                           }
 727                       }
 728                   }
 729
 730               $classes{$name}->{pretext} .= "private:\n" . $string;
 731
 732               next NEXTLINE;
 733             }
 734
 735           # Member function definition?
 736           if (/^([^\{\(]*?)             # pretext, maybe w template decl tag
 737                \b ($identifier (?: $s :: $s $identifier)*) # class name
 738                ($s $template_arg)?      # optional class-template args
 739                $s :: $s
 740                ((?:$operator_name | (?: ~? $identifier )) # member name
 741                 (?:$s $template_arg)?)  # optional member-template args
 742                $s ( \( (?: [^\)] | \([^\)]*\) )* \) [^:\{=]* ) # arg list
 743                ((?:\{|:.*\{).* | (?:$s = $s 0 $s ;))$/sx)    # initializer ':' and body '{' or pure virtual
 744             {
 745               my ($pretext, $class, $templateargs, $name, $args, $posttext)
 746                 = ($1, $2, (defined $3 ? $3 : ''), $4, $5, $6);
 747 #print "P<$pretext> C<$class> T<$templateargs> N<$name> A<$args> P<$posttext>\n";
 748               # Canonify operator names
 749               $name =~ s/(?<=\w)(?:$s_once)+(?=\W)//gs;
 750               $name =~ s/(?<=\W)(?:$s_once)+(?=\w)//gs;
 751               $name =~ s/(?:$s_once)+/ /gs;
 752               # Canonify class name
 753               $class =~ s/$s//gs;
 754               my $memberfunction = { class => $class,
 755                                      name => $name,
 756                                      templateargs => $templateargs,
 757                                      pretext => $pretext,
 758                                      args => $args,
 759                                      posttext => $posttext };
 760               handle_function ($memberfunction);
 761               next NEXTLINE;
 762             }
 763
 764           # Free function definition?
 765           if (/^([^\{]*)                # pretext, maybe w template decl tag
 766                \b ($operator_name | $identifier) # function name
 767                ($s $template_arg)?      # optional template args
 768                $s( \( $paren_expr \) [^:\{\(\)=]*) # arg list
 769                (\{.*)$/sx)              # body
 770             {
 771               my $function = { class => '',
 772                                name => $2,
 773                                templateargs => (defined $3
 774                                                 ? $3 : ''),
 775                                pretext => $1,
 776                                args => $4,
 777                                posttext => $5 };
 778               handle_function ($function);
 779               next NEXTLINE;
 780             }
 781
 782           handle_source_code ();
 783           next NEXTLINE;
 784         }
 785     }
 786
 787   if (! /^$s$/s)
 788     {
 789       $verbose && print "EOF: " . $_ . "\n";
 790       die "${blockfile}:$blockstart: Unexpected end of file in block starting here;";
 791     }
 792
 793 }
 794
 795 sub read_more ()        # Read one more line of code. Stow away
 796                         # comments and character constants
 797 {
 798   # Get a line without comments.
 799   while (1)
 800     {
 801       if (eof(INPUT))                   # Reset line numbering.
 802         {
 803           check_empty_ifstack();
 804           $lineno = 0;
 805           do
 806             {
 807               my $file;
 808               return 0 unless $file = shift @ARGV;
 809               $ARGV = $file;
 810               open(INPUT, $ARGV) || die "Cannot open $ARGV for reading!";
 811               if ($opt_s)
 812                 {
 813 #      print "FILE: $ARGV\n";
 814                   my $part_ext = '';
 815                   if ($ARGV =~ /^(?:.*\/)?(.+)$/ && $1 =~ /(?:[^-]*)-(.*)\..*/)
 816                     {
 817                       $part_ext = $1;
 818                     }
 819                   $current_part_ext = $part_ext;
 820                   $impl_parts{$part_ext} = 1;
 821 #      print "PART: '$part_ext'\n";
 822                 }
 823               print "read file: '$ARGV'\n" if $verbose;
 824             }
 825           while(eof(INPUT));
 826         }
 827
 828       $lineno++;
 829
 830       my $line = <INPUT>;
 831
 832       if (! defined $line)
 833         {
 834           return 0;
 835         }
 836
 837       $_ .= $line;
 838
 839       # Save comments and strings in @comments array.  Save strings
 840       # first to catch strings with comment-like contents.
 841       my $number = @comments;
 842
 843       # We don't touch strings in NEEDS[], neither #includes!  Save now --
 844       # restore later.
 845       my $saved = '';
 846       if (s/(^$s \# $s include.*$
 847              | NEEDS $s \[[^\]]* )
 848            /\003/sx)
 849         {
 850           $saved = $1;
 851         }
 852
 853       while (s,(\'(?:\\.|[^\']|\\[0-7]+)\'),\002$number\002,s)
 854         {
 855           push @comments, $1;
 856           $number++;
 857         }
 858
 859 #      while (s,(\"(?:[^\"]|(?<=\\)\")*\"),\002$number\002,s)
 860       while (s,(\"(?:[^\\\"]|\\.)*\"),\002$number\002,s)
 861         {
 862           push @comments, $1;
 863           $number++;
 864         }
 865
 866       if ($saved ne '')
 867         {
 868           s/\003/$saved/s;
 869         }
 870
 871       while (s|(//(?!-\s*\n).*)$|\001$number\001|m) # Do not match magic "//-"
 872         {                       # The \001 signifies whitespace.
 873           push @comments, $1;
 874           $number++;
 875         }
 876
 877       while (s|(/\*.*\*/)|\001$number\001|s)
 878         {
 879           push @comments, $1;
 880           $number++;
 881         }
 882
 883       if (! /\/\*/)
 884         {
 885           last;
 886         }
 887     }
 888
 889   return 1;
 890 }
 891
 892 sub label_chunk
 893 {
 894   my ($codechunk,$type) = @_;
 895
 896   $codechunk->{type} = $type;
 897   $codechunk->{section} = $current_section;
 898   $codechunk->{string} = $_;
 899   $codechunk->{part} = $current_part;
 900   $codechunk->{part_ext} = $opt_s ? $current_part_ext : $current_part;
 901
 902   $impl_parts{$current_part} = 1 unless $opt_s;
 903
 904   $codechunk->{line} = $blockstart;
 905   $codechunk->{file} = $ARGV;
 906   $codechunk->{printed} = 0;
 907
 908   push @{$sections{$current_section}}, $codechunk;
 909 }
 910
 911 sub ignoring
 912 {
 913   foreach my $i (@ifstack)
 914     {
 915       if ($i->{value} == 1)
 916         {
 917           return 1;
 918         }
 919     }
 920
 921   return 0;
 922 }
 923
 924 sub handle_preproc
 925 {
 926 #   if ($codeblock->{string} =~ /^$s\#\s*(if|endif|else|elif)/)
 927 #     {
 928 #       die "${ARGV}:${lineno}: Conditional compilation not supported;";
 929 #     }
 930
 931   if (/^$s\#\s*if\s+0${s}$/)
 932     {
 933       push @ifstack, { value => 1, file => ${ARGV}, line => $lineno };
 934       $verbose && print "IF 0: " . ignoring() . "\n";
 935       return;
 936     }
 937   elsif (@ifstack && /^$s\#\s*if(def|ndef)?\s/)
 938     {
 939       push @ifstack, { value => 0, file => ${ARGV}, line => $lineno };
 940       $verbose && print "IF: " . ignoring() . "\n";
 941       return if ignoring();
 942     }
 943   elsif (@ifstack && /^$s\#\s*(else|elif)/)
 944     {
 945       my $ignoring = ignoring();
 946       my $i = pop @ifstack;
 947       $i->{value} = -$i->{value};
 948       push @ifstack, $i;
 949       $verbose && print "ELSE/ELIF: " . ignoring() . " ($ignoring)\n";
 950       return if $ignoring;
 951     }
 952   elsif (@ifstack && /^$s\#\s*endif/)
 953     {
 954       my $ignoring = pop @ifstack;
 955       $verbose && print "ENDIF: " . ignoring() . "\n";
 956       return if ignoring() || $ignoring->{value};
 957     }
 958   elsif (/^$s\#\s*include${s}([\"<][^\">]+[\">])/)
 959     {
 960       my $codeblock;
 961       $codeblock->{name} = $1;
 962       $codeblock->{inline} = 0;
 963
 964       $includes{$codeblock->{name}} = $codeblock;
 965
 966       label_chunk ($codeblock, "include");
 967
 968       $verbose && print "INCLUDE: " . $codeblock->{name} . "\n";
 969       return;
 970     }
 971
 972   # XXX: For now, treat preprocessor stuff besides #include, #if 0 as code.
 973   handle_source_code ();
 974 }
 975
 976 sub dump_ifstack
 977 {
 978   my $indent = '';
 979   foreach my $i (@ifstack)
 980     {
 981       print "$indent$i->{value}: $i->{file}:$i->{line}\n";
 982       $indent .= '  ';
 983     }
 984 }
 985
 986 sub check_empty_ifstack
 987 {
 988   if ($#ifstack >= 0)
 989   {
 990     my $i = pop @ifstack;
 991     print STDERR "${ARGV}:${lineno}: missing endif for $i->{file}:$i->{line}\n";
 992     die;
 993     $status = -1;
 994   }
 995 }
 996
 997 sub handle_source_code
 998 {
 999   return if /^[\s\n]*$/;
1000
1001   my $codeblock = {};
1002   label_chunk ($codeblock, "code");
1003
1004   $verbose && print "UNKNOWN: " . $codeblock->{string};
1005 }
1006
1007 sub handle_classdef
1008 {
1009   my $class = $_[0];
1010   label_chunk ($class, "classdef");
1011
1012   $class->{funcs} = [];
1013
1014   if ($class->{syntax} ne 'forwarddecl')
1015     {
1016       $classes{$class->{name}} = $class;
1017     }
1018
1019   $verbose && print "CLASSDEF: " . $class->{name} . " ["
1020     . $class->{syntax} . "]\n";
1021 }
1022
1023 sub handle_function
1024 {
1025   my $func = $_[0];
1026
1027   $func->{purevirtual} = 0;
1028
1029   if ($func->{class} ne '')
1030     {
1031       # Nested class hacks
1032       if ($func->{class} =~ /::/
1033           && ! defined $classes{$func->{class}})
1034         {
1035           # Define class along the way -- the dirty way.
1036           my $class = { name => $func->{class},
1037                         syntax => "class",
1038                         nested_class => 1 };
1039           my ($topclass, $rest) = split (/::/, $func->{class});
1040           my $save_sec = $current_section;
1041           $current_section = $classes{$topclass}->{section};
1042           handle_classdef ($class);
1043           $current_section = $save_sec;
1044         }
1045
1046       $func->{visibility} = "private";
1047       if (s/^($s)PRIVATE([\s\n])/$1$2/s)
1048         {
1049           $func->{visibility} = "private";
1050           $func->{pretext} =~ s|PRIVATE[ \t]*||s;
1051         }
1052       elsif (s/^($s)PUBLIC([\s\n])/$1$2/s)
1053         {
1054           $func->{visibility} = "public";
1055           $func->{pretext} =~ s|PUBLIC[ \t]*||s;
1056         }
1057       elsif (s/^($s)PROTECTED([\s\n])/$1$2/s)
1058         {
1059           $func->{visibility} = "protected";
1060           $func->{pretext} =~ s|PROTECTED[ \t]*||s;
1061         }
1062       elsif (s/^($s)IMPLEMENT([\s\n])/$1$2/s)
1063         {
1064           # Use a visibility attribute that is never used in adding
1065           # declarations to classes in print_classdecl.
1066           $func->{visibility} = "implementation_only";
1067           $func->{pretext} =~ s|IMPLEMENT[ \t]*||s;
1068         }
1069
1070       if ($func->{posttext} =~ s/$s=${s}0$s;$s$//s)
1071         {
1072           $func->{purevirtual} = 1;
1073         }
1074
1075       if ($func->{class} =~ /::/
1076           && $func->{visibility} ne "implementation_only")
1077         {
1078           die "${ARGV}:${lineno}: Limitation: Only predeclared members " .
1079             "supported for nested classes.  Use IMPLEMENT;";
1080         }
1081
1082       if (! defined $classes{$func->{class}})
1083         {
1084           die "${ARGV}:${lineno}: Class " . $func->{class}
1085             . " has not been declared;";
1086         }
1087     }
1088   else
1089     {
1090       $func->{visibility} = "free";
1091     }
1092
1093   # Interprete more type attributes.
1094   $func->{inline} = 0;
1095   $func->{always_inline} = 0;
1096   $func->{static} = 0;
1097   $func->{hide} = 0;
1098   $func->{virtual} = 0;
1099   $func->{explicit} = 0;
1100   $func->{classtemplate} = '';
1101   $func->{funtemplate} = '';
1102   $func->{template} = '';
1103   $func->{fully_specialized_template} = '';
1104   while (1)
1105     {
1106       if (s/^($s)((?:$template)+)([\s\n])/$1$3/s)
1107         {
1108           my $match = $2;
1109           my @specs = split(/(?<= \>)(?= $s template)/sx, $match, 3);
1110
1111           if ($func->{class} eq '') # Free function?
1112             {
1113               $func->{funtemplate} = shift @specs;
1114             }
1115           else                  # Have a class
1116             {
1117               my $class = $classes{$func->{class}};
1118               my $istemplateclass = ($class->{pretext} =~ /^[^\{]*template/s);
1119
1120               if ($istemplateclass)
1121                 {
1122                   $func->{classtemplate} = shift @specs;
1123                   $func->{funtemplate} = shift @specs if scalar @specs;
1124                 }
1125               else              # Not a class template
1126                 {
1127                   $func->{funtemplate} = shift @specs;
1128                 }
1129             }
1130
1131           die "${ARGV}:$lineno: Too many template specs"
1132             if scalar @specs;
1133
1134           $func->{template} = 'yes';
1135           $func->{fully_specialized_template} = 'yes'
1136             if ($match =~ /^(?:${s}template$s<${s}>)+${s}$/s);
1137
1138           $func->{pretext} =~ s/\Q$match//s;
1139 #         $func->{pretext} =~ s|$template[ \t]*||s;
1140           next;
1141         }
1142
1143       if (s/^($s)inline([\s\n])/$1$2/si) # "inline" is case-insensitive.
1144         {
1145           $func->{inline} = 1 if $doing_inlines
1146                                  || $func->{fully_specialized_template} ne '';
1147           $func->{pretext} =~ s|inline[ \t]*||si;
1148           @{$func->{needs}} = ();
1149           while (1)
1150             {
1151               if (s/^($s)NEEDS\s*\[([^\]]+)\]([\s\n])/$1$3/s)
1152                 {
1153                   @{$func->{needs}} = split (/\s*,\s*/, $2);
1154                   # Delete NEEDS directive, but keep newlines
1155                   while ($func->{pretext} =~
1156                          s|NEEDS \s* \[ ( (?:[^\n\]]*\n)* )
1157                            [^\n\]]+ \n (\n*)
1158                            [^\n\]]* \]
1159                           |NEEDS[$1\n$2\]|sx) {}
1160                   $func->{pretext} =~ s|NEEDS\s*\[ (\n*) [^\n\]]*\]|$1|sx;
1161                   next;
1162                 }
1163               if (s/^($s)NOEXPORT([\s\n])/$1$2/si)
1164                 {
1165                   $func->{hide} = 1;
1166                   $func->{pretext} =~ s|NOEXPORT[ \t]*||s;
1167                   next;
1168                 }
1169               if (s/^($s)ALWAYS_INLINE([\s\n])/$1$2/si)
1170                 {
1171                   $func->{inline} = 1;
1172                   $func->{always_inline} = 1;
1173                   $func->{pretext} =~ s|ALWAYS_INLINE[ \t]*||s;
1174                   next;
1175                 }
1176               last;
1177             }
1178
1179           # Reset inline data if inline handling was not enabled by -i
1180           # or ALWAYS_INLINE.
1181           if (! $func->{inline})
1182             {
1183               undef $func->{needs};
1184             }
1185           next;
1186         }
1187
1188
1189       if (s/^($s)static([\s\n])/$1$2/s)
1190         {
1191           $func->{static} = 1;
1192           $func->{pretext} =~ s/static[ \t]*//s;
1193
1194           if ($func->{class} eq '')
1195             {
1196               $func->{visibility} = "static";
1197               $func->{hide} = 1;
1198             }
1199
1200           next;
1201         }
1202
1203       if (s/^($s)IMPLEMENT([\s\n])/$1$2/s)
1204         {
1205           $func->{pretext} =~ s/IMPLEMENT[ \t]*//s;
1206
1207           if ($func->{class} eq '')
1208             {
1209               $func->{visibility} = "implementation_only";
1210             }
1211
1212           next;
1213         }
1214
1215       if (s/^($s)explicit([\s\n])/$1$2/s)
1216         {
1217           $func->{explicit} = 1;
1218           $func->{pretext} =~ s|explicit[ \t]*||s;
1219           next;
1220         }
1221
1222       if (s/^($s)virtual([\s\n])/$1$2/s)
1223         {
1224           $func->{virtual} = 1;
1225           $func->{pretext} =~ s|virtual[ \t]*||s;
1226           next;
1227         }
1228
1229       if (/^($s)(PRIVATE|PUBLIC|PROTECTED)([\s\n])/)
1230         {
1231           die "${blockfile}:$blockstart: only one visibility attribute allowed at start of declaration;";
1232         }
1233
1234       last;
1235   }
1236
1237   label_chunk ($func, "function");
1238
1239   if ($current_section eq 'INTERFACE')
1240     {
1241       die "${ARGV}:${lineno}: Function " . $func->{name}
1242           . " in INTERFACE section;";
1243     }
1244
1245   push @{$classes{$func->{class}}->{funcs}}, $func;
1246
1247   $verbose && print "FUNC: " . ($func->{class} ne ''
1248                                 ? ($func->{class} . "::")
1249                                 : "")
1250     . $func->{name}
1251     . ($func->{classtemplate} ne ''
1252        ? " T: " . $func->{classtemplate} : "")
1253     . ($func->{funtemplate} ne ''
1254        ? " M: " . $func->{funtemplate} : "")
1255     . ($func->{fully_specialized_template} ne ''
1256        ? " FULLY_SPEC" : "")
1257     . "\n";
1258 }
1259
1260 #############################################################################
1261
1262 #
1263 # Printing code.
1264 #
1265
1266 my $saved_head;
1267 my $saved_indent;
1268
1269 sub print_head                  # Save header.  Print it only if a
1270                                 # print_expand() follows
1271 {
1272   $saved_head .= $_[0];
1273   $saved_indent = $print_indent;
1274 }
1275
1276 sub clear_head
1277 {
1278   $saved_head = '';
1279 }
1280
1281 sub print_expand($)             # Expands comments and prints to OUT.
1282 {
1283   my $str = $_[0];
1284
1285   if ($saved_head ne '')
1286     {
1287       local $print_indent = $saved_indent;
1288       my $str = $saved_head;
1289       $saved_head = '';
1290
1291       print_expand $str;        # Recurse.
1292     }
1293
1294   $str =~ s/\n(?:[ \t]*\n)+/\n\n/sg if ! $doing_linenumbers;
1295
1296   while ( $str =~ s/([\001\002])([0-9]+)\1/$comments[$2]/sg )
1297     {}
1298
1299   if ($print_indent)
1300     {
1301       my $istr = " " x $print_indent;
1302       $str =~ s/^/$istr/mg;
1303     }
1304
1305   print OUT $str;
1306 }
1307
1308 sub print_lineno($)
1309 {
1310   return if ! $doing_linenumbers;
1311
1312   my $object = $_[0];
1313
1314   print_expand '';              # print headers we accumulated
1315   print OUT "#line " . $object->{line} . " \"" . $object->{file} . "\"\n";
1316 }
1317
1318 sub print_lineno_sans_empty_lines($)
1319 {
1320   return if ! $doing_linenumbers;
1321
1322   my $object = $_[0];
1323
1324   my $start_of_code = $object->{string};
1325   $start_of_code =~ s/^([\s\n]+).*$/$1/s;
1326
1327   my @startcomments = split /\n/, " $start_of_code ";
1328
1329   print OUT "#line " . ($object->{line} + @startcomments - 1)
1330     . " \"" . $object->{file} . "\"\n";
1331 }
1332
1333 sub weedout_whitespace          # Delete whitespace except on lines w/comments
1334 {
1335   my $str = $_[0];
1336
1337   $str =~ s/^[\s\n]+//s;
1338
1339   if (! $doing_linenumbers)     # more cosmetic changes if we do not
1340     {                           # have to be correct line-number-wise
1341       my @lines = split /\n/, $str;
1342       my $foundcode = 0;
1343       $str = '';
1344
1345       foreach my $line (@lines)
1346         {
1347           $line =~ s/^\s+//;
1348           $line =~ s/\s+$//;
1349
1350           if ($line =~ /\001/ || $line =~ /^\s*$/)
1351             {
1352               $line .= "\n";
1353             }
1354           else
1355             {
1356               if (! $foundcode)
1357                 {
1358                   $foundcode = 1;
1359
1360                   # Found something like code: Remove trailing whitespace
1361                   # from $str,
1362                   $str =~ s/\s+$//s;
1363                   $str .= "\n" if $str ne '';
1364                 }
1365
1366               $line =~ s/\s+/ /g;
1367               $line .= ' ';
1368             }
1369           $str .= $line;
1370         }
1371     }
1372
1373   $str =~ s/\s+$//;
1374
1375   return $str;
1376 }
1377
1378 sub func_prototype($)           # Return a function declaration from
1379                                 # func head.
1380 {
1381   my $func = $_[0];
1382   my $pretext = $func->{pretext};
1383
1384   if ($func->{inline})
1385     {
1386       $pretext =~ s/^($s)/${1}inline /s;
1387     }
1388
1389   if ($func->{explicit})
1390     {
1391       $pretext =~ s/^($s)/${1}explicit /s;
1392     }
1393
1394   if ($func->{static})
1395     {
1396       $pretext =~ s/^($s)/${1}static /s;
1397     }
1398
1399   if ($func->{virtual})
1400     {
1401       $pretext =~ s/^($s)/${1}virtual /s;
1402     }
1403
1404   if ($func->{funtemplate} ne '')
1405     {
1406       $pretext =~ s/^($s)/${1}$func->{funtemplate} /s;
1407     }
1408
1409   my $func_header = weedout_whitespace($pretext .
1410                                        $func->{name} . $func->{args});
1411
1412   # Insert ; at the correct place, that is, before any comments.
1413   my $e = $func->{purevirtual} ? ' = 0' : '';
1414   $func_header =~ s/($s)$/$e;$1/s;
1415
1416   return $func_header;
1417 }
1418
1419 sub print_funcdecl($)
1420 {
1421   my $function = $_[0];
1422
1423   if ($function->{visibility} ne "implementation_only")
1424     {
1425       print_expand "\n";
1426       print_lineno_sans_empty_lines $function;
1427       print_expand func_prototype($function) . "\n";
1428     }
1429
1430   # Handle inlines.
1431   if ($function->{inline})
1432     {
1433       handle_inline ($function);
1434     }
1435 }
1436
1437 sub print_classdecl($)
1438 {
1439   my $class = $_[0];
1440   return if check_if_printed ($class);
1441
1442   print_lineno $class;
1443
1444   if (defined $class->{nested_class})
1445     {
1446       # (This will not actually print anything, but do other processing.)
1447       foreach my $function (@{$class->{funcs}})
1448         {
1449           die "Assert failed"
1450             if $function->{visibility} ne "implementation_only";
1451           print_funcdecl $function;
1452         }
1453     }
1454   elsif ($class->{syntax} =~ /^(?:struct|class)$/)
1455     {
1456       if (! $doing_inlines)
1457         {
1458           $class->{pretext} =~ s/\binline\b[ \t]*//g;
1459         }
1460
1461       print_expand $class->{pretext};
1462
1463       print_head "\npublic:";
1464       $print_indent += 2;
1465       foreach my $function (grep {$_->{visibility} eq "public"}
1466                                  @{$class->{funcs}})
1467         {
1468           print_funcdecl $function;
1469         }
1470       $print_indent -= 2;
1471       clear_head();
1472       print_head "\nprotected:";
1473       $print_indent += 2;
1474       foreach my $function (grep {$_->{visibility} eq "protected"}
1475                                  @{$class->{funcs}})
1476         {
1477           print_funcdecl $function;
1478         }
1479       $print_indent -= 2;
1480       clear_head();
1481       print_head "\nprivate:";
1482       $print_indent += 2;
1483       foreach my $function (grep {$_->{visibility} eq "private"}
1484                                  @{$class->{funcs}})
1485         {
1486           print_funcdecl $function;
1487         }
1488       $print_indent -= 2;
1489       clear_head();
1490
1491       # Also, don't forget to "print" already-declared functions.
1492       # (This will not actually print anything, but do other processing.)
1493       foreach my $function (grep {$_->{visibility} eq "implementation_only"}
1494                                  @{$class->{funcs}})
1495         {
1496           print_funcdecl $function;
1497         }
1498
1499       print_expand $class->{posttext};
1500     }
1501   else
1502     {
1503       print_expand $class->{string};
1504     }
1505 }
1506
1507 my $parengroup;
1508 sub print_funcdef($)
1509 {
1510   my $function = $_[0];
1511   return if $function->{purevirtual};
1512   return if check_if_printed ($function);
1513
1514   my $pretext = $function->{pretext};
1515
1516   if ($function->{inline})
1517     {
1518       if ($function->{always_inline})
1519         {
1520           $pretext =~ s/^($s)/${1}ALWAYS_INLINE /s;
1521         }
1522       $pretext =~ s/^($s)/${1}inline /s;
1523     }
1524
1525   if ($function->{static} && $function->{class} eq '')
1526     {
1527       $pretext =~ s/^($s)/${1}static /s;
1528     }
1529
1530   if ($function->{funtemplate} ne '')
1531     {
1532       $pretext =~ s/^($s)/${1}$function->{funtemplate} /s;
1533     }
1534
1535   if ($function->{classtemplate} ne '')
1536     {
1537       $pretext =~ s/^($s)/${1}$function->{classtemplate} /s;
1538     }
1539
1540   # Remove default arguments from argument list
1541   my $args = $function->{args};
1542   $parengroup = qr{             # Matches correctly-nested groups of parens
1543                       \(
1544                       (?:
1545                        (?> [^()]* )        # Non-parens without backtracking
1546                        |
1547                        (??{ $parengroup }) # Backtrack: Group with parens
1548                       )*
1549                       \)
1550                      }x;
1551   my $expr = qr{ [^(),]* (?:$parengroup)? [^(),]* }x;
1552   $args =~ s/$s = $expr//gx;
1553
1554   print_expand "\n";
1555   print_lineno $function;
1556   print_expand $pretext
1557     . ($function->{class} ne ''
1558        ? $function->{class} . $function->{templateargs}
1559            . "::" . $function->{name}
1560        : $function->{name} . $function->{templateargs})
1561     . $args . $function->{posttext};
1562 }
1563
1564 sub print_code($)
1565 {
1566   my $codeblock = $_[0];
1567   return if check_if_printed ($codeblock);
1568   print_lineno $codeblock;
1569   print_expand $codeblock->{string};
1570 }
1571
1572 sub check_if_printed
1573 {
1574   my $codeblock = $_[0];
1575   return 1 if $codeblock->{printed};
1576   $codeblock->{printed} = 1;
1577   return 0;
1578 }
1579
1580 #############################################################################
1581
1582 #
1583 # Inline-function bookkeeping.
1584 #
1585
1586 sub lookup_by_name              # Return (list of) item(s) matching name.
1587 {
1588   my ($item, $context) = @_;
1589
1590   # Is it a class name?
1591   if (defined $classes{$item})
1592     {
1593       return $classes{$item};
1594     }
1595
1596   # Is it an include file?
1597   if (defined $includes{$item})
1598     {
1599       $includes{$item}->{inline} = 1;
1600       return $includes{$item};
1601     }
1602
1603   # Must be a function name!
1604   my ($classname, $funcname);
1605
1606   if ($item =~ /::/)
1607     {
1608       ($classname, $funcname) = split /::/, $item;
1609     }
1610   else
1611     {
1612       ($classname, $funcname) = ('' , $item);
1613     }
1614
1615   my @grepresult = grep {$_->{name} eq $funcname && $_->{inline}}
1616                          @{$classes{$classname}->{funcs}};
1617
1618   return shift @grepresult
1619     if (scalar @grepresult == 1);
1620
1621   if (scalar @grepresult == 0)
1622     {
1623       my @xgrepresult = grep {$_->{name} eq $funcname}
1624                               @{$classes{$classname}->{funcs}};
1625       die $context->{file} . ":" . $context->{line} . ": Cannot find $item;"
1626         if (scalar @xgrepresult == 0);
1627       $wno_inline && print STDERR $context->{file} . ":" . $context->{line} .
1628                                   ": warning: Cannot find inline code ".
1629                                   "for $item;\n";
1630     }
1631
1632   return @grepresult;   # Return list of matching function names.
1633 }
1634
1635 # Check if Function $function can already see Object $item in its context.
1636 sub inline_known
1637 {
1638   my ($item, $function) = @_;
1639
1640   if ($item->{type} eq "function"
1641       && $item->{hide}
1642       && ! $function->{hide})
1643     {
1644       die $function->{file} . ":" . $function->{line} .
1645         ": Nonhidden function " . funcname($function) .
1646         " depends on hidden function " . funcname($item) . " (" .
1647         ($item->{visibility} eq 'static' ? "static" : "NOEXPORT") . ")";
1648     }
1649
1650   return exists $public_inline{$item}
1651     || (($function->{visibility} eq 'private'
1652          || ($function->{class} ne ''
1653              && $classes{$function->{class}}->{section} eq "IMPLEMENTATION"))
1654         && exists $private_inline{$item})
1655     || ($function->{hide}
1656         && exists $unit_inline{$item});
1657 }
1658
1659 # Put inline function $1 and all its dependencies (given by NEEDS
1660 # directives) into @inline_order_[public/private/unit], depending on
1661 # visibility of $1.  Function handle_inline is called when printing
1662 # inline-function declarations, so the sequence of handle_inline calls
1663 # is determined by declaration-printing order.
1664 sub handle_inline
1665 {
1666   my $function = $_[0];
1667   my $class = $function->{class};
1668   my @needed = ();
1669
1670   $verbose &&
1671     print "INLINE " . funcname($function) . " NEEDS ";
1672
1673   # Add all needed items, then add my own name as well as my class
1674   # name for good measure.
1675   foreach my $item (@{$function->{needs}})
1676     {
1677       push @needed, lookup_by_name ($item, $function);
1678     }
1679
1680   push @needed, $function;
1681   unshift @needed, lookup_by_name ($class, $function)
1682     if ($class ne '');
1683
1684  NEEDEDLOOP:
1685   while (@needed)
1686     {
1687       my $object = $needed[0];
1688
1689       if (inline_known ($object, $function))
1690         {
1691           shift @needed;
1692           next;
1693         }
1694
1695       # Check for further dependencies.
1696       my @moreneeded = ();
1697
1698       if ($object->{type} eq "function" && $object->{class} ne '')
1699         {
1700           my $class = lookup_by_name ($object->{class}, $object);
1701           push @moreneeded, $class;
1702         }
1703
1704       if (defined $object->{needs})
1705         {
1706           foreach my $item (@{$object->{needs}})
1707             {
1708               my $o = lookup_by_name ($item, $object);
1709               next if ! ref $o; # Skip referenced but noninline objects
1710               push @moreneeded, $o;
1711             }
1712         }
1713
1714       # Check if we have everything that's needed for $item.
1715       foreach my $i (@moreneeded)
1716         {
1717           if (inline_known ($i, $function))
1718             {
1719               next;
1720             }
1721
1722           if ($i == $function)  # Function depends on itself!
1723             {
1724               my $callstack = "  " . funcname ($function) . "\n";;
1725               my $prev = $function;
1726               push @needed, $function;
1727               foreach my $j (@needed)
1728                 {
1729                   # $j is not part of call stack if it does not need $prev
1730                   next if ! grep {lookup_by_name ($_, $object) == $prev}
1731                                  @{$j->{needs}};
1732                   $callstack .= "  " . funcname ($j) . "\n";
1733                   $prev = $j;
1734                   last if $j == $function;
1735                 }
1736
1737               die $object->{file} . ":" . $object->{line} . ": Function " .
1738                 funcname ($object) . " NEEDS " . funcname ($i) .
1739                 ", which circularly depends on this function:\n" .
1740                 $callstack;
1741             }
1742
1743           unshift @needed, $i;
1744           next NEEDEDLOOP;
1745         }
1746
1747       $verbose && print &funcname ($object) . " ";
1748
1749       if ($function->{hide})
1750         {
1751           $unit_inline{$object} = 1;
1752           push @inline_order_unit, $object;
1753         }
1754       elsif ($function->{visibility} eq 'private'
1755              || ($class ne ''
1756                  && $classes{$class}->{section} eq "IMPLEMENTATION"))
1757         {
1758           $private_inline{$object} = 1;
1759           push @inline_order_private, $object;
1760         }
1761       else
1762         {
1763           $public_inline{$object} = 1;
1764           push @inline_order_public, $object;
1765         }
1766
1767       shift @needed;
1768     }
1769
1770   $verbose && print "\n";
1771 }
1772
1773 sub print_inlines
1774 {
1775   foreach my $object (grep {$_->{type} eq "classdef"} @_)
1776     {
1777       if ($object->{section} ne 'INTERFACE')
1778         {
1779           print_classdecl $object;
1780         }
1781     }
1782
1783   foreach my $object (grep {$_->{type} eq "function"} @_)
1784     {
1785       print_funcdef $object;
1786     }
1787 }
1788
1789 ######################################################################
1790 #
1791 # Utilities
1792 #
1793 sub funcname
1794 {
1795   my $function = $_[0];
1796
1797   return ($function->{class} ? ($function->{class} . "::") : "")
1798     . $function->{name};
1799 }