tools/sfdc/GateAOS4.pl

   1
   2 ### Class GateAOS4: Create a AmigaOS gatestub file ############################
   3
   4 BEGIN {
   5     package GateAOS4;
   6     use vars qw(@ISA);
   7     @ISA = qw( Gate );
   8
   9     sub new {
  10         my $proto  = shift;
  11         my $class  = ref($proto) || $proto;
  12         my $self   = $class->SUPER::new( @_ );
  13         bless ($self, $class);
  14         return $self;
  15     }
  16
  17     sub header {
  18         my $self = shift;
  19         my $sfd  = $self->{SFD};
  20
  21         $self->SUPER::header (@_);
  22
  23         print "#define __NOLIBBASE__\n";
  24         print "#include <proto/$sfd->{basename}.h>\n";
  25         print "#undef __NOLIBBASE__\n";
  26         print "#include <stdarg.h>\n";
  27         print "\n";
  28     }
  29
  30     sub function {
  31         my $self     = shift;
  32         my %params    = @_;
  33         my $prototype = $params{'prototype'};
  34         my $sfd       = $self->{SFD};
  35
  36         if ($prototype->{type} eq 'function' ||
  37             $prototype->{type} eq 'varargs' ) {
  38             $self->function_proto (prototype => $prototype);
  39             $self->function_start (prototype => $prototype);
  40             for my $i (0 .. $$prototype{'numargs'} - 1 ) {
  41                 $self->function_arg (prototype => $prototype,
  42                                      argtype   => $$prototype{'argtypes'}[$i],
  43                                      argname   => $$prototype{'___argnames'}[$i],
  44                                      argreg    => $$prototype{'regs'}[$i],
  45                                      argnum    => $i );
  46             }
  47             $self->function_end (prototype => $prototype);
  48
  49             print "\n";
  50         }
  51     }
  52
  53     sub function_start {
  54         my $self      = shift;
  55         my %params    = @_;
  56         my $prototype = $params{'prototype'};
  57         my $sfd       = $self->{SFD};
  58
  59         print "$prototype->{return}";
  60         if ($prototype->{type} eq 'varargs') {
  61             print " VARARGS68K";
  62         }
  63         print "\n";
  64         print "$gateprefix$prototype->{funcname}(";
  65         if ($prototype->{type} eq 'function' &&
  66             $prototype->{subtype} =~ /^(library|device|boopsi)$/) {
  67             # Special function prototype
  68
  69             if ($prototype->{bias} == 0) {
  70                 # Do nothing
  71             }
  72             elsif ($prototype->{subtype} eq 'library' ||
  73                    $prototype->{subtype} eq 'boopsi') {
  74                 print "struct LibraryManagerInterface* _iface";
  75             }
  76             elsif( $prototype->{subtype} eq 'device') {
  77                 print "struct DeviceManagerInterface* _iface";
  78             }
  79         }
  80         else {
  81             print "struct $sfd->{BaseName}IFace* _iface";
  82         }
  83     }
  84
  85     sub function_arg {
  86         my $self      = shift;
  87         my %params    = @_;
  88         my $prototype = $params{'prototype'};
  89         my $argtype   = $params{'argtype'};
  90         my $argname   = $params{'argname'};
  91         my $argreg    = $params{'argreg'};
  92         my $argnum    = $params{'argnum'};
  93         my $sfd       = $self->{SFD};
  94
  95         if ($prototype->{subtype} ne 'tagcall' ||
  96             $argnum ne $prototype->{numargs} - 2) {
  97
  98             if ($argnum != 0 || $prototype->{bias} != 0) {
  99                 print ",\n";
 100             }
 101
 102             if ($prototype->{subtype} =~ /^(library|device|boopsi)$/ &&
 103                 $prototype->{bias} == 0 &&
 104                 $argnum == $prototype->{numargs} - 1 ) {
 105                 print " struct ExecIFace* _iface";
 106             }
 107             else {
 108                 print " $prototype->{___args}[$argnum]";
 109             }
 110         }
 111     }
 112
 113     sub function_end {
 114         my $self      = shift;
 115         my %params    = @_;
 116         my $prototype = $params{'prototype'};
 117         my $sfd       = $self->{SFD};
 118
 119         if ($self->{PROTO}) {
 120             print ");\n";
 121         }
 122         else {
 123             print ")\n";
 124             print "{\n";
 125
 126             if ($prototype->{subtype} =~ /^(library|device|boopsi)$/ &&
 127                 $prototype->{bias} == 0) {
 128                 print "  $prototype->{___args}[$prototype->{numargs} - 1] = ".
 129                     "($prototype->{argtypes}[$prototype->{numargs} - 1]) " .
 130                     "_iface->Data.LibBase;\n";
 131             }
 132
 133             if ($prototype->{type} ne 'varargs') {
 134                 print "  return $libprefix$prototype->{funcname}(";
 135
 136                 if ($libarg eq 'first' && !$prototype->{nb}) {
 137                     print "($sfd->{basetype}) _iface->Data.LibBase";
 138                     print $prototype->{numargs} > 0 ? ", " : "";
 139                 }
 140
 141                 print join (', ', @{$prototype->{___argnames}});
 142
 143                 if ($libarg eq 'last' && !$prototype->{nb}) {
 144                     print $prototype->{numargs} > 0 ? ", " : "";
 145                     print "($sfd->{basetype}) _iface->Data.LibBase";
 146                 }
 147             }
 148             else {
 149                 my $na;
 150
 151                 if ($prototype->{subtype} eq 'tagcall') {
 152                     $na = $prototype->{numargs} - 3;
 153                 }
 154                 elsif ($prototype->{subtype} eq 'printfcall') {
 155                     $na = $prototype->{numargs} - 2;
 156                 }
 157                 else {
 158                     # methodcall: first vararg is removed
 159                     $na = $prototype->{numargs} - 3;
 160                 }
 161
 162                 print "  va_list _va;\n";
 163                 print "  va_startlinear (_va, ";
 164                 if ($na >= 0) {
 165                     print "$prototype->{___argnames}[$na]);\n";
 166                 }
 167                 else {
 168                     print "_iface);\n"
 169                 }
 170
 171                 print "  return $libprefix$prototype->{real_funcname}(";
 172
 173                 if ($libarg eq 'first' && !$prototype->{nb}) {
 174                     print "($sfd->{basetype}) _iface->Data.LibBase";
 175                     print $prototype->{numargs} > 0 ? ", " : "";
 176                 }
 177
 178                 for (my $i = 0; $i <= $na; ++$i) {
 179                     print "@{$prototype->{___argnames}}[$i], ";
 180                 }
 181
 182                 print "va_getlinearva (_va, " .
 183                     "$prototype->{argtypes}[$prototype->{numargs}-1])";
 184
 185                 if ($libarg eq 'last' && !$prototype->{nb}) {
 186                     print $prototype->{numargs} > 0 ? ", " : "";
 187                     print "($sfd->{basetype}) _iface->Data.LibBase";
 188                 }
 189
 190 #               varargs = va_getlinearva(ap, struct TagItem *);
 191 #               return  AllocAudioA(
 192 #                                   varargs,
 193 #                                   (struct AHIBase *) IAHI->Data.LibBase);
 194             }
 195
 196             print ");\n";
 197             print "}\n";
 198         }
 199     }
 200 }