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