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'} =~ s/@/_/g;
 692     $$result{'basename'} = lc $$result{'basename'};
 693     $$result{'BASENAME'} = uc $$result{'basename'};
 694     $$result{'Basename'} = ucfirst $$result{'basename'};
 695     ($result->{BaseName} = $result->{base}) =~ s/Base//;
 696
 697     return $result;
 698 }
 699
 700
 701 ### parse_proto: Parse a single function prototype  ###########################
 702
 703 sub parse_proto ( $$$ ) {
 704     my $sfd          = shift;
 705     my $prototype    = shift;
 706     my $varargs_type = shift;
 707
 708     my $return;
 709     my $name;
 710     my $arguments;
 711     my $registers;
 712
 713     if (!(($return,undef,undef,$name,$arguments,$registers) =
 714           ( $$prototype{'value'} =~
 715             /^((struct\s+)?(\w+\s*?)+\**)\s*(\w+)\s*\((.*)\)\s*\((.*)\).*/ ))) {
 716         print STDERR "Unable to parse prototype on line $$prototype{'line'}.\n";
 717         die;
 718     }
 719
 720     # Nuke whitespaces from the register specification
 721     $registers =~ s/\s//;
 722
 723     $$prototype{'return'}   = $return;
 724     $$prototype{'funcname'} = $name;
 725
 726     $$prototype{'numargs'}  = 0;
 727     $$prototype{'numregs'}  = 0;
 728
 729     @{$$prototype{'regs'}}        = ();
 730     @{$$prototype{'args'}}        = ();
 731     @{$$prototype{'___args'}}     = ();
 732     @{$$prototype{'argnames'}}    = ();
 733     @{$$prototype{'___argnames'}} = ();
 734     @{$$prototype{'argtypes'}}    = ();
 735
 736     if ($arguments =~ /^(void|VOID)$/) {
 737         $arguments = "";
 738     }
 739
 740     my @args = split(/,/,$arguments);
 741
 742     # Fix function pointer arguments and build $$prototype{'args'}
 743
 744     my $par_cnt = 0;
 745     foreach my $arg (@args) {
 746         # Strip whitespaces
 747         $arg =~ s/\s*(.*?)\s*/$1/;
 748
 749         if ($par_cnt != 0) {
 750             my $old_arg = pop @{$$prototype{'args'}};
 751
 752             push @{$$prototype{'args'}}, $old_arg . "," . $arg;
 753         }
 754         else {
 755             push @{$$prototype{'args'}}, $arg;
 756         }
 757
 758         # Count parentheses (a function pointer arguments is processed
 759         # when $par_cnt is 0).
 760         $par_cnt += ( $arg =~ tr/\(/\(/ );
 761         $par_cnt -= ( $arg =~ tr/\)/\)/ );
 762     }
 763
 764     $$prototype{'numargs'} = $#{$$prototype{'args'}} + 1;
 765
 766     if ($registers =~ /sysv/) {
 767         $prototype->{type} = 'cfunction';
 768         $prototype->{nb}   = 1;
 769     }
 770     elsif ($registers =~ /autoreg/) {
 771         my $a_cnt = 0;
 772         my $d_cnt = 0;
 773         foreach my $arg (@{$$prototype{'args'}}) {
 774             if ($arg =~ /\*/) {
 775                 push @{$$prototype{'regs'}}, "a$a_cnt";
 776                 $a_cnt++;
 777             }
 778             else {
 779                 push @{$$prototype{'regs'}}, "d$d_cnt";
 780                 $d_cnt++;
 781             }
 782         }
 783
 784         $prototype->{numregs} = $#{$$prototype{'regs'}} + 1;
 785         $prototype->{nb}      = $sfd->{base} eq '';
 786     }
 787     else {
 788         # Split regs and make them lower case
 789         @{$$prototype{'regs'}} = split(/,/,lc $registers);
 790         $prototype->{numregs} = $#{$$prototype{'regs'}} + 1;
 791         $prototype->{nb}      = $sfd->{base} eq '' || $registers =~ /a6/;
 792     }
 793
 794     $$prototype{'nr'} = $$prototype{'return'} =~ /^(VOID|void)$/;
 795
 796     # varargs sub types:
 797     #   printfcall: LONG Printf( STRPTR format, ... );
 798     #     All varargs are optional
 799     #   tagcall:    BOOL AslRequestTags( APTR requester, Tag Tag1, ... );
 800     #     First vararg is a Tag, then a TAG_DONE terminated tag list
 801     #   methodcall: ULONG DoGadgetMethod( ... ULONG message, ...);
 802     #     First vararg is required.
 803
 804     if ($prototype->{type} eq 'varargs') {
 805         if ($varargs_type =~
 806             /^\s*(const|CONST)?\s*struct\s+TagItem\s*\*\s*$/ ) {
 807             $prototype->{subtype} = 'tagcall';
 808
 809             if ($prototype->{numargs} == $prototype->{numregs}) {
 810                 if (!$quiet) {
 811                     print STDERR "Warning: Adding missing Tag argument to " .
 812                         $prototype->{funcname} . "()\n";
 813                 }
 814
 815                 my $last = pop @{$prototype->{args}};
 816                 push @{$prototype->{args}}, "Tag _tag1" ;
 817                 push @{$prototype->{args}}, $last;
 818
 819                 ++$prototype->{numargs};
 820             }
 821         }
 822         else {
 823             if ($prototype->{numargs} == $prototype->{numregs}) {
 824                 $prototype->{subtype} = 'printfcall';
 825             }
 826             elsif ($prototype->{numargs} == $prototype->{numregs} + 1) {
 827                 $prototype->{subtype} = 'methodcall';
 828             }
 829         }
 830     }
 831     elsif ($prototype->{type} eq 'cfunction') {
 832         foreach (split(/,/,lc $registers)) {
 833             /^sysv$/ && do {
 834                 $prototype->{subtype} = 'sysv';
 835                 next;
 836             };
 837
 838             /^base$/ && do {
 839                 if ($sfd->{base} eq '') {
 840                     printf STDERR "$prototype->{funcname}: " .
 841                         "Library has no base!\n";
 842                     die;
 843                 }
 844
 845                 $prototype->{nb} = 0;
 846                 next;
 847             };
 848         }
 849     }
 850
 851
 852
 853     # Make sure we have the same number of arguments as registers, or,
 854     # if this is a varargs function, possible one extra, á la "MethodID, ...".
 855     # Tagcalls always have one extra, á la "Tag, ...".
 856
 857     if (($prototype->{type} eq 'varargs' &&
 858          $prototype->{subtype} eq 'tagcall' &&
 859          $prototype->{numargs} != $prototype->{numregs} + 1 ) ||
 860
 861         ($prototype->{type} eq 'varargs' &&
 862          $prototype->{subtype} eq 'printfcall' &&
 863          $prototype->{numargs} != $prototype->{numregs}) ||
 864
 865         ($prototype->{type} eq 'varargs' &&
 866          $prototype->{subtype} eq 'methodcall' &&
 867          $prototype->{numargs} != $prototype->{numregs} + 1) ||
 868
 869         ($prototype->{type} eq 'function' &&
 870          $prototype->{numargs} != $prototype->{numregs})) {
 871
 872         print STDERR "Failed to parse arguments/registers on SFD " .
 873             "line $$prototype{'line'}:\n$$prototype{'value'}\n";
 874         print STDERR "The number of arguments doesn't match " .
 875             "the number of registers (+1 if tagcall).\n";
 876         die;
 877     }
 878
 879     my $type = '';
 880
 881     foreach my $arg (@{$$prototype{'args'}}) {
 882         my $name    = '';
 883         my $___name = '';
 884         my $___arg  = '';
 885
 886         # MorhOS includes use __CLIB_PROTOTYPE for some reason ...
 887         if ($arg =~ /.*\(.*?\)\s*(__CLIB_PROTOTYPE)?\(.*\)/) {
 888             my $type1;
 889             my $type2;
 890
 891             ($type1, $name, $type2) =
 892                 ( $arg =~ /^\s*(.*)\(\s*\*\s*(\w+)\s*\)\s*(\w*\(.*\))\s*/ );
 893             $type = "$type1(*)$type2";
 894             $___name = "___$name";
 895             $___arg = "$type1(*___$name) $type2";
 896         }
 897         elsif ($arg !~ /^\.\.\.$/) {
 898             ($type, $name) = ( $arg =~ /^\s*(.*?[\s*]*?)\s*(\w+)\s*$/ );
 899             $___name = "___$name";
 900             $___arg = "$type ___$name";
 901         }
 902         else {
 903             if ($prototype->{type} eq 'varargs') {
 904                 $type = $varargs_type;
 905             }
 906             else {
 907                 # Unknown type
 908 #               $type = "void*";
 909                 $type = "...";
 910             }
 911             $name = '...';
 912             $___name = '...';
 913             $___arg = '...';
 914         }
 915
 916         if ($type eq '' || $name eq '' ) {
 917             print STDERR "Type or name missing from '$arg'.\n";
 918             die;
 919         }
 920
 921         push @{$$prototype{'___args'}}, $___arg;
 922         push @{$$prototype{'argnames'}}, $name;
 923         push @{$$prototype{'___argnames'}}, $___name;
 924
 925         push @{$$prototype{'argtypes'}}, $type;
 926     }
 927 }
 928
 929
 930
 931 sub BEGIN {
 932     my $old_output = '';
 933
 934
 935 ### close_output: Close the output file if necessary  #########################
 936
 937     sub close_output () {
 938         close (STDOUT);
 939         $old_output = '';
 940     }
 941
 942
 943 ### check_output: Check if the file will be reopended by open_output ##########
 944
 945     sub will_close_output ( $$ ) {
 946         my $sfd      = shift;
 947         my $function = shift;
 948
 949         my $new_output = $output;
 950
 951         $new_output =~ s/%f/$function/;
 952         $new_output =~ s/%b/$$sfd{'base'}/;
 953         $new_output =~ s/%l/$$sfd{'libname'}/;
 954         $new_output =~ s/%n/$$sfd{'basename'}/;
 955
 956         if( $old_output ne '' &&
 957             $new_output ne $old_output ) {
 958             return 1;
 959         }
 960         else {
 961             return 0;
 962         }
 963     }
 964
 965 ### open_output: (Re)open the output file if necessary  #######################
 966
 967     sub open_output ( $$ ) {
 968         my $sfd      = shift;
 969         my $function = shift;
 970
 971         my $new_output = $output;
 972
 973         $new_output =~ s/%f/$function/;
 974         $new_output =~ s/%b/$$sfd{'base'}/;
 975         $new_output =~ s/%l/$$sfd{'libname'}/;
 976         $new_output =~ s/%n/$$sfd{'basename'}/;
 977
 978         if( $new_output ne $old_output ) {
 979
 980             close_output ();
 981
 982             if ($new_output eq '-') {
 983                 open (STDOUT, ">&OLDOUT") or die;
 984             }
 985             else {
 986                 open (STDOUT, ">" . $new_output) or die;
 987
 988                 if (!$quiet) {
 989                     print STDERR "Writing to '$new_output'\n";
 990                 }
 991             }
 992
 993             $old_output = $new_output;
 994
 995             return 1;
 996         }
 997         else {
 998             return 0;
 999         }
1000     }
1001 }