tools/sfdc/GateAROS.pl

   1
   2 ### Class GateAROS: Create an AROS gatestub file ##############################
   3
   4 BEGIN {
   5     package GateAROS;
   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 "#include <aros/libcall.h>\n";
  24         print "\n";
  25     }
  26
  27     sub function {
  28         my $self     = shift;
  29         my %params    = @_;
  30         my $prototype = $params{'prototype'};
  31         my $sfd       = $self->{SFD};
  32
  33         if ($prototype->{type} eq 'cfunction') {
  34             print "#define $gateprefix$prototype->{funcname} " .
  35                 "AROS_SLIB_ENTRY(" .
  36                 "$gateprefix$prototype->{funcname},$sfd->{Basename})\n\n";
  37         }
  38
  39         $self->SUPER::function (@_);
  40     }
  41
  42     sub function_start {
  43         my $self      = shift;
  44         my %params    = @_;
  45         my $prototype = $params{'prototype'};
  46         my $sfd       = $self->{SFD};
  47         my $nb        = $prototype->{nb} || $libarg eq 'none';
  48
  49         # AROS macros cannot handle function pointer arguments :-(
  50
  51         for my $i (0 .. $prototype->{numargs} - 1) {
  52             if ($prototype->{argtypes}[$i] =~ /\(\*\)/) {
  53                 my $typedef  = $prototype->{argtypes}[$i];
  54                 my $typename = "$sfd->{Basename}_$prototype->{funcname}_fp$i";
  55
  56                 $typedef =~ s/\(\*\)/(*_$typename)/;
  57
  58                 print "typedef $typedef;\n";
  59             }
  60         }
  61
  62         if ($self->{PROTO}) {
  63             printf "AROS_LD%d%s(", $prototype->{numargs}, $nb ? "I" : "";
  64         }
  65         else {
  66             printf "AROS_LH%d%s(", $prototype->{numargs}, $nb ? "I" : "";
  67         }
  68         print "$prototype->{return}, $gateprefix$prototype->{funcname},\n";
  69     }
  70
  71     sub function_arg {
  72         my $self      = shift;
  73         my %params    = @_;
  74         my $prototype = $params{'prototype'};
  75         my $argtype   = $params{'argtype'};
  76         my $argname   = $params{'argname'};
  77         my $argreg    = $params{'argreg'};
  78         my $argnum    = $params{'argnum'};
  79         my $sfd       = $self->{SFD};
  80
  81         if ($argtype =~ /\(\*\)/) {
  82             $argtype = "_$sfd->{Basename}_$prototype->{funcname}_fp$argnum";
  83         }
  84
  85         if ($self->{PROTO}) {
  86             print "     AROS_LDA($argtype, $argname, " . (uc $argreg) . "),\n";
  87         }
  88         else {
  89             print "     AROS_LHA($argtype, $argname, " . (uc $argreg) . "),\n";
  90         }
  91     }
  92
  93     sub function_end {
  94         my $self      = shift;
  95         my %params    = @_;
  96         my $prototype = $params{'prototype'};
  97         my $sfd       = $self->{SFD};
  98
  99         my $bt = "/* bt */";
 100         my $bn = "/* bn */";
 101
 102         if ($prototype->{nb}) {
 103             for my $i (0 .. $#{$prototype->{regs}}) {
 104                 if ($prototype->{regs}[$i] eq 'a6') {
 105                     $bt = $prototype->{argtypes}[$i];
 106                     $bn  =$prototype->{___argnames}[$i];
 107                     last;
 108                 }
 109             }
 110         }
 111         else {
 112             $bt = $sfd->{basetype};
 113             $bn = "_base";
 114         }
 115
 116         printf "        $bt, $bn, %d, $sfd->{Basename})",
 117         $prototype->{bias} / 6;
 118
 119         if ($self->{PROTO}) {
 120             print ";\n";
 121             print "#define $gateprefix$prototype->{funcname} " .
 122                 "AROS_SLIB_ENTRY(" .
 123                 "$gateprefix$prototype->{funcname},$sfd->{Basename})\n";
 124         }
 125         else {
 126             print "\n";
 127             print "{\n";
 128             print "  AROS_LIBFUNC_INIT\n";
 129             print "  return $libprefix$prototype->{funcname}(";
 130
 131             if ($libarg eq 'first' && !$prototype->{nb}) {
 132                 print "_base";
 133                 print $prototype->{numargs} > 0 ? ", " : "";
 134             }
 135
 136             print join (', ', @{$prototype->{___argnames}});
 137
 138             if ($libarg eq 'last' && !$prototype->{nb}) {
 139                 print $prototype->{numargs} > 0 ? ", " : "";
 140                 print "_base";
 141             }
 142
 143             print ");\n";
 144             print "  AROS_LIBFUNC_EXIT\n";
 145             print "}\n";
 146         }
 147     }
 148 }