ext/xvarpp

   1 #!/usr/bin/perl
   2 # $Header$
   3
   4 $usage = "Usage: xvar [-a] [-c] typemap file.xv\n";
   5 die $usage unless (@ARGV >= 2 && @ARGV <= 4);
   6
   7 SWITCH: while ($ARGV[0] =~ /^-/) {
   8     $flag = shift @ARGV;
   9     $aflag = 1, next SWITCH if $flag =~ /^-a$/;
  10     $cflag = 1, next SWITCH if $flag =~ /^-c$/;
  11     die $usage;
  12 }
  13
  14 $typemap = shift @ARGV;
  15 open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
  16 while (<TYPEMAP>) {
  17         next if /^\s*$/ || /^#/;
  18         chop;
  19         ($typename, $kind) = split(/\t+/);
  20         $type_kind{$typename} = $kind;
  21 }
  22 close(TYPEMAP);
  23
  24 $uvfile = shift @ARGV;
  25 open(F, $uvfile) || die "cannot open $uvfile\n";
  26 #($uvoutfile = $uvfile) =~ s|^.*/([^/]*).us$|\1.c| ;
  27 #print "uvoutfile is $uvoutfile\n";
  28
  29 #open(FOUT, ">$uvoutfile") || die "cannot open $uvoutfile\n";
  30 #select(FOUT);
  31
  32 while (<F>) {
  33         last if ($Module, $foo, $Package, $foo1, $Prefix) =
  34                 /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(\w+))?/;
  35         print $_;
  36 }
  37 $Package .= "::" if defined $Package && $Package ne "";
  38 print <<EOF;
  39 static struct varinfo varinfo [] = {
  40 EOF
  41
  42 while (<F>) {
  43         next if /^s*$/ || /^#/;
  44         if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(\w+))?/) {
  45                 $Module = $1;
  46                 $foo = $2;
  47                 $Package = $3;
  48                 $foo1 = $4;
  49                 $Prefix = $5;
  50                 $Package .= "'" if defined $Package && $Package ne "";
  51                 next;
  52         }
  53         chop;
  54         $func = undef;
  55         ($var, $kind, $store, $read) = split(/\t+/);
  56         die "$kind not defined in typemap\n" if !defined($type_kind{$kind});
  57         $flags = "0";
  58         if ($store =~ /FUNC=(.*)/) {
  59                 $flags .= "|VI_FUNC";
  60                 $func = $1;
  61         } elsif ($store eq "VAR") {
  62                 $flags .= "|VI_VARIABLE";
  63         } elsif ($store ne "VAL") {
  64                 die "$var storage class not VAL, VAR or FUNC\n";
  65         }
  66         if ($read eq "READWRITE") {
  67                 $flags .= "|VI_READWRITE";
  68         } elsif ($read ne "READONLY") {
  69                 die "$var access class not READONLY or READWRITE\n";
  70         }
  71         SIZE: {
  72                 $type_kind = $type_kind{$kind};
  73                 $size = 0;
  74                 do {$size = "sizeof(int)"; last SIZE; }
  75                                                 if ($type_kind eq "T_INT");
  76                 do {$size = "sizeof($kind)"; last SIZE; }
  77                                                 if ($type_kind eq "T_ENUM");
  78                 do {$size = "sizeof(unsigned int)"; last SIZE; }
  79                                                 if ($type_kind eq "T_U_INT");
  80                 do {$size = "sizeof(short)"; last SIZE; }
  81                                                 if ($type_kind eq "T_SHORT");
  82                 do {$size = "sizeof(unsigned short)"; last SIZE; }
  83                                                 if ($type_kind eq "T_U_SHORT");
  84                 do {$size = "sizeof(long)"; last SIZE; }
  85                                                 if ($type_kind eq "T_LONG");
  86                 do {$size = "sizeof(unsigned long)"; last SIZE; }
  87                                                 if ($type_kind eq "T_U_LONG");
  88                 do {$size = "sizeof(char)"; last SIZE; }
  89                                                 if ($type_kind eq "T_CHAR");
  90                 do {$size = "sizeof(unsigned char)"; last SIZE; }
  91                                                 if ($type_kind eq "T_U_CHAR");
  92                 do {$size = "0"; last SIZE; }
  93                                                 if ($type_kind eq "T_STRING");
  94                 do {$size = "sizeof(char *)"; last SIZE; }
  95                                                 if ($type_kind eq "T_PTR");
  96                 do {$size = "sizeof($kind)"; last SIZE; }
  97                                                 if ($type_kind eq "T_OPAQUE");
  98         }
  99         ($name = $var) =~ s/^$Prefix//;
 100         print "    { \"$Package$name\", $type_kind, $flags, $size, ";
 101         if ($store =~ /FUNC/) {
 102                 print "(char *)$func, 0.0 },\n";
 103         } elsif ($store eq "VAR") {
 104                 print "(char *)&$var, 0.0 },\n";
 105         } elsif ($type_kind eq "T_FLOAT" || $type_kind eq "T_DOUBLE") {
 106                 print "0, $var },\n";
 107         } else {
 108                 print "(char *)$var, 0.0 },\n";
 109         }
 110 }
 111 print <<EOF if $aflag;
 112 };
 113
 114 static unsigned long varinfolen = sizeof(varinfo)/sizeof(*varinfo);
 115
 116 static int UV_val(int ix, SV *sv)
 117 {
 118     return common_UV_val(varinfo, varinfolen, ix, sv);
 119 }
 120
 121 static int UV_set(int ix, SV *sv)
 122 {
 123     return common_UV_set(varinfo, varinfolen, ix, sv);
 124 }
 125 EOF
 126 print <<EOF if !$aflag;
 127 };
 128
 129 static unsigned long varinfolen = sizeof(varinfo)/sizeof(*varinfo);
 130
 131 static int UV_val(ix, sv)
 132 int ix;
 133 SV *sv;
 134 {
 135     return common_UV_val(varinfo, varinfolen, ix, sv);
 136 }
 137
 138 static int UV_set(ix, sv)
 139 int ix;
 140 SV *sv;
 141 {
 142     return common_UV_set(varinfo, varinfolen, ix, sv);
 143 }
 144
 145 EOF
 146 print qq/extern "C"\n/ if $cflag;
 147 print <<EOF;
 148 void init_$Module()
 149 {
 150     int         i;
 151     struct      ufuncs uf;
 152
 153     uf.uf_set = UV_set;
 154     uf.uf_val = UV_val;
 155     for (i = 0; i < varinfolen; i++) {
 156         uf.uf_index = i;
 157         magicname(varinfo[i].vname, (char *)&uf, sizeof uf);
 158     }
 159 }
 160
 161 EOF