tools/sfdc/Stub.pl

   1
   2 ### Class Stub: Create a generic stub file ####################################
   3
   4 BEGIN {
   5     package Stub;
   6
   7     sub new {
   8         my $proto  = shift;
   9         my %params = @_;
  10         my $class  = ref($proto) || $proto;
  11         my $self   = {};
  12         $self->{SFD}     = $params{'sfd'};
  13         $self->{NEWFILE} = 0;
  14         bless ($self, $class);
  15         return $self;
  16     }
  17
  18     sub header {
  19         my $self = shift;
  20         my $sfd  = $self->{SFD};
  21
  22         $self->{NEWFILE} = 1;
  23
  24         print "/* Automatically generated stubs! Do not edit! */\n";
  25         print "\n";
  26
  27         foreach my $inc (@{$$sfd{'includes'}}) {
  28             print "#include $inc\n";
  29         }
  30
  31         foreach my $td (@{$$sfd{'typedefs'}}) {
  32             print "typedef $td;\n";
  33         }
  34
  35         print "\n";
  36         print "#ifdef __cplusplus\n";
  37         print "extern \"C\" {\n";
  38         print "#endif /* __cplusplus */\n";
  39         print "\n";
  40
  41         if ($$sfd{'base'} ne '') {
  42             print "#ifndef BASE_EXT_DECL\n";
  43             print "#define BASE_EXT_DECL\n";
  44             print "#define BASE_EXT_DECL0 extern $$sfd{'basetype'} " .
  45                 "$$sfd{'base'};\n";
  46             print "#endif /* !BASE_EXT_DECL */\n";
  47             print "#ifndef BASE_PAR_DECL\n";
  48             print "#define BASE_PAR_NAME\n";
  49             print "#define BASE_PAR_DECL\n";
  50             print "#define BASE_PAR_DECL0 void\n";
  51             print "#endif /* !BASE_PAR_DECL */\n";
  52             print "#ifndef BASE_NAME\n";
  53             print "#define BASE_NAME $$sfd{'base'}\n";
  54             print "#endif /* !BASE_NAME */\n";
  55             print "\n";
  56             print "BASE_EXT_DECL0\n";
  57             print "\n";
  58         }
  59
  60     }
  61
  62     sub function {
  63         my $self     = shift;
  64         my %params    = @_;
  65         my $prototype = $params{'prototype'};
  66         my $sfd       = $self->{SFD};
  67
  68         # Don't process private functions
  69         if ($prototype->{private}) {
  70             return;
  71         }
  72
  73         $self->function_proto (prototype => $prototype, decl_regular => $self->{NEWFILE} );
  74         $self->function_start (prototype => $prototype);
  75         for my $i (0 .. $$prototype{'numargs'} - 1 ) {
  76             $self->function_arg (prototype => $prototype,
  77                                  argtype   => $$prototype{'argtypes'}[$i],
  78                                  argname   => $$prototype{'___argnames'}[$i],
  79                                  argreg    => $$prototype{'regs'}[$i],
  80                                  argnum    => $i );
  81         }
  82         $self->function_end (prototype => $prototype);
  83
  84         print "\n";
  85
  86         $self->{NEWFILE} = 0;
  87     }
  88
  89     sub footer {
  90         my $self = shift;
  91         my $sfd  = $self->{SFD};
  92
  93         print "\n";
  94         print "#undef BASE_EXT_DECL\n";
  95         print "#undef BASE_EXT_DECL0\n";
  96         print "#undef BASE_PAR_NAME\n";
  97         print "#undef BASE_PAR_DECL\n";
  98         print "#undef BASE_PAR_DECL0\n";
  99         print "#undef BASE_NAME\n";
 100         print "\n";
 101         print "#ifdef __cplusplus\n";
 102         print "}\n";
 103         print "#endif /* __cplusplus */\n";
 104     }
 105
 106
 107     # Helper functions
 108
 109     sub function_proto {
 110         my $self     = shift;
 111         my %params   = @_;
 112         my $prototype    = $params{'prototype'};
 113         my $decl_regular = $params{'decl_regular'};
 114         my $sfd      = $self->{SFD};
 115
 116         if ($prototype->{type} eq 'varargs' && $decl_regular) {
 117             my $rproto = $prototype->{real_prototype};
 118
 119             print "__inline $$rproto{'return'} $$rproto{'funcname'}(";
 120             if (!$prototype->{nb}) {
 121                 if ($$rproto{'numargs'} == 0) {
 122                     print "BASE_PAR_DECL0";
 123                 }
 124                 else {
 125                     print "BASE_PAR_DECL ";
 126                 }
 127             }
 128             print join (', ', @{$$rproto{'___args'}});
 129
 130             print ");\n";
 131             print "\n";
 132         }
 133
 134         if ($prototype->{type} eq 'cfunction' &&
 135             $prototype->{argnames}[$#{@{$prototype->{argnames}}}] eq '...') {
 136             print "#if 0\n";
 137             print "/* Unsupported */\n";
 138         }
 139
 140         # Declare structs in case some ==include directive is missing
 141         for my $argtype (@{$prototype->{argtypes}}) {
 142             my $struct;
 143
 144             (undef, $struct) = ( $argtype =~ /\s*(const)?\s*struct\s*(\w+).*/) and
 145                 printf "struct $struct;\n";
 146         }
 147
 148
 149         print "__inline $$prototype{'return'}\n";
 150         print "$$prototype{'funcname'}(";
 151         if (!$prototype->{nb}) {
 152             if ($$prototype{'numargs'} == 0) {
 153                 print "BASE_PAR_DECL0";
 154             }
 155             else {
 156                 print "BASE_PAR_DECL ";
 157             }
 158         }
 159         print join (', ', @{$$prototype{'___args'}});
 160         print ")";
 161
 162     }
 163
 164     sub function_start {
 165         my $self      = shift;
 166         my %params    = @_;
 167         my $prototype = $params{'prototype'};
 168         my $sfd       = $self->{SFD};
 169
 170         print "\n";
 171         print "{\n";
 172
 173         if ($$prototype{'type'} eq 'varargs') {
 174             print "  return $$prototype{'real_funcname'}(BASE_PAR_NAME ";
 175         }
 176         elsif ($prototype->{type} eq 'cfunction') {
 177             if (!$prototype->{nb}) {
 178                 print "  BASE_EXT_DECL\n";
 179             }
 180
 181             my $argtypes = join (', ',@{$$prototype{'argtypes'}});
 182
 183             if ($argtypes eq '') {
 184                 if ($prototype->{nb}) {
 185                     $argtypes = "void";
 186                 }
 187             }
 188             else {
 189                 if (!$prototype->{nb}) {
 190                     $argtypes = "$sfd->{basetype}, $argtypes";
 191                 }
 192             }
 193
 194
 195             # Skip jmp instruction (is m68k ILLEGAL in MOS)
 196             my $offs = $$prototype{'bias'} - 2;
 197
 198             print "  $$prototype{'return'} (*_func) ($argtypes) = \n";
 199             print "    ($$prototype{'return'} (*) ($argtypes))\n";
 200             print "    *((ULONG*) (((char*) BASE_NAME) - $offs));\n";
 201             print "  return (*_func)(";
 202
 203             if (!$prototype->{nb}) {
 204                 print "BASE_NAME";
 205                 print ", " unless $prototype->{numargs} == 0;
 206             }
 207         }
 208         else {
 209             print STDERR "$prototype->{funcname}: Unhandled.\n";
 210             die;
 211         }
 212     }
 213
 214     sub function_arg {
 215         my $self      = shift;
 216         my %params    = @_;
 217         my $prototype = $params{'prototype'};
 218         my $argtype   = $params{'argtype'};
 219         my $argname   = $params{'argname'};
 220         my $argreg    = $params{'argreg'};
 221         my $argnum    = $params{'argnum'};
 222         my $sfd       = $self->{SFD};
 223
 224         my $argstr;
 225
 226         if ($$prototype{'type'} eq 'varargs') {
 227             if ($prototype->{subtype} eq 'printfcall') {
 228                 if ($argnum < $$prototype{'numargs'} - 1) {
 229                     $argstr = $argname;
 230                 }
 231                 elsif ($argnum == $$prototype{'numargs'} - 1) {
 232                     my $vartype  =
 233                         $$prototype{'argtypes'}[$$prototype{'numargs'} - 1];
 234                     my $argnm =
 235                         $$prototype{'___argnames'}[$$prototype{'numargs'} - 2];
 236                     $argstr = "($vartype) (&$argnm + 1)";
 237                 }
 238                 else {
 239                     $argstr = '';
 240                 }
 241             }
 242             else {
 243                 # tagcall/methodcall
 244                 if ($argnum < $$prototype{'numargs'} - 2) {
 245                     $argstr = $argname;
 246                 }
 247                 elsif ($argnum == $$prototype{'numargs'} - 2) {
 248                     my $vartype =
 249                         $$prototype{'argtypes'}[$$prototype{'numargs'} - 1];
 250                     $argstr = "($vartype) &$argname";
 251                 }
 252                 else {
 253                     $argstr = '';
 254                 }
 255             }
 256         }
 257         elsif ($prototype->{type} eq 'cfunction') {
 258             $argstr = $argname;
 259         }
 260         else {
 261             print STDERR "$prototype->{funcname}: Unhandled.\n";
 262             die;
 263         }
 264
 265         if ($argstr ne '') {
 266             print ($argnum != 0 ? ", $argstr" : $argstr);
 267         }
 268     }
 269
 270     sub function_end {
 271         my $self      = shift;
 272         my %params    = @_;
 273         my $prototype = $params{'prototype'};
 274         my $sfd       = $self->{SFD};
 275
 276         print ");\n";
 277         print "}\n";
 278
 279         if ($prototype->{type} eq 'cfunction' &&
 280             $prototype->{argnames}[$#{@{$prototype->{argnames}}}] eq '...') {
 281             print "/* Unsupported */\n";
 282             print "#endif\n";
 283         }
 284     }
 285 }