This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 5
[perl5.git] / ext / 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");
45d8adaa 67 push(@callnames, "&$name");
450a55e4
LW
68 }
69 else {
70 push(@outies, "\t str_set(st[$i], (char*) $name);\n");
45d8adaa 71 push(@callnames, "$name");
450a55e4 72 }
450a55e4
LW
73 }
74 else {
75 push(@callnames, $name);
76 }
77 if ($mode =~ /I/) {
78 print <<EOF;
79 $type $name =$x $cast str_$what(st[$i]);
80EOF
81 }
45d8adaa
LW
82 elsif ($type =~ /char/) {
83 print <<EOF;
84 char ${name}[133];
85EOF
86 }
450a55e4
LW
87 else {
88 print <<EOF;
89 $type $name;
90EOF
91 }
92 }
93 $callnames = join(', ', @callnames);
94 $outies = join("\n",@outies);
95 if ($rettype eq 'void') {
96 print <<EOF;
97$pre (void)$funcname($callnames);
98EOF
99 }
100 else {
101 print <<EOF;
102$pre retval = $funcname($callnames);
103EOF
104 }
105 if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) {
106 print <<EOF;
107 str_set(st[0], (char*) retval);
108EOF
109 }
110 elsif ($rettype =~ /^[A-Z]+\s*\*$/) {
111 print <<EOF;
d9d8d8de 112 str_nset(st[0], (char*) &retval, sizeof retval);
450a55e4
LW
113EOF
114 }
115 else {
116 print <<EOF;
117 str_numset(st[0], (double) retval);
118EOF
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}