perl 5.0 alpha 3
[perl.git] / usub / tus
1 #!/usr/bin/perl
2 # $Header$ 
3
4 $usage = "Usage: tus [-a] [-s] [-c] typemap file.us\n";
5 die $usage unless (@ARGV >= 2 && @ARGV <= 6);
6
7 SWITCH: while ($ARGV[0] =~ /^-/) {
8     $flag = shift @ARGV;
9     $aflag = 1, next SWITCH if $flag =~ /^-a$/;
10     $spat = $1, next SWITCH if $flag =~ /^-s(.*)$/;
11     $cflag = 1, next SWITCH if $flag =~ /^-c$/;
12     $eflag = 1, next SWITCH if $flag =~ /^-e$/;
13     die $usage;
14 }
15
16 $typemap = shift @ARGV;
17 open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
18 while (<TYPEMAP>) {
19         next if /^\s*$/ || /^#/;
20         chop;
21         ($typename, $kind) = split(/\t+/, $_, 2);
22         $type_kind{$typename} = $kind;
23 }
24 close(TYPEMAP);
25
26 %input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));
27
28 T_INT
29         $var = (int)str_gnum($arg)
30 T_ENUM
31         $var = ($type)str_gnum($arg)
32 T_U_INT
33         $var = (unsigned int)str_gnum($arg)
34 T_SHORT
35         $var = (short)str_gnum($arg)
36 T_U_SHORT
37         $var = (unsigned short)str_gnum($arg)
38 T_LONG
39         $var = (long)str_gnum($arg)
40 T_U_LONG
41         $var = (unsigned long)str_gnum($arg)
42 T_CHAR
43         $var = (char)*str_get($arg)
44 T_U_CHAR
45         $var = (unsigned char)str_gnum($arg)
46 T_FLOAT
47         $var = (float)str_gnum($arg)
48 T_DOUBLE
49         $var = str_gnum($arg)
50 T_STRING
51         $var = str_get($arg)
52 T_PTR
53         $var = ($type)(unsigned long)str_gnum($arg)
54 T_OPAQUE
55         $var NOT IMPLEMENTED
56 T_OPAQUEPTR
57         $var = ($type)str_get($arg)
58 T_PACKED
59         $var = US_unpack_$ntype($arg)
60 T_PACKEDARRAY
61         $var = US_unpack_$ntype($arg)
62 T_REF
63         if (ref_ok($arg, \"${ntype}\"))
64             $var = *(${ntype}Ptr)$arg->str_magic->str_u.str_stab;
65         else
66             Tthrow(InvalidX(\"$var is not of type ${ntype}\"))
67 T_REFPTR
68         if (ref_ok($arg, \"$subtype\"))
69             $var = ($ntype)$arg->str_magic->str_u.str_stab;
70         else
71             Tthrow(InvalidX(\"$var is not of type $subtype\"))
72 T_DATAUNIT
73         $var = DataUnit(U32($arg->str_cur), (Octet*)$arg->str_ptr)
74 T_CALLBACK
75         $var = make_perl_cb_$type($arg)
76 T_ARRAY
77         $var = $ntype(items -= $argoff);
78         U32 ix_$var = $argoff;
79         while (items--) {
80             DO_ARRAY_ELEM;
81         }
82 T_PLACEHOLDER
83 T_END
84
85 $* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
86 T_INT
87         str_numset($arg, (double)$var);
88 T_ENUM
89         str_numset($arg, (double)(int)$var);
90 T_U_INT
91         str_numset($arg, (double)$var);
92 T_SHORT
93         str_numset($arg, (double)$var);
94 T_U_SHORT
95         str_numset($arg, (double)$var);
96 T_LONG
97         str_numset($arg, (double)$var);
98 T_U_LONG
99         str_numset($arg, (double)$var);
100 T_CHAR
101         str_set($arg, (char *)&$var, 1);
102 T_U_CHAR
103         str_numset($arg, (double)$var);
104 T_FLOAT
105         str_numset($arg, (double)$var);
106 T_DOUBLE
107         str_numset($arg, $var);
108 T_STRING
109         str_set($arg, $var);
110 T_PTR
111         str_numset($arg, (double)(unsigned long)$var);
112 T_OPAQUE
113         str_nset($arg, (char *)&$var, sizeof($var));
114 T_OPAQUEPTR
115         str_nset($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
116 T_PACKED
117         US_pack_$ntype($arg, $var);
118 T_PACKEDARRAY
119         US_pack_$ntype($arg, $var, count_$ntype);
120 T_REF
121         ref_construct($arg, \"${ntype}\", US_service_$ntype,
122                     ($var ? (void*)new $ntype($var) : 0));
123 T_REFPTR
124         NOT IMPLEMENTED
125 T_DATAUNIT      
126         str_nset($arg, $var.chp(), $var.size());
127 T_CALLBACK
128         str_nset($arg, $var.context.value().chp(),
129                 $var.context.value().size());
130 T_ARRAY
131         ST_EXTEND($var.size);
132         for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
133                 ST(ix_$var) = str_mortal(&str_undef);
134         DO_ARRAY_ELEM
135         }
136         sp += $var.size - 1;
137 T_END
138
139 $uvfile = shift @ARGV;
140 open(F, $uvfile) || die "cannot open $uvfile\n";
141
142 if ($eflag) {
143         print qq|#include "cfm/basic.h"\n|;
144 }
145
146 while (<F>) {
147         last if ($Module, $foo, $Package, $foo1, $Prefix) =
148                 /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/;
149         print $_;
150 }
151 $Pack = $Package;
152 $Package .= "'" if defined $Package && $Package ne "";
153 $/ = "";
154
155 while (<F>) {
156         # parse paragraph
157         chop;
158         next if /^\s*$/;
159         next if /^(#.*\n?)+$/;
160         if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/) {
161                 $Module = $1;
162                 $foo = $2;
163                 $Package = $3;
164                 $Pack = $Package;
165                 $foo1 = $4;
166                 $Prefix = $5;
167                 $Package .= "'" if defined $Package && $Package ne "";
168                 next;
169         }
170         split(/[\t ]*\n/);
171
172         # initialize info arrays
173         undef(%args_match);
174         undef(%var_types);
175         undef(%var_addr);
176         undef(%defaults);
177         undef($class);
178         undef($static);
179         undef($elipsis);
180
181         # extract return type, function name and arguments
182         $ret_type = shift(@_);
183         if ($ret_type =~ /^static\s+(.*)$/) {
184                 $static = 1;
185                 $ret_type = $1;
186         }
187         $func_header = shift(@_);
188         ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
189         if ($func_name =~ /(.*)::(.*)/) {
190                 $class = $1;
191                 $func_name = $2;
192         }
193         ($pname = $func_name) =~ s/^($Prefix)?/$Package/;
194         push(@Func_name, "${Pack}_$func_name");
195         push(@Func_pname, $pname);
196         @args = split(/\s*,\s*/, $orig_args);
197         if (defined($class) && !defined($static)) {
198                 unshift(@args, "THIS");
199                 $orig_args = "THIS, $orig_args";
200                 $orig_args =~ s/^THIS, $/THIS/;
201         }
202         $orig_args =~ s/"/\\"/g;
203         $min_args = $num_args = @args;
204         foreach $i (0..$num_args-1) {
205                 if ($args[$i] =~ s/\.\.\.//) {
206                         $elipsis = 1;
207                         $min_args--;
208                         if ($args[i] eq '' && $i == $num_args - 1) {
209                             pop(@args);
210                             last;
211                         }
212                 }
213                 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
214                         $min_args--;
215                         $args[$i] = $1;
216                         $defaults{$args[$i]} = $2;
217                         $defaults{$args[$i]} =~ s/"/\\"/g;
218                 }
219         }
220         if (defined($class) && !defined($static)) {
221                 $func_args = join(", ", @args[1..$#args]);
222         } else {
223                 $func_args = join(", ", @args);
224         }
225         @args_match{@args} = 1..@args;
226
227         # print function header
228         print <<"EOF" if $aflag;
229 static int
230 US_${Pack}_$func_name(int, int sp, int items)
231 EOF
232         print <<"EOF" if !$aflag;
233 static int
234 US_${Pack}_$func_name(ix, sp, items)
235 register int ix;
236 register int sp;
237 register int items;
238 EOF
239         print <<"EOF" if $elipsis;
240 {
241     if (items < $min_args) {
242         fatal("Usage: $pname($orig_args)");
243     }
244 EOF
245         print <<"EOF" if !$elipsis;
246 {
247     if (items < $min_args || items > $num_args) {
248         fatal("Usage: $pname($orig_args)");
249     }
250 EOF
251
252 # Now do a block of some sort.
253
254 $condnum = 0;
255 if (!@_) {
256     @_ = "CLEANUP:";
257 }
258 while (@_) {
259         if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
260                 $cond = shift(@_);
261                 if ($condnum == 0) {
262                     print "    if ($cond)\n";
263                 }
264                 elsif ($cond ne '') {
265                     print "    else if ($cond)\n";
266                 }
267                 else {
268                     print "    else\n";
269                 }
270                 $condnum++;
271         }
272
273         print           <<"EOF" if $eflag;
274     TRY {
275 EOF
276         print           <<"EOF" if !$eflag;
277     {
278 EOF
279
280         # do initialization of input variables
281         $thisdone = 0;
282         $retvaldone = 0;
283         while ($_ = shift(@_)) {
284                 last if /^\s*NOT_IMPLEMENTED_YET/;
285                 last if /^\s*(CODE|OUTPUT|CLEANUP|CASE)\s*:/;
286                 ($var_type, $var_name, $var_init) =
287                     /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
288                 if ($var_name =~ /^&/) {
289                         $var_name =~ s/^&//;
290                         $var_addr{$var_name} = 1;
291                 }
292                 $thisdone |= $var_name eq "THIS";
293                 $retvaldone |= $var_name eq "RETVAL";
294                 $var_types{$var_name} = $var_type;
295                 print "\t" . &map_type($var_type);
296                 $var_num = $args_match{$var_name};
297                 if ($var_addr{$var_name}) {
298                         $func_args =~ s/\b($var_name)\b/&\1/;
299                 }
300                 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
301                         if ($var_init !~ /^\s*$/) {
302                                 &output_init($var_type, $var_num,
303                                     "$var_name $var_init");
304                         } elsif ($var_num) {
305                                 # generate initialization code
306                                 &generate_init($var_type, $var_num, $var_name);
307                         } else {
308                                 print ";\n";
309                         }
310                 } else {
311                         print "\t$var_name;\n";
312                 }
313         }
314         if (!$thisdone && defined($class) && !defined($static)) {
315                 print "\t$class *";
316                 $var_types{"THIS"} = "$class *";
317                 &generate_init("$class *", 1, "THIS");
318         }
319
320         # do code
321         if (/^\s*NOT_IMPLEMENTED_YET/) {
322                 print "\nfatal(\"$pname: not implemented yet\");\n";
323         } else {
324                 if ($ret_type ne "void") {
325                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
326                                 if !$retvaldone;
327                         $args_match{"RETVAL"} = 0;
328                         $var_types{"RETVAL"} = $ret_type;
329                 }
330                 if (/^\s*CODE:/) {
331                         while ($_ = shift(@_)) {
332                                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
333                                 print "$_\n";
334                         }
335                 } else {
336                         print "\n\t";
337                         if ($ret_type ne "void") {
338                                 print "RETVAL = (".&map_type($ret_type).")";
339                         }
340                         if (defined($static)) {
341                                 print "$class::";
342                         } elsif (defined($class)) {
343                                 print "THIS->";
344                         }
345                         if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
346                                 $func_name = $2;
347                         }
348                         print "$func_name($func_args);\n";
349                         &generate_output($ret_type, 0, "RETVAL")
350                             unless $ret_type eq "void";
351                 }
352         }
353
354         # do output variables
355         if (/^\s*OUTPUT\s*:/) {
356                 while ($_ = shift(@_)) {
357                         last if /^\s*CLEANUP\s*:/;
358                         s/^\s+//;
359                         ($outarg, $outcode) = split(/\t+/);
360                         if ($outcode) {
361                         print "\t$outcode\n";
362                         } else {
363                                 die "$outarg not an argument"
364                                     unless defined($args_match{$outarg});
365                                 $var_num = $args_match{$outarg};
366                                 &generate_output($var_types{$outarg}, $var_num,
367                                     $outarg); 
368                         }
369                 }
370         }
371         # do cleanup
372         if (/^\s*CLEANUP\s*:/) {
373             while ($_ = shift(@_)) {
374                     last if /^\s*CASE\s*:/;
375                     print "$_\n";
376             }
377         }
378         # print function trailer
379         print <<EOF if $eflag;
380     }
381     BEGHANDLERS
382     CATCHALL
383         fatal("%s: %s\\tpropagated", Xname, Xreason);
384     ENDHANDLERS
385 EOF
386         print <<EOF if !$eflag;
387     }
388 EOF
389         if (/^\s*CASE\s*:/) {
390             unshift(@_, $_);
391         }
392 }
393         print <<EOF;
394     return sp;
395 }
396
397 EOF
398 }
399
400 # print initialization routine
401 print qq/extern "C"\n/ if $cflag;
402 print <<"EOF";
403 void init_$Module()
404 {
405 EOF
406
407 for (@Func_name) {
408         $pname = shift(@Func_pname);
409         print "    make_usub(\"$pname\", 0, US_$_, __FILE__);\n";
410 }
411 print "}\n";
412
413 sub output_init {
414         local($type, $num, $init) = @_;
415         local($arg) = "ST($num)";
416
417         eval "print \" $init\n\"";
418 }
419
420 sub generate_init {
421         local($type, $num, $var) = @_;
422         local($arg) = "ST($num)";
423         local($argoff) = $num - 1;
424         local($ntype);
425
426         die "$type not in typemap" if !defined($type_kind{$type});
427         ($ntype = $type) =~ s/\s*\*/Ptr/g;
428         $subtype = $ntype;
429         $subtype =~ s/Ptr$//;
430         $subtype =~ s/Array$//;
431         $expr = $input_expr{$type_kind{$type}};
432         if ($expr =~ /DO_ARRAY_ELEM/) {
433             $subexpr = $input_expr{$type_kind{$subtype}};
434             $subexpr =~ s/ntype/subtype/g;
435             $subexpr =~ s/\$arg/ST(ix_$var)/g;
436             $subexpr =~ s/\n\t/\n\t\t/g;
437             $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
438             $subexpr =~ s/\$var/$var[ix_$var - $argoff]/;
439             $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
440         }
441         if (defined($defaults{$var})) {
442                 $expr =~ s/(\t+)/$1    /g;
443                 $expr =~ s/        /\t/g;
444                 eval "print \"\t$var;\n\tif (items < $num)\n\t    $var = $defaults{$var};\n\telse {\n$expr;\n\t}\n\"";
445         } elsif ($expr !~ /^\t\$var =/) {
446                 eval "print \"\t$var;\n$expr;\n\"";
447         } else {
448                 eval "print \"$expr;\n\"";
449         }
450 }
451
452 sub generate_output {
453         local($type, $num, $var) = @_;
454         local($arg) = "ST($num)";
455         local($argoff) = $num - 1;
456         local($ntype);
457
458         if ($type =~ /^array\(([^,]*),(.*)\)/) {
459                 print "\tstr_nset($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
460         } else {
461                 die "$type not in typemap" if !defined($type_kind{$type});
462                 ($ntype = $type) =~ s/\s*\*/Ptr/g;
463                 $ntype =~ s/\(\)//g;
464                 $subtype = $ntype;
465                 $subtype =~ s/Ptr$//;
466                 $subtype =~ s/Array$//;
467                 $expr = $output_expr{$type_kind{$type}};
468                 if ($expr =~ /DO_ARRAY_ELEM/) {
469                     $subexpr = $output_expr{$type_kind{$subtype}};
470                     $subexpr =~ s/ntype/subtype/g;
471                     $subexpr =~ s/\$arg/ST(ix_$var)/g;
472                     $subexpr =~ s/\$var/${var}[ix_$var]/g;
473                     $subexpr =~ s/\n\t/\n\t\t/g;
474                     $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
475                 }
476                 eval "print qq\f$expr\f";
477         }
478 }
479
480 sub map_type {
481         local($type) = @_;
482
483         if ($type =~ /^array\(([^,]*),(.*)\)/) {
484                 return "$1 *";
485         } else {
486                 return $type;
487         }
488 }