1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
#!/usr/bin/perl
while (<>) {
if (s/^CASE\s+//) {
@fields = split;
$funcname = pop(@fields);
$rettype = "@fields";
@modes = ();
@types = ();
@names = ();
@outies = ();
@callnames = ();
$pre = "\n";
$post = '';
while (<>) {
last unless /^[IO]+\s/;
@fields = split(' ');
push(@modes, shift(@fields));
push(@names, pop(@fields));
push(@types, "@fields");
}
while (s/^<\s//) {
$pre .= "\t $_";
$_ = <>;
}
while (s/^>\s//) {
$post .= "\t $_";
$_ = <>;
}
$items = @names;
$namelist = '$' . join(', $', @names);
$namelist = '' if $namelist eq '$';
print <<EOF;
case US_$funcname:
if (items != $items)
fatal("Usage: &$funcname($namelist)");
else {
EOF
if ($rettype eq 'void') {
print <<EOF;
int retval = 1;
EOF
}
else {
print <<EOF;
$rettype retval;
EOF
}
foreach $i (1..@names) {
$mode = $modes[$i-1];
$type = $types[$i-1];
$name = $names[$i-1];
if ($type =~ /^[A-Z]+\*$/) {
$cast = "*($type*)";
}
else {
$cast = "($type)";
}
$what = ($type =~ /^(struct\s+\w+|char|[A-Z]+)\s*\*$/ ? "get" : "gnum");
$type .= "\t" if length($type) < 4;
$cast .= "\t" if length($cast) < 8;
$x = "\t" x (length($name) < 6);
if ($mode =~ /O/) {
if ($what eq 'gnum') {
push(@outies, "\t str_numset(st[$i], (double) $name);\n");
}
else {
push(@outies, "\t str_set(st[$i], (char*) $name);\n");
}
push(@callnames, "&$name");
}
else {
push(@callnames, $name);
}
if ($mode =~ /I/) {
print <<EOF;
$type $name =$x $cast str_$what(st[$i]);
EOF
}
else {
print <<EOF;
$type $name;
EOF
}
}
$callnames = join(', ', @callnames);
$outies = join("\n",@outies);
if ($rettype eq 'void') {
print <<EOF;
$pre (void)$funcname($callnames);
EOF
}
else {
print <<EOF;
$pre retval = $funcname($callnames);
EOF
}
if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) {
print <<EOF;
str_set(st[0], (char*) retval);
EOF
}
elsif ($rettype =~ /^[A-Z]+\s*\*$/) {
print <<EOF;
str_set(st[0], (char*) &retval, sizeof retval);
EOF
}
else {
print <<EOF;
str_numset(st[0], (double) retval);
EOF
}
print $outies if $outies;
print $post if $post;
if (/^END/) {
print "\t}\n\treturn sp;\n";
}
else {
redo;
}
}
elsif (/^END/) {
print "\t}\n\treturn sp;\n";
}
else {
print;
}
}
|
