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