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},
  49             $$prototype{'return'} eq 'void'
  50                 || $$prototype{'return'} eq 'VOID' ? "NR" : "";
  51         }
  52         else {
  53             $self->SUPER::function_start (@_);
  54         }
  55     }
  56
  57     sub function_arg {
  58         my $self      = shift;
  59         my %params    = @_;
  60         my $prototype = $params{'prototype'};
  61         my $argtype   = $params{'argtype'};
  62         my $argname   = $params{'argname'};
  63         my $argreg    = $params{'argreg'};
  64         my $argnum    = $params{'argnum'};
  65         my $sfd       = $self->{SFD};
  66
  67         if ($$prototype{'type'} eq 'function') {
  68             print "    AROS_LCA($argtype, $argname, " . (uc $argreg) . "),\n";
  69         }
  70         else {
  71             $self->SUPER::function_arg (@_);
  72         }
  73     }
  74
  75     sub function_end {
  76         my $self      = shift;
  77         my %params    = @_;
  78         my $prototype = $params{'prototype'};
  79         my $sfd       = $self->{SFD};
  80
  81         if ($$prototype{'type'} eq 'function') {
  82             if ($prototype->{nb}) {
  83                 my $bt = "/* bt */";
  84                 my $bn = "/* bn */";
  85
  86                 for my $i (0 .. $#{$prototype->{regs}}) {
  87                     if ($prototype->{regs}[$i] eq 'a6') {
  88                         $bt = $prototype->{argtypes}[$i];
  89                         $bn  =$prototype->{___argnames}[$i];
  90                         last;
  91                     }
  92                 }
  93
  94                 printf "    $bt, $bn, %d, $sfd->{Basename});\n",
  95                 $prototype->{bias} / 6;
  96             }
  97             else {
  98                 printf "    $sfd->{basetype}, BASE_NAME, %d, $sfd->{Basename});\n",
  99                 $prototype->{bias} / 6;
 100             }
 101
 102             if (!$prototype->{nr}) {
 103                 print "  return _res;\n";
 104             }
 105
 106             print "};\n";
 107         }
 108         else {
 109             $self->SUPER::function_end (@_);
 110         }
 111     }
 112 }