tools/sfdc/StubAROS.pl

   1
   2 ### Class StubAROS: Create an AROS stub file ##################################
   3
   4 BEGIN {
   5     package StubAROS;
   6     use vars qw(@ISA);
   7     @ISA = qw( Stub );
   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
  20         $self->SUPER::header (@_);
  21
  22         print "#include <aros/libcall.h>\n";
  23         print "\n";
  24     }
  25
  26     sub function_start {
  27         my $self      = shift;
  28         my %params    = @_;
  29         my $prototype = $params{'prototype'};
  30         my $sfd       = $self->{SFD};
  31
  32         if ($prototype->{type} eq 'function') {
  33             print "\n";
  34             print "{\n";
  35
  36             if (!$prototype->{nb}) {
  37                 print "  BASE_EXT_DECL\n";
  38             }
  39
  40             if (!$prototype->{nr}) {
  41                 print "  $prototype->{return} _res = ($prototype->{return}) ";
  42             }
  43             else {
  44                 print "  ";
  45             }
  46
  47             printf "AROS_LC%d%s($prototype->{return}, $prototype->{funcname},\n",
  48             $prototype->{numargs}, $prototype->{nb} ? "I" : "";
  49         }
  50         else {
  51             $self->SUPER::function_start (@_);
  52         }
  53     }
  54
  55     sub function_arg {
  56         my $self      = shift;
  57         my %params    = @_;
  58         my $prototype = $params{'prototype'};
  59         my $argtype   = $params{'argtype'};
  60         my $argname   = $params{'argname'};
  61         my $argreg    = $params{'argreg'};
  62         my $argnum    = $params{'argnum'};
  63         my $sfd       = $self->{SFD};
  64
  65         if ($$prototype{'type'} eq 'function') {
  66             print "    AROS_LCA($argtype, $argname, " . (uc $argreg) . "),\n";
  67         }
  68         else {
  69             $self->SUPER::function_arg (@_);
  70         }
  71     }
  72
  73     sub function_end {
  74         my $self      = shift;
  75         my %params    = @_;
  76         my $prototype = $params{'prototype'};
  77         my $sfd       = $self->{SFD};
  78
  79         if ($$prototype{'type'} eq 'function') {
  80             if ($prototype->{nb}) {
  81                 my $bt = "/* bt */";
  82                 my $bn = "/* bn */";
  83
  84                 for my $i (0 .. $#{$prototype->{regs}}) {
  85                     if ($prototype->{regs}[$i] eq 'a6') {
  86                         $bt = $prototype->{argtypes}[$i];
  87                         $bn  =$prototype->{___argnames}[$i];
  88                         last;
  89                     }
  90                 }
  91
  92                 printf "    $bt, $bn, %d, $sfd->{Basename});\n",
  93                 $prototype->{bias} / 6;
  94             }
  95             else {
  96                 printf "    $sfd->{basetype}, BASE_NAME, %d, $sfd->{Basename});\n",
  97                 $prototype->{bias} / 6;
  98             }
  99
 100             if (!$prototype->{nr}) {
 101                 print "  return _res;\n";
 102             }
 103
 104             print "};\n";
 105         }
 106         else {
 107             $self->SUPER::function_end (@_);
 108         }
 109     }
 110 }