tools/sfdc/main.pl

   1 #!/usr/bin/perl -w
   2 #
   3 #     sfdc - Compile SFD files into someting useful
   4 #     Copyright (C) 2003-2004 Martin Blom <martin@blom.org>
   5 #
   6 #     This program is free software; you can redistribute it and/or
   7 #     modify it under the terms of the GNU General Public License
   8 #     as published by the Free Software Foundation; either version 2
   9 #     of the License, or (at your option) any later version.
  10 #
  11 #     This program is distributed in the hope that it will be useful,
  12 #     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 #     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 #     GNU General Public License for more details.
  15 #
  16 #     You should have received a copy of the GNU General Public License
  17 #     along with this program; if not, write to the Free Software
  18 #     Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  19
  20 use strict;
  21
  22 use IO::Handle;
  23 use Getopt::Long;
  24
  25 # The default AmigaOS GG installation of does not seem to include
  26 # Pod::Usage, so we have to provide a fallback. Ugly, but it works and
  27 # that's what counts.
  28
  29 eval {
  30     require Pod::Usage;
  31     import Pod::Usage;
  32 };
  33
  34 if ($@) {
  35     eval '
  36         # Minimal fall-back ...
  37
  38         sub pod2usage {
  39             my @params = @_;
  40
  41             my $verbose = 0;
  42             my $exitval = 0;
  43             my $message = "";
  44             my $output = \*STDERR;
  45
  46             while (@params) {
  47                 for (shift @params) {
  48                     /^-verbose$/ && do { $verbose = shift @params};
  49                     /^-exitval$/ && do { $exitval = shift @params};
  50                     /^-message$/ && do { $message = shift @params};
  51                     /^-output$/  && do { $output  = shift @params};
  52                 }
  53             }
  54
  55             print $output "$message\n" if $message;
  56             print $output "\n";
  57             print $output "Perl module Pod::Usage is missing.\n";
  58             print $output "Please refer to the sfdc documentation for usage, ".
  59                 "or install Pod::Usage.\n";
  60             exit $exitval;
  61         }
  62     ';
  63 }
  64
  65 sub parse_sfd ( $ );
  66 sub parse_proto ( $$$ );
  67 sub open_output ( $$ );
  68 sub will_close_output ( $$ );
  69 sub close_output ();
  70
  71 my @lf =
  72 [
  73  'struct Library* LibInit(struct Library* library,' .
  74  '                        BPTR seglist,' .
  75  '                        struct ExecBase* SysBase)' .
  76  '                       (d0,a0,a6)',
  77  'struct Library* LibOpen(ULONG version) (d0)',
  78  'BPTR LibClose() ()',
  79  'BPTR LibExpunge() ()',
  80  'ULONG LibNull() ()'
  81  ];
  82
  83 my @df  =
  84 [
  85  'struct Library* DevInit(struct Library* library,' .
  86  '                        BPTR seglist,' .
  87  '                        struct ExecBase* SysBase)' .
  88  '                       (d0,a0,a6)',
  89  'ULONG DevOpen(struct IORequest* ioreq,' .
  90  '              ULONG unit,' .
  91  '              ULONG flags) (a1,d0,d1)',
  92  'BPTR DevClose(struct IORequest* ioreq) (a1)',
  93  'BPTR DevExpunge() ()',
  94  'ULONG DevNull() ()',
  95  'VOID DevBeginIO(struct IORequest* ioreq) (a1)',
  96  'ULONG DevAbortIO(struct IORequest* ioreq) (a1)'
  97  ];
  98
  99 my @bf  =
 100 [
 101  'struct ClassLibrary* ClassInit(struct ClassLibrary* library,' .
 102  '                               BPTR seglist,' .
 103  '                               struct ExecBase* SysBase)' .
 104  '                              (d0,a0,a6)',
 105  'struct ClassLibrary* ClassOpen(ULONG version) (d0)',
 106  'BPTR ClassClose() ()',
 107  'BPTR ClassExpunge() ()',
 108  'ULONG ClassNull() ()',
 109  'Class* ObtainEngine() ()',
 110  ];
 111
 112 my %targets = (
 113               'generic' =>
 114                { target    => 'generic',
 115                  vectors   => { 'library' => @lf, 'device' => @df, 'boopsi' => @bf },
 116                  macros    => 'Macro',
 117                  stubs     => 'Stub',
 118                  gatestubs => 'Gate',
 119                },
 120
 121               '(\w)+(-.*)?-aros' =>
 122                { target    => 'aros',
 123                  vectors   => { 'library' => @lf, 'device' => @df, 'boopsi' => @bf },
 124                  macros    => 'MacroAROS',
 125                  stubs     => 'StubAROS',
 126                  gatestubs => 'GateAROS',
 127                  sdistubs  => 'SDIAROS'
 128                },
 129
 130               'i.86be(-pc)?-amithlon' =>
 131                { target    => 'amithlon',
 132                  vectors   => { 'library' => @lf, 'device' => @df, 'boopsi' => @bf },
 133                  macros    => 'MacroLP',
 134                  stubs     => 'StubAmithlon',
 135                  gatestubs => 'GateAmithlon'
 136                },
 137
 138               'm68k(-unknown)?-amigaos' =>
 139                { target    => 'amigaos',
 140                  vectors   => { 'library' => @lf, 'device' => @df, 'boopsi' => @bf },
 141                  macros    => 'Macro68k',
 142                  stubs     => 'Stub68k',
 143                  gatestubs => 'Gate68k'
 144                },
 145
 146               'p(ower)?pc(-unknown)?-amigaos' =>
 147                { target    => 'amigaos4',
 148                  vectors   => { 'library' => @lf, 'device' => @df, 'boopsi' => @bf },
 149                  macros    => 'MacroAOS4',
 150                  stubs     => 'StubAOS4',
 151                  gatestubs => 'GateAOS4'
 152                },
 153
 154               'p(ower)?pc(-unknown)?-morphos' =>
 155                { target    => 'morphos',
 156                  vectors   => { 'library' => @lf, 'device' => @df, 'boopsi' => @bf },
 157                  macros    => 'MacroMOS',
 158                  stubs     => 'StubMOS',
 159                  gatestubs => 'GateMOS'
 160                }
 161               );
 162
 163 my $classes;
 164
 165 ###############################################################################
 166 ### Main program ##############################################################
 167 ###############################################################################
 168
 169 Getopt::Long::Configure ("bundling");
 170
 171 my $gateprefix = '';
 172 my $help       = '0';
 173 my $libarg     = 'none';
 174 my $libprefix  = '';
 175 my $addvectors = 'none';
 176 my $man        = '0';
 177 my $mode       = 'verify';
 178 my $output     = '-';
 179 my $quiet      = '0';
 180 my $target     = 'm68k-unknown-amigaos';
 181 my $version    = '0';
 182
 183 GetOptions ('addvectors=s' => \$addvectors,
 184             'gateprefix=s' => \$gateprefix,
 185             'help|h'       => \$help,
 186             'libarg=s'     => \$libarg,
 187             'libprefix=s'  => \$libprefix,
 188             'man'          => \$man,
 189             'mode=s'       => \$mode,
 190             'output|o=s'   => \$output,
 191             'quiet|q'      => \$quiet,
 192             'target=s'     => \$target,
 193             'version|v'    => \$version) or exit 10;
 194
 195 if ($version) {
 196     print STDERR "sfdc SFDC_VERSION (SFDC_DATE)\n";
 197     print STDERR "Copyright (C) 2003-2004 Martin Blom <martin\@blom.org>\n";
 198     print STDERR "This is free software; " .
 199         "see the source for copying conditions.\n";
 200     exit 0;
 201 }
 202
 203 if ($help) {
 204     pod2usage (-verbose => 1,
 205                -exitval => 0,
 206                -output => \*STDOUT);
 207 }
 208
 209 if ($man) {
 210     pod2usage (-verbose => 3,
 211                -exitval => 0);
 212     exit 0;
 213 }
 214
 215 if ($#ARGV < 0) {
 216     pod2usage (-message => "No SFD file specified.",
 217                -verbose => 0,
 218                -exitval => 10);
 219 }
 220
 221 $mode = lc $mode;
 222
 223 if (!($mode =~ /^(clib|dump|fd|libproto|lvo|functable|macros|proto|pragmas|stubs|gateproto|gatestubs|sdiproto|sdistubs|verify)$/)) {
 224     pod2usage (-message => "Unknown mode specified. Use --help for a list.",
 225                -verbose => 0,
 226                -exitval => 10);
 227 }
 228
 229 if ($libarg !~ /^(first|last|none)$/) {
 230     pod2usage (-message => "Unknown libarg specified. Use --help for a list.",
 231                -verbose => 0,
 232                -exitval => 10);
 233 }
 234
 235 if ($addvectors !~ /^(none|library|device|boopsi)$/) {
 236     pod2usage (-message => "Unknown addvectors value. Use --help for a list.",
 237                -verbose => 0,
 238                -exitval => 10);
 239 }
 240
 241 check_target: {
 242     foreach my $target_regex (keys %targets) {
 243         if ($target =~ /^$target_regex$/) {
 244             $classes = $targets{$target_regex};
 245             last check_target;
 246         }
 247     }
 248
 249     pod2usage (-message => "Unknown target specified. Use --help for a list.",
 250                -verbose => 0,
 251                -exitval => 10);
 252 }
 253
 254 # Save old STDOUT
 255
 256 open( OLDOUT, ">&STDOUT" );
 257
 258 for my $i ( 0 .. $#ARGV ) {
 259     my $sfd = parse_sfd ($ARGV[$i]);
 260     my $num = $#{$$sfd{'prototypes'}};
 261
 262     my $obj;
 263
 264     for ($mode) {
 265         /^clib$/ && do {
 266             $obj = CLib->new( sfd => $sfd );
 267             last;
 268         };
 269
 270         /^fd$/ && do {
 271             $obj = FD->new( sfd => $sfd );
 272             last;
 273         };
 274
 275         /^dump$/ && do {
 276             $obj = Dump->new( sfd => $sfd );
 277             last;
 278         };
 279
 280         /^libproto$/ && do {
 281             $obj = Gate->new( sfd => $sfd,
 282                               proto => 0,
 283                               libproto => 1 );
 284             last;
 285         };
 286
 287         /^lvo$/ && do {
 288             $obj = LVO->new( sfd => $sfd );
 289             last;
 290         };
 291
 292         /^functable$/ && do {
 293             $obj = FuncTable->new( sfd => $sfd );
 294             last;
 295         };
 296
 297         /^macros$/ && do {
 298             $obj = $$classes{'macros'}->new( sfd => $sfd );
 299
 300             # By tradition, the functions in the macro files are sorted
 301 #           @{$$sfd{'prototypes'}} = sort {
 302 #               $$a{'funcname'} cmp $$b{'funcname'}
 303 #           } @{$$sfd{'prototypes'}};
 304             last;
 305         };
 306
 307         /^proto$/ && do {
 308             $obj = Proto->new( sfd => $sfd );
 309             last;
 310         };
 311
 312         /^pragmas$/ && do {
 313             $obj = SASPragmas->new( sfd => $sfd );
 314             last;
 315         };
 316
 317         /^verify$/ && do {
 318             $obj = Verify->new( sfd => $sfd );
 319             last;
 320         };
 321
 322         /^stubs$/ && do {
 323             $obj = $$classes{'stubs'}->new( sfd => $sfd );
 324
 325             # By tradition, the functions in the stub files are sorted
 326 #           @{$$sfd{'prototypes'}} = sort {
 327 #               $$a{'funcname'} cmp $$b{'funcname'}
 328 #           } @{$$sfd{'prototypes'}};
 329             last;
 330         };
 331
 332         /^gateproto$/ && do {
 333             $obj = $$classes{'gatestubs'}->new( sfd => $sfd,
 334                                                 proto => 1,
 335                                                 libproto => 0);
 336             last;
 337         };
 338
 339         /^gatestubs$/ && do {
 340             $obj = $$classes{'gatestubs'}->new( sfd => $sfd,
 341                                                 proto => 0,
 342                                                 libproto => 0);
 343
 344             last;
 345         };
 346
 347         /^sdiproto$/ && do {
 348             $obj = $$classes{'sdistubs'}->new( sfd => $sfd,
 349                                                 proto => 1);
 350
 351             last;
 352         };
 353
 354         /^sdistubs$/ && do {
 355             $obj = $$classes{'sdistubs'}->new( sfd => $sfd,
 356                                                 proto => 0 );
 357
 358             last;
 359         };
 360
 361         die "Unknown mode specified: " . $mode;
 362     }
 363
 364
 365     for my $j ( 0 .. $num + 1) {
 366         my $prototype = $$sfd{'prototypes'}[$j];
 367         my $funcname  = $$prototype{'funcname'};
 368
 369         if (!defined ($funcname) || will_close_output ($sfd, $funcname) != 0) {
 370             $obj->footer ();
 371         }
 372
 373         if ($j > $num) {
 374             last;
 375         }
 376
 377         if (open_output ($sfd, $funcname) != 0) {
 378             $obj->header ();
 379         }
 380
 381         $obj->function (prototype => $prototype);
 382     }
 383
 384     close_output ();
 385 }
 386
 387 if (!$quiet) {
 388     print STDERR "All done.\n";
 389 }
 390
 391 open (STDOUT, ">&OLDOUT");
 392 close (OLDOUT);
 393
 394 exit 0;
 395
 396
 397
 398
 399
 400
 401 ###############################################################################
 402 ### Subroutines ###############################################################
 403 ###############################################################################
 404
 405
 406 ### parse_sfd: Parse an SFD file hand return a hash record #####################
 407
 408 sub parse_sfd ( $ ) {
 409     my $file = shift;
 410     local *SFD;
 411
 412     my $type      = 'function';
 413     my $last_type = $type;
 414     my $private   = 0;
 415     my $bias      = 0;
 416     my $version   = 1;
 417     my $comment   = '';
 418
 419     my $result = {
 420         copyright  => 'Copyright © 2001 Amiga, Inc.',
 421         id         => '',
 422         libname    => '',
 423         base       => '',
 424         basetype   => 'struct Library *',
 425 #       includes   => (),
 426 #       typedefs   => (),
 427 #       prototypes => (),
 428         basename   => '',
 429         BASENAME   => '',
 430         Basename   => ''
 431     };
 432
 433     # Why do I need this????
 434     $$result{'prototypes'} = ();
 435     $$result{'includes'}   = ();
 436     $$result{'typedefs'}   = ();
 437
 438     if ($addvectors ne 'none') {
 439         push @{$$result{'includes'}}, '<dos/dos.h>';
 440         push @{$$result{'includes'}}, '<exec/execbase.h>';
 441
 442         if ($addvectors eq 'device') {
 443             push @{$$result{'includes'}}, '<exec/io.h>';
 444         }
 445         elsif ($addvectors eq 'boopsi') {
 446             push @{$$result{'includes'}}, '<intuition/classes.h>';
 447         }
 448
 449         for my $i ( 0 .. $#{$classes->{vectors}->{$addvectors}} ) {
 450             push @{$$result{'prototypes'}}, {
 451                 type    => 'function',
 452                 subtype => $addvectors,
 453                 value   => $classes->{vectors}->{$addvectors}[$i],
 454                 line    => 0,
 455                 private => 0,
 456                 bias    => 6 * $i,
 457                 version => 0,
 458                 comment => ''
 459                 };
 460         }
 461     }
 462
 463
 464     my $proto_line = '';
 465     my %proto;
 466
 467     if (!$quiet) {
 468         ( my $fn = $file ) =~ s,.*[/\\](.*),$1,;
 469         print STDERR "Processing SFD file '$fn'.\n";
 470         STDERR->flush();
 471     }
 472
 473     unless (open (SFD, "<" . $file)) {
 474         print STDERR "Unable to open file '$file'.\n";
 475         die;
 476     };
 477
 478     my $line_no = 0;
 479
 480   LINE:
 481     while (my $line = <SFD>) {
 482
 483         ++$line_no;
 484
 485         for ($line) {
 486             /^==copyright\s/ && do {
 487                 ( $$result{'copyright'} = $_ ) =~ s/==copyright\s+(.*)\s*/$1/;
 488                 last;
 489             };
 490
 491             /^==id\s+/ && do {
 492                 ( $$result{'id'} = $_ ) =~ s/==id\s+(.*)\s*/$1/;
 493                 last;
 494             };
 495
 496             /^==libname\s+/ && do {
 497                 ( $$result{'libname'} = $_ ) =~ s/==libname\s+(.*)\s*/$1/;
 498                 last;
 499             };
 500
 501             /^==base\s+/ && do {
 502                 ( $$result{'base'} = $_ ) =~ s/==base\s+_?(.*)\s*/$1/;
 503                 last;
 504             };
 505
 506             /^==basetype\s+/ && do {
 507                 ( $$result{'basetype'} = $_ ) =~ s/==basetype\s+(.*)\s*/$1/;
 508                 last;
 509             };
 510
 511             /^==include\s+/ && do {
 512                 ( my $inc = $_ ) =~ s/==include\s+(.*)\s*/$1/;
 513
 514                 push @{$$result{'includes'}}, $inc;
 515                 last;
 516             };
 517
 518             /^==typedef\s+/ && do {
 519                 ( my $td = $_ ) =~ s/==typedef\s+(.*)\s*$/$1/;
 520
 521                 push @{$$result{'typedefs'}}, $td;
 522                 last;
 523             };
 524
 525             /^==bias\s+/ && do {
 526                 ( $bias = $_ ) =~ s/==bias\s+(.*)\s*/$1/;
 527                 last;
 528             };
 529
 530             /^==reserve\s+/ && do {
 531                 ( my $reserve = $_ ) =~ s/==reserve\s+(.*)\s*/$1/;
 532
 533                 $bias += 6 * $reserve;
 534                 last;
 535             };
 536
 537             /^==alias\s*$/ && do {
 538                 # Move back again
 539                 $type = $last_type;
 540                 $bias -= 6;
 541                 last;
 542             };
 543
 544             /^==varargs\s*$/ && do {
 545                 $type = 'varargs';
 546                 # Move back again
 547                 $bias -= 6;
 548                 last;
 549             };
 550
 551             /^==private\s*$/ && do {
 552                 $private = 1;
 553                 last;
 554             };
 555
 556             /^==public\s*$/ && do {
 557                 $private = 0;
 558                 last;
 559             };
 560
 561             /^==version\s+/ && do {
 562                 ( $version = $_ ) =~ s/==version\s+(.*)\s*/$1/;
 563                 last;
 564             };
 565
 566             /^==end\s*$/ && do {
 567                 last LINE;
 568             };
 569
 570             /^\*/ && do {
 571                 ( my $cmt = $_ ) =~ s/^\*(.*)\s*/$1/;
 572
 573                 $comment .= ($comment eq '' ? "" : "\n" ) . $cmt;
 574                 last;
 575             };
 576
 577             /^[^=*\n]/ && do {
 578                 # Strip whitespaces and append
 579                 $line =~ s/\s*(.*)\s*/$1/;
 580                 $proto_line .= $line . " ";
 581                 last;
 582             };
 583
 584             /^\s*$/ && do {
 585                 # Skip blank lines
 586                 last;
 587             };
 588
 589             # If we get here, we found a line we don't understand
 590             print STDERR "Unable to parse line $line_no in SFD file" .
 591                 " '$file'. The line looks like this:\n" . $line ;
 592             die;
 593         };
 594
 595         if ( $proto_line =~
 596              /.*[A-Za-z0-9_]+\s*\(.*\).*\(((base|sysv|autoreg|[\saAdD][0-7]-?),?)*\)\s*$/
 597              ) {
 598
 599             if ($proto_line =~ /.*\(.*[0-7]-.*\)\s*$/) {
 600                 if ($$classes{'target'} ne 'amigaos') {
 601                     print STDERR "Warning: Multiregister functions are m68k only.\n";
 602                 }
 603                 $proto_line =~ s/([da][0-7])-[da][0-7]/$1/g;
 604             }
 605 #           else {
 606                 push @{$$result{'prototypes'}}, {
 607                     type    => $type,
 608                     subtype => '',
 609                     value   => $proto_line,
 610                     line    => $line_no,
 611                     private => $private,
 612                     bias    => $bias,
 613                     version => $version,
 614                     comment => $comment
 615                     };
 616
 617                 $comment    = '';
 618 #           }
 619
 620             $last_type  = $type;
 621             $type       = 'function';
 622             $proto_line = '';
 623             $bias += 6;
 624         }
 625     }
 626
 627     if( $proto_line ne '' ) {
 628         # If $proto_line isn't empty, we couldn't parse it
 629         die "Unhanled proto '" . $proto_line . "'\n";
 630     }
 631
 632     close (SFD);
 633
 634     # Now parse the prototypes
 635     my $real_funcname  = '';
 636     my $real_prototype = {};
 637     my $varargs_type   = '';
 638
 639     for my $i ( 0 .. $#{$$result{'prototypes'}} ) {
 640         my $prototype = $$result{'prototypes'}[$i];
 641
 642         if ($$prototype{'type'} eq 'varargs') {
 643             $$prototype{'real_funcname'}  = $real_funcname;
 644             $$prototype{'real_prototype'} = $real_prototype;
 645         }
 646         else {
 647             $$prototype{'real_funcname'}  = '';
 648             $$prototype{'real_prototype'} = '';
 649         }
 650
 651         parse_proto ($result, $prototype, $varargs_type);
 652
 653         if ($$prototype{'type'} eq 'function') {
 654             $varargs_type = $$prototype{'argtypes'}[$#{$$prototype{'argtypes'}}];
 655         }
 656
 657         if ($$prototype{'type'} eq 'function') {
 658             $real_funcname  = $$prototype{'funcname'};
 659             $real_prototype = $prototype;
 660         }
 661     };
 662
 663     # Create some other variables
 664
 665     ( $$result{'basename'} = $file ) =~ s:.*/(\w+?)_lib\.sfd:$1:;
 666
 667     if ($$result{'basename'} eq '') {
 668         ( $$result{'basename'} = $$result{'libname'} ) =~ s/(.*)\.\w+/$1/ or do {
 669             print STDERR "Unable to find or guess base name.\n";
 670             print STDERR "Please add \"==libname module_name\" to SFD file.\n";
 671             die;
 672         };
 673
 674         # Fake the CIA libname
 675         if ($$result{'basename'} eq "cia") {
 676             $$result{'libname'} = "ciaX.resource";
 677         }
 678         else {
 679             $$result{'libname'} = $$result{'basename'} . ".library";
 680         }
 681     }
 682
 683     # Fake the Workbench basename
 684     if ($$result{'basename'} eq "workbench") {
 685         $$result{'basename'} = "wb";
 686     }
 687
 688     $$result{'basename'} =~ s/-/_/g;
 689     $$result{'basename'} =~ s/\//_/g;
 690     $$result{'basename'} =~ s/\./_/g;
 691     $$result{'basename'} = lc $$result{'basename'};
 692     $$result{'BASENAME'} = uc $$result{'basename'};
 693     $$result{'Basename'} = ucfirst $$result{'basename'};
 694     ($result->{BaseName} = $result->{base}) =~ s/Base//;
 695
 696     return $result;
 697 }
 698
 699
 700 ### parse_proto: Parse a single function prototype  ###########################
 701
 702 sub parse_proto ( $$$ ) {
 703     my $sfd          = shift;
 704     my $prototype    = shift;
 705     my $varargs_type = shift;
 706
 707     my $return;
 708     my $name;
 709     my $arguments;
 710     my $registers;
 711
 712     if (!(($return,undef,undef,$name,$arguments,$registers) =
 713           ( $$prototype{'value'} =~
 714             /^((struct\s+)?(\w+\s*?)+\**)\s*(\w+)\s*\((.*)\)\s*\((.*)\).*/ ))) {
 715         print STDERR "Unable to parse prototype on line $$prototype{'line'}.\n";
 716         die;
 717     }
 718
 719     # Nuke whitespaces from the register specification
 720     $registers =~ s/\s//;
 721
 722     $$prototype{'return'}   = $return;
 723     $$prototype{'funcname'} = $name;
 724
 725     $$prototype{'numargs'}  = 0;
 726     $$prototype{'numregs'}  = 0;
 727
 728     @{$$prototype{'regs'}}        = ();
 729     @{$$prototype{'args'}}        = ();
 730     @{$$prototype{'___args'}}     = ();
 731     @{$$prototype{'argnames'}}    = ();
 732     @{$$prototype{'___argnames'}} = ();
 733     @{$$prototype{'argtypes'}}    = ();
 734
 735     if ($arguments =~ /^(void|VOID)$/) {
 736         $arguments = "";
 737     }
 738
 739     my @args = split(/,/,$arguments);
 740
 741     # Fix function pointer arguments and build $$prototype{'args'}
 742
 743     my $par_cnt = 0;
 744     foreach my $arg (@args) {
 745         # Strip whitespaces
 746         $arg =~ s/\s*(.*?)\s*/$1/;
 747
 748         if ($par_cnt != 0) {
 749             my $old_arg = pop @{$$prototype{'args'}};
 750
 751             push @{$$prototype{'args'}}, $old_arg . "," . $arg;
 752         }
 753         else {
 754             push @{$$prototype{'args'}}, $arg;
 755         }
 756
 757         # Count parentheses (a function pointer arguments is processed
 758         # when $par_cnt is 0).
 759         $par_cnt += ( $arg =~ tr/\(/\(/ );
 760         $par_cnt -= ( $arg =~ tr/\)/\)/ );
 761     }
 762
 763     $$prototype{'numargs'} = $#{$$prototype{'args'}} + 1;
 764
 765     if ($registers =~ /sysv/) {
 766         $prototype->{type} = 'cfunction';
 767         $prototype->{nb}   = 1;
 768     }
 769     elsif ($registers =~ /autoreg/) {
 770         my $a_cnt = 0;
 771         my $d_cnt = 0;
 772         foreach my $arg (@{$$prototype{'args'}}) {
 773             if ($arg =~ /\*/) {
 774                 push @{$$prototype{'regs'}}, "a$a_cnt";
 775                 $a_cnt++;
 776             }
 777             else {
 778                 push @{$$prototype{'regs'}}, "d$d_cnt";
 779                 $d_cnt++;
 780             }
 781         }
 782
 783         $prototype->{numregs} = $#{$$prototype{'regs'}} + 1;
 784         $prototype->{nb}      = $sfd->{base} eq '';
 785     }
 786     else {
 787         # Split regs and make them lower case
 788         @{$$prototype{'regs'}} = split(/,/,lc $registers);
 789         $prototype->{numregs} = $#{$$prototype{'regs'}} + 1;
 790         $prototype->{nb}      = $sfd->{base} eq '' || $registers =~ /a6/;
 791     }
 792
 793     $$prototype{'nr'} = $$prototype{'return'} =~ /^(VOID|void)$/;
 794
 795     # varargs sub types:
 796     #   printfcall: LONG Printf( STRPTR format, ... );
 797     #     All varargs are optional
 798     #   tagcall:    BOOL AslRequestTags( APTR requester, Tag Tag1, ... );
 799     #     First vararg is a Tag, then a TAG_DONE terminated tag list
 800     #   methodcall: ULONG DoGadgetMethod( ... ULONG message, ...);
 801     #     First vararg is required.
 802
 803     if ($prototype->{type} eq 'varargs') {
 804         if ($varargs_type =~
 805             /^\s*(const|CONST)?\s*struct\s+TagItem\s*\*\s*$/ ) {
 806             $prototype->{subtype} = 'tagcall';
 807
 808             if ($prototype->{numargs} == $prototype->{numregs}) {
 809                 if (!$quiet) {
 810                     print STDERR "Warning: Adding missing Tag argument to " .
 811                         $prototype->{funcname} . "()\n";
 812                 }
 813
 814                 my $last = pop @{$prototype->{args}};
 815                 push @{$prototype->{args}}, "Tag _tag1" ;
 816                 push @{$prototype->{args}}, $last;
 817
 818                 ++$prototype->{numargs};
 819             }
 820         }
 821         else {
 822             if ($prototype->{numargs} == $prototype->{numregs}) {
 823                 $prototype->{subtype} = 'printfcall';
 824             }
 825             elsif ($prototype->{numargs} == $prototype->{numregs} + 1) {
 826                 $prototype->{subtype} = 'methodcall';
 827             }
 828         }
 829     }
 830     elsif ($prototype->{type} eq 'cfunction') {
 831         foreach (split(/,/,lc $registers)) {
 832             /^sysv$/ && do {
 833                 $prototype->{subtype} = 'sysv';
 834                 next;
 835             };
 836
 837             /^base$/ && do {
 838                 if ($sfd->{base} eq '') {
 839                     printf STDERR "$prototype->{funcname}: " .
 840                         "Library has no base!\n";
 841                     die;
 842                 }
 843
 844                 $prototype->{nb} = 0;
 845                 next;
 846             };
 847         }
 848     }
 849
 850
 851
 852     # Make sure we have the same number of arguments as registers, or,
 853     # if this is a varargs function, possible one extra, á la "MethodID, ...".
 854     # Tagcalls always have one extra, á la "Tag, ...".
 855
 856     if (($prototype->{type} eq 'varargs' &&
 857          $prototype->{subtype} eq 'tagcall' &&
 858          $prototype->{numargs} != $prototype->{numregs} + 1 ) ||
 859
 860         ($prototype->{type} eq 'varargs' &&
 861          $prototype->{subtype} eq 'printfcall' &&
 862          $prototype->{numargs} != $prototype->{numregs}) ||
 863
 864         ($prototype->{type} eq 'varargs' &&
 865          $prototype->{subtype} eq 'methodcall' &&
 866          $prototype->{numargs} != $prototype->{numregs} + 1) ||
 867
 868         ($prototype->{type} eq 'function' &&
 869          $prototype->{numargs} != $prototype->{numregs})) {
 870
 871         print STDERR "Failed to parse arguments/registers on SFD " .
 872             "line $$prototype{'line'}:\n$$prototype{'value'}\n";
 873         print STDERR "The number of arguments doesn't match " .
 874             "the number of registers (+1 if tagcall).\n";
 875         die;
 876     }
 877
 878     my $type = '';
 879
 880     foreach my $arg (@{$$prototype{'args'}}) {
 881         my $name    = '';
 882         my $___name = '';
 883         my $___arg  = '';
 884
 885         # MorhOS includes use __CLIB_PROTOTYPE for some reason ...
 886         if ($arg =~ /.*\(.*?\)\s*(__CLIB_PROTOTYPE)?\(.*\)/) {
 887             my $type1;
 888             my $type2;
 889
 890             ($type1, $name, $type2) =
 891                 ( $arg =~ /^\s*(.*)\(\s*\*\s*(\w+)\s*\)\s*(\w*\(.*\))\s*/ );
 892             $type = "$type1(*)$type2";
 893             $___name = "___$name";
 894             $___arg = "$type1(*___$name) $type2";
 895         }
 896         elsif ($arg !~ /^\.\.\.$/) {
 897             ($type, $name) = ( $arg =~ /^\s*(.*?[\s*]*?)\s*(\w+)\s*$/ );
 898             $___name = "___$name";
 899             $___arg = "$type ___$name";
 900         }
 901         else {
 902             if ($prototype->{type} eq 'varargs') {
 903                 $type = $varargs_type;
 904             }
 905             else {
 906                 # Unknown type
 907 #               $type = "void*";
 908                 $type = "...";
 909             }
 910             $name = '...';
 911             $___name = '...';
 912             $___arg = '...';
 913         }
 914
 915         if ($type eq '' || $name eq '' ) {
 916             print STDERR "Type or name missing from '$arg'.\n";
 917             die;
 918         }
 919
 920         push @{$$prototype{'___args'}}, $___arg;
 921         push @{$$prototype{'argnames'}}, $name;
 922         push @{$$prototype{'___argnames'}}, $___name;
 923
 924         push @{$$prototype{'argtypes'}}, $type;
 925     }
 926 }
 927
 928
 929
 930 sub BEGIN {
 931     my $old_output = '';
 932
 933
 934 ### close_output: Close the output file if necessary  #########################
 935
 936     sub close_output () {
 937         close (STDOUT);
 938         $old_output = '';
 939     }
 940
 941
 942 ### check_output: Check if the file will be reopended by open_output ##########
 943
 944     sub will_close_output ( $$ ) {
 945         my $sfd      = shift;
 946         my $function = shift;
 947
 948         my $new_output = $output;
 949
 950         $new_output =~ s/%f/$function/;
 951         $new_output =~ s/%b/$$sfd{'base'}/;
 952         $new_output =~ s/%l/$$sfd{'libname'}/;
 953         $new_output =~ s/%n/$$sfd{'basename'}/;
 954
 955         if( $old_output ne '' &&
 956             $new_output ne $old_output ) {
 957             return 1;
 958         }
 959         else {
 960             return 0;
 961         }
 962     }
 963
 964 ### open_output: (Re)open the output file if necessary  #######################
 965
 966     sub open_output ( $$ ) {
 967         my $sfd      = shift;
 968         my $function = shift;
 969
 970         my $new_output = $output;
 971
 972         $new_output =~ s/%f/$function/;
 973         $new_output =~ s/%b/$$sfd{'base'}/;
 974         $new_output =~ s/%l/$$sfd{'libname'}/;
 975         $new_output =~ s/%n/$$sfd{'basename'}/;
 976
 977         if( $new_output ne $old_output ) {
 978
 979             close_output ();
 980
 981             if ($new_output eq '-') {
 982                 open (STDOUT, ">&OLDOUT") or die;
 983             }
 984             else {
 985                 open (STDOUT, ">" . $new_output) or die;
 986
 987                 if (!$quiet) {
 988                     print STDERR "Writing to '$new_output'\n";
 989                 }
 990             }
 991
 992             $old_output = $new_output;
 993
 994             return 1;
 995         }
 996         else {
 997             return 0;
 998         }
 999     }
1000 }