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