tools/sfdc/SDIAROS.pl

   1
   2 ### Class SDIAROS: Create an AROS SDI stub file ##############################
   3
   4 BEGIN {
   5     package SDIAROS;
   6     use vars qw(@ISA);
   7     @ISA = qw( SDI );
   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 "#include <SDI_lib.h>\n";
  25         print "\n";
  26     }
  27
  28     sub function {
  29         my $self     = shift;
  30         my %params    = @_;
  31         my $prototype = $params{'prototype'};
  32         my $sfd       = $self->{SFD};
  33
  34         if ($prototype->{type} eq 'cfunction') {
  35             print "#define $gateprefix$prototype->{funcname} " .
  36                 "AROS_SLIB_ENTRY(" .
  37                 "$gateprefix$prototype->{funcname},$sfd->{Basename},".
  38                 ($prototype->{bias}/6).")\n\n";
  39         }
  40
  41         $self->SUPER::function (@_);
  42     }
  43
  44     sub function_start {
  45         my $self      = shift;
  46         my %params    = @_;
  47         my $prototype = $params{'prototype'};
  48         my $sfd       = $self->{SFD};
  49         my $nb        = $prototype->{nb} || $libarg eq 'none';
  50
  51         # AROS macros cannot handle function pointer arguments :-(
  52
  53         for my $i (0 .. $prototype->{numargs} - 1) {
  54             if ($prototype->{argtypes}[$i] =~ /\(\*\)/) {
  55                 my $typedef  = $prototype->{argtypes}[$i];
  56                 my $typename = "$sfd->{Basename}_$prototype->{funcname}_fp$i";
  57
  58                 $typedef =~ s/\(\*\)/(*_$typename)/;
  59
  60                 print "typedef $typedef;\n";
  61             }
  62         }
  63         if ($self->{PROTO}) {
  64             printf "AROS_LD%d(", $prototype->{numargs};
  65         }
  66         else {
  67             printf "AROS_LH%d(", $prototype->{numargs};
  68         }
  69
  70         print "$prototype->{return}, $gateprefix$prototype->{funcname},\n";
  71     }
  72
  73     sub function_arg {
  74         my $self      = shift;
  75         my %params    = @_;
  76         my $prototype = $params{'prototype'};
  77         my $argtype   = $params{'argtype'};
  78         my $argname   = $params{'argname'};
  79         my $argreg    = $params{'argreg'};
  80         my $argnum    = $params{'argnum'};
  81         my $sfd       = $self->{SFD};
  82
  83         if ($argtype =~ /\(\*\)/) {
  84             $argtype = "_$sfd->{Basename}_$prototype->{funcname}_fp$argnum";
  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_OR_IFACE_VAR";
 115         }
 116
 117         print "    $bt, $bn, 0, LIBSTUB\n)";
 118
 119         if ($self->{PROTO}) {
 120             print ";\n";
 121         }
 122         else {
 123             print "\n";
 124             print "{\n";
 125             print "    AROS_LIBFUNC_INIT\n";
 126
 127             if ($prototype->{numargs} > 0) {
 128                 print "    return CALL_LFUNC($libprefix$prototype->{funcname}, ";
 129                 print join (', ', @{$prototype->{___argnames}});
 130             }
 131             else {
 132                 print "    return CALL_LFUNC_NP($libprefix$prototype->{funcname}";
 133             }
 134
 135             print ");\n";
 136             print "    AROS_LIBFUNC_EXIT\n";
 137             print "}\n";
 138         }
 139     }
 140 }