perl 5.0 alpha 3
[perl.git] / usub / 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 }