Commit | Line | Data |
450a55e4 |
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"); |
45d8adaa |
67 | push(@callnames, "&$name"); |
450a55e4 |
68 | } |
69 | else { |
70 | push(@outies, "\t str_set(st[$i], (char*) $name);\n"); |
45d8adaa |
71 | push(@callnames, "$name"); |
450a55e4 |
72 | } |
450a55e4 |
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 | } |
45d8adaa |
82 | elsif ($type =~ /char/) { |
83 | print <<EOF; |
84 | char ${name}[133]; |
85 | EOF |
86 | } |
450a55e4 |
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; |
d9d8d8de |
112 | str_nset(st[0], (char*) &retval, sizeof retval); |
450a55e4 |
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 | } |