home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / PERL4036.ZIP / usub / mus < prev    next >
Text File  |  1993-02-08  |  3KB  |  136 lines
  1. #!/usr/bin/perl
  2.  
  3. while (<>) {
  4.     if (s/^CASE\s+//) {
  5.     @fields = split;
  6.     $funcname = pop(@fields);
  7.     $rettype = "@fields";
  8.     @modes = ();
  9.     @types = ();
  10.     @names = ();
  11.     @outies = ();
  12.     @callnames = ();
  13.     $pre = "\n";
  14.     $post = '';
  15.  
  16.     while (<>) {
  17.         last unless /^[IO]+\s/;
  18.         @fields = split(' ');
  19.         push(@modes, shift(@fields));
  20.         push(@names, pop(@fields));
  21.         push(@types, "@fields");
  22.     }
  23.     while (s/^<\s//) {
  24.         $pre .= "\t    $_";
  25.         $_ = <>;
  26.     }
  27.     while (s/^>\s//) {
  28.         $post .= "\t    $_";
  29.         $_ = <>;
  30.     }
  31.     $items = @names;
  32.     $namelist = '$' . join(', $', @names);
  33.     $namelist = '' if $namelist eq '$';
  34.     print <<EOF;
  35.     case US_$funcname:
  36.     if (items != $items)
  37.         fatal("Usage: &$funcname($namelist)");
  38.     else {
  39. EOF
  40.     if ($rettype eq 'void') {
  41.         print <<EOF;
  42.         int retval = 1;
  43. EOF
  44.     }
  45.     else {
  46.         print <<EOF;
  47.         $rettype retval;
  48. EOF
  49.     }
  50.     foreach $i (1..@names) {
  51.         $mode = $modes[$i-1];
  52.         $type = $types[$i-1];
  53.         $name = $names[$i-1];
  54.         if ($type =~ /^[A-Z]+\*$/) {
  55.         $cast = "*($type*)";
  56.         }
  57.         else {
  58.         $cast = "($type)";
  59.         }
  60.         $what = ($type =~ /^(struct\s+\w+|char|[A-Z]+)\s*\*$/ ? "get" : "gnum");
  61.         $type .= "\t" if length($type) < 4;
  62.         $cast .= "\t" if length($cast) < 8;
  63.         $x = "\t" x (length($name) < 6);
  64.         if ($mode =~ /O/) {
  65.         if ($what eq 'gnum') {
  66.             push(@outies, "\t    str_numset(st[$i], (double) $name);\n");
  67.             push(@callnames, "&$name");
  68.         }
  69.         else {
  70.             push(@outies, "\t    str_set(st[$i], (char*) $name);\n");
  71.             push(@callnames, "$name");
  72.         }
  73.         }
  74.         else {
  75.         push(@callnames, $name);
  76.         }
  77.         if ($mode =~ /I/) {
  78.         print <<EOF;
  79.         $type    $name =$x    $cast    str_$what(st[$i]);
  80. EOF
  81.         }
  82.             elsif ($type =~ /char/) {
  83.             print <<EOF;
  84.         char    ${name}[133];
  85. EOF
  86.         }
  87.         else {
  88.         print <<EOF;
  89.         $type    $name;
  90. EOF
  91.         }
  92.     }
  93.     $callnames = join(', ', @callnames);
  94.     $outies = join("\n",@outies);
  95.     if ($rettype eq 'void') {
  96.         print <<EOF;
  97. $pre        (void)$funcname($callnames);
  98. EOF
  99.     }
  100.     else {
  101.         print <<EOF;
  102. $pre        retval = $funcname($callnames);
  103. EOF
  104.     }
  105.     if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) {
  106.         print <<EOF;
  107.         str_set(st[0], (char*) retval);
  108. EOF
  109.     }
  110.     elsif ($rettype =~ /^[A-Z]+\s*\*$/) {
  111.         print <<EOF;
  112.         str_nset(st[0], (char*) &retval, sizeof retval);
  113. EOF
  114.     }
  115.     else {
  116.         print <<EOF;
  117.         str_numset(st[0], (double) retval);
  118. EOF
  119.     }
  120.     print $outies if $outies;
  121.     print $post if $post;
  122.     if (/^END/) {
  123.         print "\t}\n\treturn sp;\n";
  124.     }
  125.     else {
  126.         redo;
  127.     }
  128.     }
  129.     elsif (/^END/) {
  130.     print "\t}\n\treturn sp;\n";
  131.     }
  132.     else {
  133.     print;
  134.     }
  135. }
  136.