"SfR Fresh" - the SfR Freeware/Shareware Archive 
As a special service "SfR Fresh" has tried to format the requested source page into HTML format using source code syntax highlighting with prefixed line numbers.
Alternatively you can here view or download the uninterpreted source code file.
That can be also achieved for any archive member file by clicking within an archive contents listing on the first character of the file(path) respectively on the according byte size field.
1 #!/usr/local/bin/perl
2 #
3 # add_line_directive
4 #
5 # add c line directive
6 # to
7 # Small Eiffel generated C-code
8 #
9 #-----------------------------------------------------------------------------
10 # History
11 # Vers Date Coder Description
12 # 00-00 May 15,1997 Masato Mogaki first version
13 # 00-01 Aug 28,1997 Masato Mogaki for -0.85
14 #-----------------------------------------------------------------------------
15 #
16 # original published as part of SmallEiffel -0.81 under the GPL
17 # slightly adapted for use with WipeOut
18 #
19 $remove_rs = 1;
20 $remove_ci = 1;
21 $use_gc = 0;
22
23 @c = ();
24 @h = ();
25
26 for ($i=0; $i<=$#ARGV;$i++) { # collect options and source file names.
27 $s = $ARGV[$i];
28 if($s =~ /\.c$/) {
29 push(@c,$s);
30 } elsif($s =~ /\.h$/) {
31 push(@h,$s);
32 } elsif($s eq "-gc") {
33 $use_gc = 1;
34 } elsif($s eq "-ci") {
35 $remove_ci = 0;
36 } elsif($s eq "-rs") {
37 $remove_rs = 0;
38 }
39 }
40 #
41 # get class inheritance from mangle comment in *.h
42 # most deferred classes are not defined here.
43 # we have to find them from the other resource.
44 # Possible candidate is Xnnn routine.
45 #
46 foreach $s (@h) {
47 open(IN,$s);
48 $mangle = 0;
49 while(<IN>) {
50
51 if($mangle) {
52 if(/Mangling Table End/) {
53 last;
54 } elsif(/[AD]\s+\d+\s*T(\d+)\s*[RE] ([0-9_A-Z]+)(\[[0-9_A-Z,]+\])? ([0-9,]+)/) {
55
56 $c = $1;
57 $n = $2;
58 #$g = $3;
59 $d = $4;
60 $class_name[$c] = $n;
61 $decendants[$c] = $d;
62 @dec = split(',',$decendants[$c]);
63 shift @dec; #first one ins self.
64 foreach $d (@dec) {
65 $ancestors[$d] .= ",$c";
66 }
67 }
68 } elsif(/Mangling Table Start/) {
69 $mangle=1;
70 }
71 }
72 }
73
74 # Make @ancestors from @decendants.
75 #
76 for ($i=0;$i<=$#ancestors;$i++) {
77
78 $ans = $ancestors[$i];
79 $ans =~ s/^,//;
80 if($ans =~ /,/) {
81 @ans = split(',',$ans); # sort it by specific order.
82 @ans = sort {($decendants[$b] =~ /\b$a\b/)?-1:1;} @ans;
83 $ancestors[$i] = join(',',@ans);
84 } else {
85 $ancestors[$i] = $ans;
86 }
87 }
88 #find eiffel souce file name from line like p[123]="./test.e";
89 #and class name from g[123]="TEST";
90 #
91 foreach $s (@c) {
92 open(IN,$s);
93 $se_init = 0;
94 while(<IN>) {
95 if($se_init) {
96 if(/^p\[(\d+)\]="(.*)";/) {
97 $src_name[$1] = $2;
98 }elsif(/^p\[(\d+)\]=p\[(\d+)\];/) {
99 $src_name[$1] = $src_name[$2];
100 }elsif(/^g\[(\d+)\]="(.*)";/) {
101 $class_name[$1]=$2;
102 }elsif(/^g\[(\d+)\]=g\[(\d+)\];/) {
103 $class_name[$1]=$class_name[$2];
104 }
105 } elsif(/^void se_initialize/) {
106 $se_init = 1;
107 }
108 }
109 close(IN);
110 }
111
112 # Scan Eiffel sources and register
113 # the starting line number of each feature.
114 #
115
116 foreach $src_name(@src_name) {
117 if(!$checked{$src_name}) {
118 $checked{$src_name}=1;
119 &scan_e_src($src_name);
120 }
121 }
122 #
123 # convert header file.
124 # change prototype of selector routine X\d+\w+.
125 #
126 foreach $s (@h) {
127 $o = "B/$s";
128 $t = "C/$s";
129 if(system("cmp -s $s $o")) { # $s is changed
130 print STDERR "$s is changed\n";
131 rename($s,$o);
132 open(IN,$o);
133 open(OUT,">$t");
134 &convert_h;
135 } else {
136 unlink($s);
137 }
138 }
139 #
140 # convert c source.
141 # remove runtime trace routine like rs_XXX
142 # add line directive #line NN "source.e"
143 #
144 foreach $s (@c) {
145 $o = "B/$s";
146 $t = "C/$s";
147 if(system("cmp -s $s $o")) { # $s is changed
148 print STDERR "$s is changed\n";
149 rename($s,$o);
150 open(IN,$o);
151 open(OUT,">$t");
152 &convert_c;
153 } else {
154 unlink($s);
155 }
156 }
157
158 sub convert_h {
159 while(<IN>) {
160 if($remove_ci) {
161 s/(X\d+\w+).int l,int c,int f, /$1\(/;
162 if(/^T0\*ci/) {next;}
163 if(/^T0\*vc/) {next;}
164 }
165 print OUT $_;
166 }
167 close IN;
168 if($use_gc) {
169 print OUT "#include <gc.h>\n";
170 print OUT "#define malloc(_n) GC_malloc(_n)\n";
171 print OUT "#define calloc(_m,_n) GC_malloc((_m)*(_n))\n";
172 print OUT "#define realloc(_p,_n) GC_realloc(_p,_n)\n";
173 print OUT "#define free(_p) GC_free(_p)\n";
174 }
175 if($remove_ci) {
176 print OUT "#define ci(_id,_o,_l,_c,_f) (_o)\n";
177 print OUT "#define vc(_o,_l,_c,_f) ((T0*)(_o))\n";
178 print OUT "#define error1(_m,_l,_c,_f)\n";
179 print OUT "#define error2(_o,_l,_c,_f)\n";
180 }
181 close OUT;
182 }
183
184
185 sub convert_c {
186 $in_routine = 0;
187 $directive_printed=0;
188 $i_line = 0;
189 $o_line = 1;
190 while(<IN>) {
191 s/\/\*\w+\*\///g;
192 s/\)exit\(0\)/)abort()/; # to be caught by gdb
193 s/\bexit\(1\)/abort()/; # to be caught by gdb
194 if($remove_rs) {
195 s/rs-=8;//g;
196 s/([^ ])rs_pop_int\b/$1/g;
197 }
198 if($remove_ci) {
199 s/(X\d+\w+)\(\d+,\d+,\d+,/$1\(/g;
200 s/(X\d+\w+).int l,int c,int f, /$1\(/;
201 }
202 $i_line++;
203 if(!$in_routine) {
204 if($remove_ci &&/^void error1\(char\*m,int l,int c,int f\)\{/) {
205 # remove definitions of error1 and error2.
206 while(<IN>) {
207 if(/^void evobt/) {last;}
208 }
209 }
210 if($remove_rs) {
211 s/rs_pPOS\(tag_pos_[123456],(\d+),(\d+),(\d+)\)[,;]//;
212 }
213 if(/^(T0\*|T\d+|int|char|void|void\*) r(\d+)(\w+)\(.*\)\{$/) { # feature begin.
214 chop;
215 $cl = $2;
216 $fn = $3;
217 $head_line_directive = &source_line_directive($cl,$fn);
218 $directive_printed=0;
219 $in_routine++;
220 $head = $_;
221 @body = ();
222 %name_map=();
223 } else {
224 print OUT $_;
225 $o_line++;
226 if($directive_printed && (/return/ || /^\}$/)) {
227 $directive_printed=0;
228 print OUT "\#line $o_line \"$o\"\n";
229 $o_line++;
230 }
231 }
232 } else {
233 chop;
234 if(/^\};/) {
235 push(@body,'};');
236 $_ = $';
237 }
238 $l = "";
239 $e_pos = 0;
240 while(/rs_pPOS\(tag_pos_[123456],(\d+),(\d+),(\d+)\)[,;]/) {
241 $e_pos = $1;
242 $e_src = "\"$src_name[$3]\"";
243
244 $l .= $`;
245 if(!$remove_rs) { $l .= $0;}
246 $_ = $';
247 }
248 if($e_pos) {
249 push(@body,"#line $e_pos $e_src");
250 $directive_printed = 1;
251 $_ = $l . $_;
252 }
253 if(/^rs_link/) {
254 $rest = $';
255 if(!$remove_rs) {push(@body,$_);}
256 if(!$head_line_directive) {
257 $fn = "";
258 if($rest =~ /\(\"(\w+) of (\w+)\"/) {
259 $fn = $1;
260 $class = $2;
261 } elsif($rest =~ /\(\"(infix|prefix) (.*) of (\w+)\"/) {
262 $fn = "$1 \"2\"";
263 $class = $2;
264 }
265 if($fn) {
266 $head_line_directive = $feature_position{$class,$fn};
267 }
268 }
269 } elsif(/^rs_p[A-Z][A-Z][A-Z]\((\(void\*\*\))?&(a\d+),"(\w+)"\);/) {
270 $name_map{$2} = "_$3"; # _ is added for consistency with other local var.
271 if(!$remove_rs) {push(@body,$_);}
272 } elsif($remove_rs && /^rs_p[A-Z][A-Z][A-Z]/) {
273 #simply ignore it.
274 } elsif(/rs_unlink\(\);/) {
275 if($remove_rs) {
276 s/rs_unlink\(\);//;
277 }
278 if($_) {
279 push(@body,$_);
280 }
281 $in_routine = 0;
282 if($head_line_directive) {
283 $directive_printed++;
284 print OUT "$head_line_directive\n";
285 }
286 $head = &replace_name($head);
287 print OUT "$head\n";
288 $o_line++;
289 #_______ print body begin
290 @body = &merge_lines(@body);
291 $i_line=0;
292 $i_file="";
293 while(@body) {
294 $l = shift(@body);
295 if($l =~ /\#line (\d+) (\".*\")/) {
296 # do not print if synclonized
297 if($1 == $i_line && $i_file eq $2) {next;}
298 else {
299 $i_line = $1;
300 $i_file = $2;
301 }
302 } else {
303 $l = &replace_name($l);
304 $i_line++;
305 }
306 print OUT "$l\n";
307 $o_line++;
308 }
309 #_______ print body end
310 } elsif($_) {
311 push(@body,$_);
312 }
313 }
314 }
315 close(OUT);
316 close(IN);
317 }
318 # replace name of local variables.
319 sub replace_name {
320 my ($line) = @_;
321 my($n,$v);
322
323 if(!/^\#/) {
324 foreach $v (keys %name_map) {
325 $n = $name_map{$v};
326 $line =~ s/\b$v\b/$n/g;
327 }
328 }
329 return $line;
330 }
331
332 # merge lines to synclonize with line directive.
333 sub merge_lines {
334 my @lines = @_;
335 my (@merged,@wl,$l,$ll,$last_lno,$lno);
336 @merged = ();
337 @wl = ();
338 $last_lno = 0;
339 while(@lines) {
340 $l = shift(@lines);
341 if($l =~ /^\{T\d+\*n;$/) {
342 $ll = '';
343 while($l && $l !~ /\}$/) {
344 $ll .= $l;
345 $l = shift(@lines);
346 }
347 $l = $ll . $l;
348 # line like if(NULL!=(C->_abc))switch(((T0*)C->_abc)->id) {
349 } elsif($l =~ /^if.NULL!=.C->_\w+..switch...T0..C->_\w+.->id. \{$/) {
350 $ll = pop(@wl);
351 do {
352 $ll .= $l;
353 $l = shift(@lines);
354 } until(!$l || ($l =~ /^\};$/));
355 $ll .= $l;
356 push(@wl,$ll);
357 $l = shift(@lines);
358 } elsif($l =~ /^if.NULL!=.\w+..switch...T0\*.\w+.->id. \{$/) {
359 $ll = pop(@wl);
360 do {
361 $ll .= $l;
362 $l = shift(@lines);
363 } until(!$l || ($l =~ /^\};$/));
364 $ll .= $l;
365 push(@wl,$ll);
366 $l = shift(@lines);
367 } elsif($l =~ /^ ?else/) {
368 $ll = pop(@wl);
369 $l = $ll.$l;
370 }
371 push(@wl,$l);
372 if($l =~ /\#line (\d+)/) {
373 $lno = $1;
374 if(!$last_lno) {
375 @merged = @wl;
376 $last_lno = $lno;
377 } else {
378 @wl = &merge_into($lno-$last_lno,@wl);
379 @merged = (@merged,@wl);
380 }
381 @wl = ();
382 }
383 }
384 return (@merged,@wl);
385 }
386
387 sub merge_into {
388 my($lno,@lines) = @_;
389 my($lm,$ln);
390 if($#lines <= $lno) {
391 return @lines;
392 } else {
393 while ($#lines <= $lno) {
394 $ln = pop(@lines);
395 $lm = pop(@lines);
396 push (@lines, $lm.$ln);
397 }
398 return @lines;
399 }
400 }
401 #
402 # register feature's definition line.
403 sub scan_e_src {
404 my($src_name)=@_;
405 open(IN,$src_name);
406 my($class,$l);
407 $l=0;
408 while(<IN>) {
409 $l++;
410 if(/^[ \ta-z]*class\s+([0-9_A-Z]+)/) {
411 $class=$1;
412 }
413 if(/^\s*frozen\s+(\w+).*\sis\s*$/) {
414 $feature_position{$class,$1}="\#line $l \"$src_name\"";
415 } elsif(/^\s*((infix|prefix) \".*\").* \sis\s*$/) {
416 $feature_position{$class,$1}="\#line $l \"$src_name\"";
417 } elsif(/^\s*(\w+).*\sis\s*$/) {
418 $feature_position{$class,$1}="\#line $l \"$src_name\"";
419 }
420 }
421 }
422 #
423 # recall feature's definition line.
424 #
425 sub source_line_directive {
426 my($cl,$fn)= @_;
427 my($c,$class,$fp);
428 $class = $class_name[$cl];
429 $fp = $feature_position{$class,$fn};
430 if($fp) {
431 return "$fp";
432 } else {
433 foreach $c (split(',', $ancestors[$cl])) {
434 $class = $class_name[$c];
435 $fp = $feature_position{$class,$fn};
436 if($fp) {
437 return "$fp";
438 }
439 }
440 }
441 return "";
442 }
443 #-------- add_line_directive END
444