ext/mus

   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 }