This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 3
[perl5.git] / usub / tus
CommitLineData
93a17b20
LW
1#!/usr/bin/perl
2# $Header$
3
4$usage = "Usage: tus [-a] [-s] [-c] typemap file.us\n";
5die $usage unless (@ARGV >= 2 && @ARGV <= 6);
6
7SWITCH: 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;
17open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
18while (<TYPEMAP>) {
19 next if /^\s*$/ || /^#/;
20 chop;
21 ($typename, $kind) = split(/\t+/, $_, 2);
22 $type_kind{$typename} = $kind;
23}
24close(TYPEMAP);
25
26%input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));
27
28T_INT
29 $var = (int)str_gnum($arg)
30T_ENUM
31 $var = ($type)str_gnum($arg)
32T_U_INT
33 $var = (unsigned int)str_gnum($arg)
34T_SHORT
35 $var = (short)str_gnum($arg)
36T_U_SHORT
37 $var = (unsigned short)str_gnum($arg)
38T_LONG
39 $var = (long)str_gnum($arg)
40T_U_LONG
41 $var = (unsigned long)str_gnum($arg)
42T_CHAR
43 $var = (char)*str_get($arg)
44T_U_CHAR
45 $var = (unsigned char)str_gnum($arg)
46T_FLOAT
47 $var = (float)str_gnum($arg)
48T_DOUBLE
49 $var = str_gnum($arg)
50T_STRING
51 $var = str_get($arg)
52T_PTR
53 $var = ($type)(unsigned long)str_gnum($arg)
54T_OPAQUE
55 $var NOT IMPLEMENTED
56T_OPAQUEPTR
57 $var = ($type)str_get($arg)
58T_PACKED
59 $var = US_unpack_$ntype($arg)
60T_PACKEDARRAY
61 $var = US_unpack_$ntype($arg)
62T_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}\"))
67T_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\"))
72T_DATAUNIT
73 $var = DataUnit(U32($arg->str_cur), (Octet*)$arg->str_ptr)
74T_CALLBACK
75 $var = make_perl_cb_$type($arg)
76T_ARRAY
77 $var = $ntype(items -= $argoff);
78 U32 ix_$var = $argoff;
79 while (items--) {
80 DO_ARRAY_ELEM;
81 }
82T_PLACEHOLDER
83T_END
84
85$* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
86T_INT
87 str_numset($arg, (double)$var);
88T_ENUM
89 str_numset($arg, (double)(int)$var);
90T_U_INT
91 str_numset($arg, (double)$var);
92T_SHORT
93 str_numset($arg, (double)$var);
94T_U_SHORT
95 str_numset($arg, (double)$var);
96T_LONG
97 str_numset($arg, (double)$var);
98T_U_LONG
99 str_numset($arg, (double)$var);
100T_CHAR
101 str_set($arg, (char *)&$var, 1);
102T_U_CHAR
103 str_numset($arg, (double)$var);
104T_FLOAT
105 str_numset($arg, (double)$var);
106T_DOUBLE
107 str_numset($arg, $var);
108T_STRING
109 str_set($arg, $var);
110T_PTR
111 str_numset($arg, (double)(unsigned long)$var);
112T_OPAQUE
113 str_nset($arg, (char *)&$var, sizeof($var));
114T_OPAQUEPTR
115 str_nset($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
116T_PACKED
117 US_pack_$ntype($arg, $var);
118T_PACKEDARRAY
119 US_pack_$ntype($arg, $var, count_$ntype);
120T_REF
121 ref_construct($arg, \"${ntype}\", US_service_$ntype,
122 ($var ? (void*)new $ntype($var) : 0));
123T_REFPTR
124 NOT IMPLEMENTED
125T_DATAUNIT
126 str_nset($arg, $var.chp(), $var.size());
127T_CALLBACK
128 str_nset($arg, $var.context.value().chp(),
129 $var.context.value().size());
130T_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;
137T_END
138
139$uvfile = shift @ARGV;
140open(F, $uvfile) || die "cannot open $uvfile\n";
141
142if ($eflag) {
143 print qq|#include "cfm/basic.h"\n|;
144}
145
146while (<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
155while (<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;
229static int
230US_${Pack}_$func_name(int, int sp, int items)
231EOF
232 print <<"EOF" if !$aflag;
233static int
234US_${Pack}_$func_name(ix, sp, items)
235register int ix;
236register int sp;
237register int items;
238EOF
239 print <<"EOF" if $elipsis;
240{
241 if (items < $min_args) {
242 fatal("Usage: $pname($orig_args)");
243 }
244EOF
245 print <<"EOF" if !$elipsis;
246{
247 if (items < $min_args || items > $num_args) {
248 fatal("Usage: $pname($orig_args)");
249 }
250EOF
251
252# Now do a block of some sort.
253
254$condnum = 0;
255if (!@_) {
256 @_ = "CLEANUP:";
257}
258while (@_) {
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 {
275EOF
276 print <<"EOF" if !$eflag;
277 {
278EOF
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
385EOF
386 print <<EOF if !$eflag;
387 }
388EOF
389 if (/^\s*CASE\s*:/) {
390 unshift(@_, $_);
391 }
392}
393 print <<EOF;
394 return sp;
395}
396
397EOF
398}
399
400# print initialization routine
401print qq/extern "C"\n/ if $cflag;
402print <<"EOF";
403void init_$Module()
404{
405EOF
406
407for (@Func_name) {
408 $pname = shift(@Func_pname);
409 print " make_usub(\"$pname\", 0, US_$_, __FILE__);\n";
410}
411print "}\n";
412
413sub output_init {
414 local($type, $num, $init) = @_;
415 local($arg) = "ST($num)";
416
417 eval "print \" $init\n\"";
418}
419
420sub 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
452sub 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
480sub map_type {
481 local($type) = @_;
482
483 if ($type =~ /^array\(([^,]*),(.*)\)/) {
484 return "$1 *";
485 } else {
486 return $type;
487 }
488}