perl 3.0 patch #23 patch #19, continued
[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                 }
68                 else {
69                     push(@outies, "\t    str_set(st[$i], (char*) $name);\n");
70                 }
71                 push(@callnames, "&$name");
72             }
73             else {
74                 push(@callnames, $name);
75             }
76             if ($mode =~ /I/) {
77             print <<EOF;
78             $type       $name =$x       $cast   str_$what(st[$i]);
79 EOF
80             }
81             else {
82                 print <<EOF;
83             $type       $name;
84 EOF
85             }
86         }
87         $callnames = join(', ', @callnames);
88         $outies = join("\n",@outies);
89         if ($rettype eq 'void') {
90             print <<EOF;
91 $pre        (void)$funcname($callnames);
92 EOF
93         }
94         else {
95             print <<EOF;
96 $pre        retval = $funcname($callnames);
97 EOF
98         }
99         if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) {
100             print <<EOF;
101             str_set(st[0], (char*) retval);
102 EOF
103         }
104         elsif ($rettype =~ /^[A-Z]+\s*\*$/) {
105             print <<EOF;
106             str_set(st[0], (char*) &retval, sizeof retval);
107 EOF
108         }
109         else {
110             print <<EOF;
111             str_numset(st[0], (double) retval);
112 EOF
113         }
114         print $outies if $outies;
115         print $post if $post;
116         if (/^END/) {
117             print "\t}\n\treturn sp;\n";
118         }
119         else {
120             redo;
121         }
122     }
123     elsif (/^END/) {
124         print "\t}\n\treturn sp;\n";
125     }
126     else {
127         print;
128     }
129 }