This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 4.0 patch 14: patch #11, continued
[perl5.git] / usub / mus
CommitLineData
450a55e4
LW
1#!/usr/bin/perl
2
3while (<>) {
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 {
39EOF
40 if ($rettype eq 'void') {
41 print <<EOF;
42 int retval = 1;
43EOF
44 }
45 else {
46 print <<EOF;
47 $rettype retval;
48EOF
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]);
79EOF
80 }
81 else {
82 print <<EOF;
83 $type $name;
84EOF
85 }
86 }
87 $callnames = join(', ', @callnames);
88 $outies = join("\n",@outies);
89 if ($rettype eq 'void') {
90 print <<EOF;
91$pre (void)$funcname($callnames);
92EOF
93 }
94 else {
95 print <<EOF;
96$pre retval = $funcname($callnames);
97EOF
98 }
99 if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) {
100 print <<EOF;
101 str_set(st[0], (char*) retval);
102EOF
103 }
104 elsif ($rettype =~ /^[A-Z]+\s*\*$/) {
105 print <<EOF;
d9d8d8de 106 str_nset(st[0], (char*) &retval, sizeof retval);
450a55e4
LW
107EOF
108 }
109 else {
110 print <<EOF;
111 str_numset(st[0], (double) retval);
112EOF
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}