Updated PCI IDs to latest snapshot.
[tangerine.git] / tools / sfdc / main.pl
blobc2cdbad2b2e4a94ed388b452b255ca68ee95dfe3
1 #!/usr/bin/perl -w
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.
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.
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.
20 use strict;
22 use IO::Handle;
23 use Getopt::Long;
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.
29 eval {
30 require Pod::Usage;
31 import Pod::Usage;
34 if ($@) {
35 eval '
36 # Minimal fall-back ...
38 sub pod2usage {
39 my @params = @_;
41 my $verbose = 0;
42 my $exitval = 0;
43 my $message = "";
44 my $output = \*STDERR;
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};
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;
65 sub parse_sfd ( $ );
66 sub parse_proto ( $$$ );
67 sub open_output ( $$ );
68 sub will_close_output ( $$ );
69 sub close_output ();
71 my @lf =
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() ()'
83 my @df =
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)'
99 my @bf =
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() ()',
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',
121 '(\w)+(-.*)?-aros' =>
122 { target => 'aros',
123 vectors => { 'library' => @lf, 'device' => @df, 'boopsi' => @bf },
124 macros => 'MacroAROS',
125 stubs => 'StubAROS',
126 gatestubs => 'GateAROS'
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'
137 'm68k(-unknown)?-amigaos' =>
138 { target => 'amigaos',
139 vectors => { 'library' => @lf, 'device' => @df, 'boopsi' => @bf },
140 macros => 'Macro68k',
141 stubs => 'Stub68k',
142 gatestubs => 'Gate68k'
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'
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'
162 my $classes;
164 ###############################################################################
165 ### Main program ##############################################################
166 ###############################################################################
168 Getopt::Long::Configure ("bundling");
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';
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;
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;
202 if ($help) {
203 pod2usage (-verbose => 1,
204 -exitval => 0,
205 -output => \*STDOUT);
208 if ($man) {
209 pod2usage (-verbose => 3,
210 -exitval => 0);
211 exit 0;
214 if ($#ARGV < 0) {
215 pod2usage (-message => "No SFD file specified.",
216 -verbose => 0,
217 -exitval => 10);
220 $mode = lc $mode;
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);
228 if ($libarg !~ /^(first|last|none)$/) {
229 pod2usage (-message => "Unknown libarg specified. Use --help for a list.",
230 -verbose => 0,
231 -exitval => 10);
234 if ($addvectors !~ /^(none|library|device|boopsi)$/) {
235 pod2usage (-message => "Unknown addvectors value. Use --help for a list.",
236 -verbose => 0,
237 -exitval => 10);
240 check_target: {
241 foreach my $target_regex (keys %targets) {
242 if ($target =~ /^$target_regex$/) {
243 $classes = $targets{$target_regex};
244 last check_target;
248 pod2usage (-message => "Unknown target specified. Use --help for a list.",
249 -verbose => 0,
250 -exitval => 10);
253 # Save old STDOUT
255 open( OLDOUT, ">&STDOUT" );
257 for my $i ( 0 .. $#ARGV ) {
258 my $sfd = parse_sfd ($ARGV[$i]);
259 my $num = $#{$$sfd{'prototypes'}};
261 my $obj;
263 for ($mode) {
264 /^clib$/ && do {
265 $obj = CLib->new( sfd => $sfd );
266 last;
269 /^fd$/ && do {
270 $obj = FD->new( sfd => $sfd );
271 last;
274 /^dump$/ && do {
275 $obj = Dump->new( sfd => $sfd );
276 last;
279 /^libproto$/ && do {
280 $obj = Gate->new( sfd => $sfd,
281 proto => 0,
282 libproto => 1 );
283 last;
286 /^lvo$/ && do {
287 $obj = LVO->new( sfd => $sfd );
288 last;
291 /^functable$/ && do {
292 $obj = FuncTable->new( sfd => $sfd );
293 last;
296 /^macros$/ && do {
297 $obj = $$classes{'macros'}->new( sfd => $sfd );
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;
306 /^proto$/ && do {
307 $obj = Proto->new( sfd => $sfd );
308 last;
311 /^pragmas$/ && do {
312 $obj = SASPragmas->new( sfd => $sfd );
313 last;
316 /^verify$/ && do {
317 $obj = Verify->new( sfd => $sfd );
318 last;
321 /^stubs$/ && do {
322 $obj = $$classes{'stubs'}->new( sfd => $sfd );
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;
331 /^gateproto$/ && do {
332 $obj = $$classes{'gatestubs'}->new( sfd => $sfd,
333 proto => 1,
334 libproto => 0);
335 last;
338 /^gatestubs$/ && do {
339 $obj = $$classes{'gatestubs'}->new( sfd => $sfd,
340 proto => 0,
341 libproto => 0);
343 last;
346 die "Unknown mode specified: " . $mode;
350 for my $j ( 0 .. $num + 1) {
351 my $prototype = $$sfd{'prototypes'}[$j];
352 my $funcname = $$prototype{'funcname'};
354 if (!defined ($funcname) || will_close_output ($sfd, $funcname) != 0) {
355 $obj->footer ();
358 if ($j > $num) {
359 last;
362 if (open_output ($sfd, $funcname) != 0) {
363 $obj->header ();
366 $obj->function (prototype => $prototype);
369 close_output ();
372 if (!$quiet) {
373 print STDERR "All done.\n";
376 open (STDOUT, ">&OLDOUT");
377 close (OLDOUT);
379 exit 0;
386 ###############################################################################
387 ### Subroutines ###############################################################
388 ###############################################################################
391 ### parse_sfd: Parse a SFD file hand return a hash record #####################
393 sub parse_sfd ( $ ) {
394 my $file = shift;
395 local *SFD;
397 my $type = 'function';
398 my $last_type = $type;
399 my $private = 0;
400 my $bias = 0;
401 my $version = 1;
402 my $comment = '';
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 => ''
418 # Why do I need this????
419 $$result{'prototypes'} = ();
420 $$result{'includes'} = ();
421 $$result{'typedefs'} = ();
423 if ($addvectors ne 'none') {
424 push @{$$result{'includes'}}, '<dos/dos.h>';
425 push @{$$result{'includes'}}, '<exec/execbase.h>';
427 if ($addvectors eq 'device') {
428 push @{$$result{'includes'}}, '<exec/io.h>';
430 elsif ($addvectors eq 'boopsi') {
431 push @{$$result{'includes'}}, '<intuition/classes.h>';
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 => ''
449 my $proto_line = '';
450 my %proto;
452 if (!$quiet) {
453 ( my $fn = $file ) =~ s,.*[/\\](.*),$1,;
454 print STDERR "Processing SFD file '$fn'.\n";
455 STDERR->flush();
458 unless (open (SFD, "<" . $file)) {
459 print STDERR "Unable to open file '$file'.\n";
460 die;
463 my $line_no = 0;
465 LINE:
466 while (my $line = <SFD>) {
468 ++$line_no;
470 for ($line) {
471 /==copyright\s/ && do {
472 ( $$result{'copyright'} = $_ ) =~ s/==copyright\s+(.*)\s*/$1/;
473 last;
476 /==id\s+/ && do {
477 ( $$result{'id'} = $_ ) =~ s/==id\s+(.*)\s*/$1/;
478 last;
481 /==libname\s+/ && do {
482 ( $$result{'libname'} = $_ ) =~ s/==libname\s+(.*)\s*/$1/;
483 last;
486 /==base\s+/ && do {
487 ( $$result{'base'} = $_ ) =~ s/==base\s+_?(.*)\s*/$1/;
488 last;
491 /==basetype\s+/ && do {
492 ( $$result{'basetype'} = $_ ) =~ s/==basetype\s+(.*)\s*/$1/;
493 last;
496 /==include\s+/ && do {
497 ( my $inc = $_ ) =~ s/==include\s+(.*)\s*/$1/;
499 push @{$$result{'includes'}}, $inc;
500 last;
503 /==typedef\s+/ && do {
504 ( my $td = $_ ) =~ s/==typedef\s+(.*)\s*$/$1/;
506 push @{$$result{'typedefs'}}, $td;
507 last;
510 /==bias\s+/ && do {
511 ( $bias = $_ ) =~ s/==bias\s+(.*)\s*/$1/;
512 last;
515 /==reserve\s+/ && do {
516 ( my $reserve = $_ ) =~ s/==reserve\s+(.*)\s*/$1/;
518 $bias += 6 * $reserve;
519 last;
522 /==alias\s*$/ && do {
523 # Move back again
524 $type = $last_type;
525 $bias -= 6;
526 last;
529 /==varargs\s*$/ && do {
530 $type = 'varargs';
531 # Move back again
532 $bias -= 6;
533 last;
536 /==private\s*$/ && do {
537 $private = 1;
538 last;
541 /==public\s*$/ && do {
542 $private = 0;
543 last;
546 /==version\s+/ && do {
547 ( $version = $_ ) =~ s/==version\s+(.*)\s*/$1/;
548 last;
551 /==end\s*$/ && do {
552 last LINE;
555 /^\*/ && do {
556 ( my $cmt = $_ ) =~ s/^\*(.*)\s*/$1/;
558 $comment .= ($comment eq '' ? "" : "\n" ) . $cmt;
559 last;
562 /^[^=*\n]/ && do {
563 # Strip whitespaces and append
564 $line =~ s/\s*(.*)\s*/$1/;
565 $proto_line .= $line . " ";
566 last;
569 /^\s*$/ && do {
570 # Skip blank lines
571 last;
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;
580 if ( $proto_line =~
581 /.*[A-Za-z0-9_]+\s*\(.*\).*\(((base|sysv|autoreg|[\saAdD][0-7]-?),?)*\)\s*$/
584 if ($proto_line =~ /.*\(.*[0-7]-.*\)\s*$/) {
585 if ($$classes{'target'} ne 'amigaos') {
586 print STDERR "Warning: Multiregister functions are m68k only.\n";
588 $proto_line =~ s/([da][0-7])-[da][0-7]/$1/g;
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
602 $comment = '';
605 $last_type = $type;
606 $type = 'function';
607 $proto_line = '';
608 $bias += 6;
612 if( $proto_line ne '' ) {
613 # If $proto_line isn't empty, we couldn't parse it
614 die "Unhanled proto '" . $proto_line . "'\n";
617 close (SFD);
619 # Now parse the prototypes
620 my $real_funcname = '';
621 my $real_prototype = {};
622 my $varargs_type = '';
624 for my $i ( 0 .. $#{$$result{'prototypes'}} ) {
625 my $prototype = $$result{'prototypes'}[$i];
627 if ($$prototype{'type'} eq 'varargs') {
628 $$prototype{'real_funcname'} = $real_funcname;
629 $$prototype{'real_prototype'} = $real_prototype;
631 else {
632 $$prototype{'real_funcname'} = '';
633 $$prototype{'real_prototype'} = '';
636 parse_proto ($result, $prototype, $varargs_type);
638 if ($$prototype{'type'} eq 'function') {
639 $varargs_type = $$prototype{'argtypes'}[$#{$$prototype{'argtypes'}}];
642 if ($$prototype{'type'} eq 'function') {
643 $real_funcname = $$prototype{'funcname'};
644 $real_prototype = $prototype;
648 # Create some other variables
650 ( $$result{'basename'} = $file ) =~ s:.*/(\w+?)_lib\.sfd:$1:;
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;
659 # Fake the CIA libname
660 if ($$result{'basename'} eq "cia") {
661 $$result{'libname'} = "ciaX.resource";
663 else {
664 $$result{'libname'} = $$result{'basename'} . ".library";
668 # Fake the Workbench basename
669 if ($$result{'basename'} eq "workbench") {
670 $$result{'basename'} = "wb";
673 $$result{'basename'} =~ s/-/_/g;
674 $$result{'basename'} = lc $$result{'basename'};
675 $$result{'BASENAME'} = uc $$result{'basename'};
676 $$result{'Basename'} = ucfirst $$result{'basename'};
677 ($result->{BaseName} = $result->{base}) =~ s/Base//;
679 return $result;
683 ### parse_proto: Parse a single function prototype ###########################
685 sub parse_proto ( $$$ ) {
686 my $sfd = shift;
687 my $prototype = shift;
688 my $varargs_type = shift;
690 my $return;
691 my $name;
692 my $arguments;
693 my $registers;
695 if (!(($return,undef,undef,$name,$arguments,$registers) =
696 ( $$prototype{'value'} =~
697 /^((struct\s+)?(\w+\s*?)+\**)\s*(\w+)\s*\((.*)\)\s*\((.*)\).*/ ))) {
698 print STDERR "Unable to parse prototype on line $$prototype{'line'}.\n";
699 die;
702 # Nuke whitespaces from the register specification
703 $registers =~ s/\s//;
705 $$prototype{'return'} = $return;
706 $$prototype{'funcname'} = $name;
708 $$prototype{'numargs'} = 0;
709 $$prototype{'numregs'} = 0;
711 @{$$prototype{'regs'}} = ();
712 @{$$prototype{'args'}} = ();
713 @{$$prototype{'___args'}} = ();
714 @{$$prototype{'argnames'}} = ();
715 @{$$prototype{'___argnames'}} = ();
716 @{$$prototype{'argtypes'}} = ();
718 if ($arguments =~ /^(void|VOID)$/) {
719 $arguments = "";
722 my @args = split(/,/,$arguments);
724 # Fix function pointer arguments and build $$prototype{'args'}
726 my $par_cnt = 0;
727 foreach my $arg (@args) {
728 # Strip whitespaces
729 $arg =~ s/\s*(.*?)\s*/$1/;
731 if ($par_cnt != 0) {
732 my $old_arg = pop @{$$prototype{'args'}};
734 push @{$$prototype{'args'}}, $old_arg . "," . $arg;
736 else {
737 push @{$$prototype{'args'}}, $arg;
740 # Count parentheses (a function pointer arguments is processed
741 # when $par_cnt is 0).
742 $par_cnt += ( $arg =~ tr/\(/\(/ );
743 $par_cnt -= ( $arg =~ tr/\)/\)/ );
746 $$prototype{'numargs'} = $#{$$prototype{'args'}} + 1;
748 if ($registers =~ /sysv/) {
749 $prototype->{type} = 'cfunction';
750 $prototype->{nb} = 1;
752 elsif ($registers =~ /autoreg/) {
753 my $a_cnt = 0;
754 my $d_cnt = 0;
755 foreach my $arg (@{$$prototype{'args'}}) {
756 if ($arg =~ /\*/) {
757 push @{$$prototype{'regs'}}, "a$a_cnt";
758 $a_cnt++;
760 else {
761 push @{$$prototype{'regs'}}, "d$d_cnt";
762 $d_cnt++;
766 $prototype->{numregs} = $#{$$prototype{'regs'}} + 1;
767 $prototype->{nb} = $sfd->{base} eq '';
769 else {
770 # Split regs and make them lower case
771 @{$$prototype{'regs'}} = split(/,/,lc $registers);
772 $prototype->{numregs} = $#{$$prototype{'regs'}} + 1;
773 $prototype->{nb} = $sfd->{base} eq '' || $registers =~ /a6/;
776 $$prototype{'nr'} = $$prototype{'return'} =~ /^(VOID|void)$/;
778 # varargs sub types:
779 # printfcall: LONG Printf( STRPTR format, ... );
780 # All varargs are optional
781 # tagcall: BOOL AslRequestTags( APTR requester, Tag Tag1, ... );
782 # First vararg is a Tag, then a TAG_DONE terminated tag list
783 # methodcall: ULONG DoGadgetMethod( ... ULONG message, ...);
784 # First vararg is required.
786 if ($prototype->{type} eq 'varargs') {
787 if ($varargs_type =~
788 /^\s*(const|CONST)?\s*struct\s+TagItem\s*\*\s*$/ ) {
789 $prototype->{subtype} = 'tagcall';
791 if ($prototype->{numargs} == $prototype->{numregs}) {
792 if (!$quiet) {
793 print STDERR "Warning: Adding missing Tag argument to " .
794 $prototype->{funcname} . "()\n";
797 my $last = pop @{$prototype->{args}};
798 push @{$prototype->{args}}, "Tag _tag1" ;
799 push @{$prototype->{args}}, $last;
801 ++$prototype->{numargs};
804 else {
805 if ($prototype->{numargs} == $prototype->{numregs}) {
806 $prototype->{subtype} = 'printfcall';
808 elsif ($prototype->{numargs} == $prototype->{numregs} + 1) {
809 $prototype->{subtype} = 'methodcall';
813 elsif ($prototype->{type} eq 'cfunction') {
814 foreach (split(/,/,lc $registers)) {
815 /^sysv$/ && do {
816 $prototype->{subtype} = 'sysv';
817 next;
820 /^base$/ && do {
821 if ($sfd->{base} eq '') {
822 printf STDERR "$prototype->{funcname}: " .
823 "Library has no base!\n";
824 die;
827 $prototype->{nb} = 0;
828 next;
835 # Make sure we have the same number of arguments as registers, or,
836 # if this is a varargs function, possible one extra, á la "MethodID, ...".
837 # Tagcalls always have one extra, á la "Tag, ...".
839 if (($prototype->{type} eq 'varargs' &&
840 $prototype->{subtype} eq 'tagcall' &&
841 $prototype->{numargs} != $prototype->{numregs} + 1 ) ||
843 ($prototype->{type} eq 'varargs' &&
844 $prototype->{subtype} eq 'printfcall' &&
845 $prototype->{numargs} != $prototype->{numregs}) ||
847 ($prototype->{type} eq 'varargs' &&
848 $prototype->{subtype} eq 'methodcall' &&
849 $prototype->{numargs} != $prototype->{numregs} + 1) ||
851 ($prototype->{type} eq 'function' &&
852 $prototype->{numargs} != $prototype->{numregs})) {
854 print STDERR "Failed to parse arguments/registers on SFD " .
855 "line $$prototype{'line'}:\n$$prototype{'value'}\n";
856 print STDERR "The number of arguments doesn't match " .
857 "the number of registers (+1 if tagcall).\n";
858 die;
861 my $type = '';
863 foreach my $arg (@{$$prototype{'args'}}) {
864 my $name = '';
865 my $___name = '';
866 my $___arg = '';
868 # MorhOS includes use __CLIB_PROTOTYPE for some reason ...
869 if ($arg =~ /.*\(.*?\)\s*(__CLIB_PROTOTYPE)?\(.*\)/) {
870 my $type1;
871 my $type2;
873 ($type1, $name, $type2) =
874 ( $arg =~ /^\s*(.*)\(\s*\*\s*(\w+)\s*\)\s*(\w*\(.*\))\s*/ );
875 $type = "$type1(*)$type2";
876 $___name = "___$name";
877 $___arg = "$type1(*___$name) $type2";
879 elsif ($arg !~ /^\.\.\.$/) {
880 ($type, $name) = ( $arg =~ /^\s*(.*?[\s*]*?)\s*(\w+)\s*$/ );
881 $___name = "___$name";
882 $___arg = "$type ___$name";
884 else {
885 if ($prototype->{type} eq 'varargs') {
886 $type = $varargs_type;
888 else {
889 # Unknown type
890 # $type = "void*";
891 $type = "...";
893 $name = '...';
894 $___name = '...';
895 $___arg = '...';
898 if ($type eq '' || $name eq '' ) {
899 print STDERR "Type or name missing from '$arg'.\n";
900 die;
903 push @{$$prototype{'___args'}}, $___arg;
904 push @{$$prototype{'argnames'}}, $name;
905 push @{$$prototype{'___argnames'}}, $___name;
907 push @{$$prototype{'argtypes'}}, $type;
913 sub BEGIN {
914 my $old_output = '';
917 ### close_output: Close the output file if necessary #########################
919 sub close_output () {
920 close (STDOUT);
921 $old_output = '';
925 ### check_output: Check if the file will be reopended by open_output ##########
927 sub will_close_output ( $$ ) {
928 my $sfd = shift;
929 my $function = shift;
931 my $new_output = $output;
933 $new_output =~ s/%f/$function/;
934 $new_output =~ s/%b/$$sfd{'base'}/;
935 $new_output =~ s/%l/$$sfd{'libname'}/;
936 $new_output =~ s/%n/$$sfd{'basename'}/;
938 if( $old_output ne '' &&
939 $new_output ne $old_output ) {
940 return 1;
942 else {
943 return 0;
947 ### open_output: (Re)open the output file if necessary #######################
949 sub open_output ( $$ ) {
950 my $sfd = shift;
951 my $function = shift;
953 my $new_output = $output;
955 $new_output =~ s/%f/$function/;
956 $new_output =~ s/%b/$$sfd{'base'}/;
957 $new_output =~ s/%l/$$sfd{'libname'}/;
958 $new_output =~ s/%n/$$sfd{'basename'}/;
960 if( $new_output ne $old_output ) {
962 close_output ();
964 if ($new_output eq '-') {
965 open (STDOUT, ">&OLDOUT") or die;
967 else {
968 open (STDOUT, ">" . $new_output) or die;
970 if (!$quiet) {
971 print STDERR "Writing to '$new_output'\n";
975 $old_output = $new_output;
977 return 1;
979 else {
980 return 0;