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 }