tools/sfdc/Macro.pl

   1
   2 ### Class Macro: Create a generic macro file ##################################
   3
   4 # Macros are a bit different than those generated by fd2inline.
   5 #
   6 # Tag lists ("stdarg") are always initialized with the first tag value
   7 # followed by __VA_ARGS__. This generates a compile-time error if no tags
   8 # are supplied (TAG_DONE is the minimal tag list).
   9
  10 BEGIN {
  11     package Macro;
  12
  13     sub new {
  14         my $proto  = shift;
  15         my %params = @_;
  16         my $class  = ref($proto) || $proto;
  17         my $self   = {};
  18         $self->{SFD}  = $params{'sfd'};
  19         $self->{BASE} = "${$self->{SFD}}{'BASENAME'}_BASE_NAME";
  20         $self->{BASE} =~ s/^([0-9])/_$1/;
  21         $self->{CALLBASE} = $self->{BASE};
  22         bless ($self, $class);
  23         return $self;
  24     }
  25
  26     sub header {
  27         my $self = shift;
  28         my $sfd  = $self->{SFD};
  29
  30         print "/* Automatically generated header! Do not edit! */\n";
  31         print "\n";
  32         print "#ifndef _INLINE_$$sfd{'BASENAME'}_H\n";
  33         print "#define _INLINE_$$sfd{'BASENAME'}_H\n";
  34         print "\n";
  35     }
  36
  37     sub function {
  38         my $self      = shift;
  39         my %params    = @_;
  40         my $prototype = $params{'prototype'};
  41         my $sfd       = $self->{SFD};
  42
  43         # Don't process private functions
  44         if ($prototype->{private}) {
  45             return;
  46         }
  47
  48         if ($$prototype{'type'} eq 'varargs') {
  49             if ($prototype->{subtype} eq 'tagcall') {
  50                 print "#ifndef NO_INLINE_STDARG\n";
  51             }
  52             else {
  53                 print "#ifndef NO_INLINE_VARARGS\n";
  54             }
  55         }
  56
  57         $self->function_define (prototype => $prototype);
  58         $self->function_start (prototype => $prototype);
  59         for my $i (0 .. $$prototype{'numargs'} - 1 ) {
  60             $self->function_arg (prototype => $prototype,
  61                                  argtype   => $$prototype{'argtypes'}[$i],
  62                                  argname   => $$prototype{'___argnames'}[$i],
  63                                  argreg    => $$prototype{'regs'}[$i],
  64                                  argnum    => $i );
  65         }
  66         $self->function_end (prototype => $prototype);
  67
  68         if ($$prototype{'type'} eq 'varargs') {
  69             if ($prototype->{subtype} eq 'tagcall') {
  70             print "#endif /* !NO_INLINE_STDARG */\n";
  71             }
  72             else {
  73             print "#endif /* !NO_INLINE_VARARGS */\n";
  74             }
  75         }
  76
  77         print "\n";
  78     }
  79
  80     sub footer {
  81         my $self = shift;
  82         my $sfd  = $self->{SFD};
  83
  84         print "#endif /* !_INLINE_$$sfd{'BASENAME'}_H */\n";
  85     }
  86
  87
  88     # Helper functions
  89
  90     sub function_define {
  91         my $self      = shift;
  92         my %params    = @_;
  93         my $prototype = $params{'prototype'};
  94         my $sfd       = $self->{SFD};
  95
  96         my $funcname  = $$prototype{'funcname'};
  97
  98         my $argnames_ref  = $$prototype{'___argnames'};
  99         my $argnames      = join (', ', @{$argnames_ref});
 100
 101         my $argnames2;
 102         my $argnames3 = join (', ', "___base", @{$argnames_ref});
 103
 104         if ($$prototype{'type'} eq 'varargs') {
 105             my $argnames_size = scalar(@{$argnames_ref});
 106             $argnames2 = join (', ', $self->{CALLBASE}, @{$argnames_ref}[0..($argnames_size-2)], "## __VA_ARGS__");
 107         }
 108         else {
 109             $argnames2 = join (', ', $self->{CALLBASE}, @{$argnames_ref});;
 110         }
 111
 112         print "#define $funcname($argnames) __${funcname}_WB($argnames2)\n";
 113         print "#define __${funcname}_WB($argnames3) \\\n";
 114     }
 115
 116     sub function_start {
 117         my $self      = shift;
 118         my %params    = @_;
 119         my $prototype = $params{'prototype'};
 120         my $sfd       = $self->{SFD};
 121         my $nr        = $$prototype{'return'} =~ /^(VOID|void)$/;
 122
 123         if ($$prototype{'type'} eq 'varargs') {
 124             if ($prototype->{subtype} eq 'tagcall' ||
 125                 $prototype->{subtype} eq 'methodcall') {
 126                 my $first_stdargnum = $$prototype{'numargs'} - 2;
 127                 my $first_stdarg = $$prototype{'___argnames'}[$first_stdargnum];
 128
 129                 printf "        ({IPTR _%s[] = { (IPTR) $first_stdarg, ## __VA_ARGS__ }; ",
 130                 $prototype->{subtype} eq 'tagcall' ? "tags" : "message";
 131                 print "__$$prototype{'real_funcname'}_WB((___base), ";
 132             }
 133             else {
 134                 print " ({APTR _args[] = { __VA_ARGS__ }; ";
 135
 136                 print "__$$prototype{'real_funcname'}_WB((___base), ";
 137             }
 138         }
 139         elsif ($prototype->{type} eq 'cfunction') {
 140             my $argtypes = join (', ',@{$$prototype{'argtypes'}});
 141
 142             if ($argtypes eq '') {
 143                 if ($prototype->{nb}) {
 144                     $argtypes = "void";
 145                 }
 146             }
 147             else {
 148                 if (!$prototype->{nb}) {
 149                     $argtypes = "$sfd->{basetype}, $argtypes";
 150                 }
 151             }
 152
 153             print "     ({$$prototype{'return'} (*_func) ($argtypes) = \\\n";
 154             print "         ($$prototype{'return'} (*) ($argtypes))\\\n";
 155
 156             if ($$classes{'target'} eq 'morphos') {
 157                 # Skip jmp instruction (is m68k ILLEGAL in MorphOS)
 158                 my $o = $$prototype{'bias'} - 2;
 159                 print "     *((ULONG*) (((char*) (___base)) - $o));\\\n";
 160             }
 161             elsif ($classes->{target} eq 'aros') {
 162                 my $o = $$prototype{'bias'} / 6;
 163                 print "     __AROS_GETVECADDR((___base), $o);\\\n";
 164             }
 165             else {
 166                 my $o = $$prototype{'bias'};
 167                 print "     (((char*) (___base)) - $o);\\\n";
 168             }
 169
 170             print "       (*_func)(";
 171
 172             if (!$prototype->{nb}) {
 173                 print "(___base)";
 174                 print ", " unless $prototype->{numargs} == 0;
 175             }
 176         }
 177         else {
 178             print STDERR "$prototype->{funcname}: Unhandled.\n";
 179             die;
 180         }
 181     }
 182
 183     sub function_arg {
 184         my $self      = shift;
 185         my %params    = @_;
 186         my $prototype = $params{'prototype'};
 187         my $argtype   = $params{'argtype'};
 188         my $argname   = $params{'argname'};
 189         my $argreg    = $params{'argreg'};
 190         my $argnum    = $params{'argnum'};
 191         my $sfd       = $self->{SFD};
 192
 193         if ($$prototype{'type'} eq 'varargs') {
 194             if ($prototype->{subtype} eq 'tagcall' ||
 195                 $prototype->{subtype} eq 'methodcall') {
 196                 my $first_stdargnum = $$prototype{'numargs'} - 2;
 197
 198                 # Skip the first stdarg completely
 199                 if( $argnum != $first_stdargnum ) {
 200                     if ($argname eq '...') {
 201                         if ($prototype->{subtype} eq 'tagcall') {
 202                             print "($argtype) _tags";
 203                         }
 204                         else {
 205                             print "($argtype) _message";
 206                         }
 207                     }
 208                     else {
 209                         print "($argname), ";
 210                     }
 211                 }
 212             }
 213             else {
 214                 if ($argname eq '...') {
 215                     print "($argtype) _args";
 216                 }
 217                 else {
 218                     print "($argname), ";
 219                 }
 220             }
 221         }
 222         elsif ($prototype->{type} eq 'cfunction') {
 223             if ($argname eq '...' ) {
 224                 print ($argnum != 0 ? ", ## __VA_ARGS__" : "__VA_ARGS__");
 225             }
 226             else {
 227                 print ($argnum != 0 ? ", ($argname)" : "($argname)");
 228             }
 229         }
 230         else {
 231             print STDERR "$prototype->{funcname}: Unhandled.\n";
 232             die;
 233         }
 234     }
 235
 236     sub function_end {
 237         my $self      = shift;
 238         my %params    = @_;
 239         my $prototype = $params{'prototype'};
 240         my $sfd       = $self->{SFD};
 241
 242
 243         print "); })\n";
 244     }
 245 }