perl 5.0 alpha 3
[perl.git] / usub / tuv
1 #!/usr/bin/perl
2 # $Header$ 
3
4 $usage = "Usage: tuv [-a] [-c] typemap file.uv\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, STR *str)
117 {
118     return common_UV_val(varinfo, varinfolen, ix, str);
119 }
120
121 static int UV_set(int ix, STR *str)
122 {
123     return common_UV_set(varinfo, varinfolen, ix, str);
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, str)
132 int ix;
133 STR *str;
134 {
135     return common_UV_val(varinfo, varinfolen, ix, str);
136 }
137
138 static int UV_set(ix, str)
139 int ix;
140 STR *str;
141 {
142     return common_UV_set(varinfo, varinfolen, ix, str);
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