It's nicer with []
[xonotic/xonotic.git] / misc / tools / progs-analyzer.pl
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5 use Digest::SHA;
6 use Carp;
7
8 sub id()
9 {
10         return sub { $_[0]; };
11 }
12
13 sub signed($)
14 {
15         my ($bits) = @_;
16         return sub { $_[0] >= (2**($bits-1)) ? $_[0]-(2**$bits) : $_[0]; };
17 }
18
19 use constant OPCODE_E => [qw[
20         DONE
21         MUL_F MUL_V MUL_FV MUL_VF
22         DIV_F
23         ADD_F ADD_V
24         SUB_F SUB_V
25         EQ_F EQ_V EQ_S EQ_E EQ_FNC
26         NE_F NE_V NE_S NE_E NE_FNC
27         LE GE LT GT
28         LOAD_F LOAD_V LOAD_S LOAD_ENT LOAD_FLD LOAD_FNC
29         ADDRESS
30         STORE_F STORE_V STORE_S STORE_ENT STORE_FLD STORE_FNC
31         STOREP_F STOREP_V STOREP_S STOREP_ENT STOREP_FLD STOREP_FNC
32         RETURN
33         NOT_F NOT_V NOT_S NOT_ENT NOT_FNC
34         IF IFNOT
35         CALL0 CALL1 CALL2 CALL3 CALL4 CALL5 CALL6 CALL7 CALL8
36         STATE
37         GOTO
38         AND OR
39         BITAND BITOR
40 ]];
41 use constant ETYPE_E => [qw[
42         void
43         string
44         float
45         vector
46         entity
47         field
48         function
49         pointer
50 ]];
51 use constant DEF_SAVEGLOBAL => 32768;
52 sub typesize($)
53 {
54         my ($type) = @_;
55         return 3 if $type eq 'vector';
56         return 1;
57 }
58
59 sub checkop($)
60 {
61         my ($op) = @_;
62         if($op =~ /^IF.*_V$/)
63         {
64                 return { a => 'inglobalvec', b => 'ipoffset', isjump => 'b', isconditional => 1 };
65         }
66         if($op =~ /^IF/)
67         {
68                 return { a => 'inglobal', b => 'ipoffset', isjump => 'b', isconditional => 1 };
69         }
70         if($op eq 'GOTO')
71         {
72                 return { a => 'ipoffset', isjump => 'a', isconditional => 0 };
73         }
74         if($op =~ /^ADD_V$|^SUB_V$/)
75         {
76                 return { a => 'inglobalvec', b => 'inglobalvec', c => 'outglobalvec' };
77         }
78         if($op =~ /^MUL_V$|^EQ_V$|^NE_V$/)
79         {
80                 return { a => 'inglobalvec', b => 'inglobalvec', c => 'outglobal' };
81         }
82         if($op eq 'MUL_FV')
83         {
84                 return { a => 'inglobal', b => 'inglobalvec', c => 'outglobalvec' };
85         }
86         if($op eq 'MUL_VF')
87         {
88                 return { a => 'inglobalvec', b => 'inglobal', c => 'outglobalvec' };
89         }
90         if($op eq 'LOAD_V')
91         {
92                 return { a => 'inglobal', b => 'inglobal', c => 'outglobalvec' };
93         }
94         if($op =~ /^NOT_V/)
95         {
96                 return { a => 'inglobalvec', c => 'outglobal' };
97         }
98         if($op =~ /^NOT_/)
99         {
100                 return { a => 'inglobal', c => 'outglobal' };
101         }
102         if($op eq 'STOREP_V')
103         {
104                 return { a => 'inglobalvec', b => 'inglobal' };
105         }
106         if($op eq 'STORE_V')
107         {
108                 return { a => 'inglobalvec', b => 'outglobalvec' };
109         }
110         if($op =~ /^STOREP_/)
111         {
112                 return { a => 'inglobal', b => 'inglobal' };
113         }
114         if($op =~ /^STORE_/)
115         {
116                 return { a => 'inglobal', b => 'outglobal' };
117         }
118         if($op =~ /^CALL/)
119         {
120                 return { a => 'inglobalfunc', iscall => 1 };
121         }
122         if($op =~ /^DONE$|^RETURN$/)
123         {
124                 return { a => 'inglobalvec', isreturn => 1 };
125         }
126         if($op eq 'STATE')
127         {
128                 return { a => 'inglobal', b => 'inglobalfunc' };
129         }
130         if($op =~ /^INVALID#/)
131         {
132                 return { isinvalid => 1 };
133         }
134         return { a => 'inglobal', b => 'inglobal', c => 'outglobal' };
135 }
136
137 use constant TYPES => {
138         int => ['V', 4, signed 32],
139         ushort => ['v', 2, id],
140         short => ['v', 2, signed 16],
141         opcode => ['v', 2, sub { OPCODE_E->[$_[0]] or do { warn "Invalid opcode: $_[0]"; "INVALID#$_[0]"; }; }],
142         float => ['f', 4, id],
143         uchar8 => ['a8', 8, sub { [unpack 'C8', $_[0]] }],
144         global => ['i', 4, sub { { int => $_[0], float => unpack "f", pack "L", $_[0] }; }],
145         deftype => ['v', 2, sub { { type => ETYPE_E->[$_[0] & ~DEF_SAVEGLOBAL], save => !!($_[0] & DEF_SAVEGLOBAL) }; }],
146 };
147
148 use constant DPROGRAMS_T => [
149         [int => 'version'],
150         [int => 'crc'],
151         [int => 'ofs_statements'],
152         [int => 'numstatements'],
153         [int => 'ofs_globaldefs'],
154         [int => 'numglobaldefs'],
155         [int => 'ofs_fielddefs'],
156         [int => 'numfielddefs'],
157         [int => 'ofs_functions'],
158         [int => 'numfunctions'],
159         [int => 'ofs_strings'],
160         [int => 'numstrings'],
161         [int => 'ofs_globals'],
162         [int => 'numglobals'],
163         [int => 'entityfields']
164 ];
165
166 use constant DSTATEMENT_T => [
167         [opcode => 'op'],
168         [short => 'a'],
169         [short => 'b'],
170         [short => 'c']
171 ];
172
173 use constant DDEF_T => [
174         [deftype => 'type'],
175         [ushort => 'ofs'],
176         [int => 's_name']
177 ];
178
179 use constant DGLOBAL_T => [
180         [global => 'v'],
181 ];
182
183 use constant DFUNCTION_T => [
184         [int => 'first_statement'],
185         [int => 'parm_start'],
186         [int => 'locals'],
187         [int => 'profile'],
188         [int => 's_name'],
189         [int => 's_file'],
190         [int => 'numparms'],
191         [uchar8 => 'parm_size'],
192 ];
193
194 use constant LNOHEADER_T => [
195         [int => 'lnotype'],
196         [int => 'version'],
197         [int => 'numglobaldefs'],
198         [int => 'numglobals'],
199         [int => 'numfielddefs'],
200         [int => 'numstatements'],
201 ];
202
203 use constant LNO_T => [
204         [int => 'v'],
205 ];
206
207 sub get_section($$$)
208 {
209         my ($fh, $start, $len) = @_;
210         seek $fh, $start, 0
211                 or die "seek: $!";
212         $len == read $fh, my $buf, $len
213                 or die "short read from $start length $len (malformed progs header)";
214         return $buf;
215 }
216
217 sub parse_section($$$$$)
218 {
219         my ($fh, $struct, $start, $len, $cnt) = @_;
220
221         my $itemlen = 0;
222         $itemlen += TYPES->{$_->[0]}->[1]
223                 for @$struct;
224         my $packspec = join '', map { TYPES->{$_->[0]}->[0]; } @$struct;
225         my @packnames = map { $_->[1]; } @$struct;
226
227         $len = $cnt * $itemlen
228                 if not defined $len and defined $cnt;
229         $cnt = int($len / $itemlen)
230                 if not defined $cnt and defined $len;
231         die "Invalid length specification"
232                 unless defined $len and defined $cnt and $len == $cnt * $itemlen;
233         die "Invalid length specification in scalar context"
234                 unless wantarray or $cnt == 1;
235
236         seek $fh, $start, 0
237                 or die "seek: $!";
238         my @out = map
239         {
240                 $itemlen == read $fh, my $buf, $itemlen
241                         or die "short read from $start length $cnt * $itemlen $(malformed progs header)";
242                 my %h = ();
243                 @h{@packnames} = unpack $packspec, $buf;
244                 $h{$_->[1]} = TYPES->{$_->[0]}->[2]->($h{$_->[1]})
245                         for @$struct;
246                 \%h;
247         }
248         0..($cnt-1);
249         return @out
250                 if wantarray;
251         return $out[0];
252 }
253
254 sub nfa_default_state_checker()
255 {
256         my %seen;
257         return sub
258         {
259                 my ($ip, $state) = @_;
260                 return $seen{"$ip $state"}++;
261         };
262 }
263
264 sub run_nfa($$$$$$)
265 {
266         my ($progs, $ip, $state, $copy_handler, $state_checker, $instruction_handler) = @_;
267
268         my $statements = $progs->{statements};
269
270         my $nfa;
271         $nfa = sub
272         {
273                 no warnings 'recursion';
274
275                 my ($ip, $state) = @_;
276                 my $ret = 0;
277
278                 for(;;)
279                 {
280                         return $ret
281                                 if $state_checker->($ip, $state);
282
283                         my $s = $statements->[$ip];
284                         my $c = checkop $s->{op};
285
286                         if(($ret = $instruction_handler->($ip, $state, $s, $c)))
287                         {
288                                 # abort execution
289                                 last;
290                         }
291
292                         if($c->{isreturn})
293                         {
294                                 last;
295                         }
296                         elsif($c->{iscall})
297                         {
298                                 my $func = $s->{a};
299                                 last
300                                         if $progs->{builtins}{error}{$func};
301                                 $ip += 1;
302                         }
303                         elsif($c->{isjump})
304                         {
305                                 if($c->{isconditional})
306                                 {
307                                         if(rand 2)
308                                         {
309                                                 if(($ret = $nfa->($ip+$s->{$c->{isjump}}, $copy_handler->($state))) < 0)
310                                                 {
311                                                         last;
312                                                 }
313                                                 $ip += 1;
314                                         }
315                                         else
316                                         {
317                                                 $nfa->($ip+1, $copy_handler->($state));
318                                                 $ip += $s->{$c->{isjump}};
319                                         }
320                                 }
321                                 else
322                                 {
323                                         $ip += $s->{$c->{isjump}};
324                                 }
325                         }
326                         else
327                         {
328                                 $ip += 1;
329                         }
330                 }
331
332                 return $ret;
333         };
334
335         $nfa->($ip, $copy_handler->($state));
336 }
337
338 sub get_constant($$$)
339 {
340         my ($progs, $g, $type) = @_;
341
342         if (!defined $type) {
343                 $type = 'float';
344                 $type = 'int'
345                         if $g->{int} > 0 && $g->{int} < 8388608;
346                 $type = 'string'
347                         if $g->{int} > 0 && $g->{int} < length $progs->{strings};
348         }
349
350         return str($progs->{getstring}->($g->{int}))
351                 if $type eq 'string';
352         return $g->{float}
353                 if $type eq 'float';
354         return "'$g->{float} _ _'"
355                 if $type eq 'vector';
356         return "entity $g->{int}"
357                 if $type eq 'entity';
358         return ".$progs->{entityfieldnames}[$g->{int}][0]"
359                 if $type eq 'field' and defined $progs->{entityfieldnames}[$g->{int}][0];
360         return "$g->{int}i"
361                 if $type eq 'int';
362
363         return "$type($g->{int})";
364 }
365
366 use constant PRE_MARK_STATEMENT => "";
367 use constant POST_MARK_STATEMENT => "";
368 use constant PRE_MARK_OPERAND => "*** ";
369 use constant POST_MARK_OPERAND => " ***";
370
371 use constant INSTRUCTION_FORMAT => "%8s %3s | %-12s ";
372 use constant OPERAND_FORMAT => "%s";
373 use constant OPERAND_SEPARATOR => ", ";
374 use constant INSTRUCTION_SEPARATOR => "\n";
375
376 sub str($)
377 {
378         my ($str) = @_;
379         $str =~ s/[\000-\037\\\"\177-\377]/sprintf "\\%03o", ord $&/ge;
380         return "\"$str\"";
381 }
382
383 sub debugpos($$$) {
384         my ($progs, $func, $ip) = @_;
385         my $s = $func->{debugname};
386         if ($progs->{cno}) {
387                 my $column = $progs->{cno}[$ip]{v};
388                 $s =~ s/:/:$column:/;
389         }
390         if ($progs->{lno}) {
391                 my $line = $progs->{lno}[$ip]{v};
392                 $s =~ s/:/:$line:/;
393         }
394         return $s;
395 }
396
397 sub disassemble_function($$;$)
398 {
399         my ($progs, $func, $highlight) = @_;
400
401         print "$func->{debugname}:\n";
402
403         if($func->{first_statement} < 0) # builtin
404         {
405                 printf INSTRUCTION_FORMAT, '', '', '.BUILTIN';
406                 printf OPERAND_FORMAT, -$func->{first_statement};
407                 print INSTRUCTION_SEPARATOR;
408                 return;
409         }
410
411         my $initializer = sub
412         {
413                 my ($ofs) = @_;
414                 # TODO: Can we know its type?
415                 my $g = get_constant($progs, $progs->{globals}[$ofs]{v}, undef);
416                 print " = $g"
417                         if defined $g;
418         };
419
420         printf INSTRUCTION_FORMAT, '', '', '.PARM_START';
421         printf OPERAND_FORMAT, "$func->{parm_start}";
422         print INSTRUCTION_SEPARATOR;
423
424         printf INSTRUCTION_FORMAT, '', '', '.LOCALS';
425         printf OPERAND_FORMAT, "$func->{locals}";
426         print INSTRUCTION_SEPARATOR;
427
428         my %override_locals = ();
429         my $p = $func->{parm_start};
430         for(0..($func->{numparms}-1))
431         {
432                 $override_locals{$p} //= "argv_$_";
433                 for my $comp(0..($func->{parm_size}[$_]-1))
434                 {
435                         $override_locals{$p} //= "argv_$_\[$comp]";
436                         ++$p;
437                 }
438                 printf INSTRUCTION_FORMAT, '', '', '.ARG';
439                 printf OPERAND_FORMAT, "argv_$_";
440                 print OPERAND_SEPARATOR;
441                 printf OPERAND_FORMAT, $func->{parm_size}[$_];
442                 print INSTRUCTION_SEPARATOR;
443         }
444         for($func->{parm_start}..($func->{parm_start} + $func->{locals} - 1))
445         {
446                 next
447                         if exists $override_locals{$_};
448                 $override_locals{$_} = "local_$_";
449
450                 printf INSTRUCTION_FORMAT, '', '', '.LOCAL';
451                 printf OPERAND_FORMAT, "local_$_";
452                 $initializer->($_);
453                 print INSTRUCTION_SEPARATOR;
454         }
455
456         my $getname = sub
457         {
458                 my ($ofs) = @_;
459                 return $override_locals{$ofs}
460                         if exists $override_locals{$ofs};
461                 my $def = $progs->{globaldef_byoffset}->($ofs);
462                 return $def->{debugname};
463         };
464
465         my $operand = sub
466         {
467                 my ($ip, $type, $operand) = @_;
468                 if($type eq 'inglobal')
469                 {
470                         my $name = $getname->($operand);
471                         printf OPERAND_FORMAT, "$name";
472                 }
473                 elsif($type eq 'outglobal')
474                 {
475                         my $name = $getname->($operand);
476                         printf OPERAND_FORMAT, "&$name";
477                 }
478                 elsif($type eq 'inglobalvec')
479                 {
480                         my $name = $getname->($operand);
481                         printf OPERAND_FORMAT, "$name\[\]";
482                 }
483                 elsif($type eq 'outglobalvec')
484                 {
485                         my $name = $getname->($operand);
486                         printf OPERAND_FORMAT, "&$name\[\]";
487                 }
488                 elsif($type eq 'inglobalfunc')
489                 {
490                         my $name = $getname->($operand);
491                         printf OPERAND_FORMAT, "$name()";
492                 }
493                 elsif($type eq 'ipoffset')
494                 {
495                         printf OPERAND_FORMAT, "@{[$ip + $operand]}" . sprintf ' ($%+d)', $operand;
496                 }
497                 else
498                 {
499                         die "unknown type: $type";
500                 }
501         };
502
503         my $statements = $func->{statements};
504         my $come_from = $func->{come_from};
505
506         my $ipprev = undef;
507         for my $ip(sort { $a <=> $b } keys %$statements)
508         {
509                 if($ip == $func->{first_statement})
510                 {
511                         printf INSTRUCTION_FORMAT, $ip, '', '.ENTRY';
512                         print INSTRUCTION_SEPARATOR;
513                 }
514                 if(defined $ipprev && $ip != $ipprev + 1)
515                 {
516                         printf INSTRUCTION_FORMAT, $ip, '', '.SKIP';
517                         printf OPERAND_FORMAT, $ip - $ipprev - 1;
518                         print INSTRUCTION_SEPARATOR;
519                 }
520                 if(my $cf = $come_from->{$ip})
521                 {
522                         printf INSTRUCTION_FORMAT, $ip, '', '.XREF';
523                         my $cnt = 0;
524                         for(sort { $a <=> $b } keys %$cf)
525                         {
526                                 print OPERAND_SEPARATOR
527                                         if $cnt++;
528                                 printf OPERAND_FORMAT, ($cf->{$_} ? 'c' : 'j') . $_ . sprintf ' ($%+d)', $_ - $ip;
529                         }
530                         print INSTRUCTION_SEPARATOR;
531                 }
532
533                 my $op = $progs->{statements}[$ip]{op};
534                 my $ipt = $progs->{statements}[$ip];
535                 my $opprop = checkop $op;
536
537                 if($highlight and $highlight->{$ip})
538                 {
539                         for(values %{$highlight->{$ip}})
540                         {
541                                 for(sort keys %$_)
542                                 {
543                                         print PRE_MARK_STATEMENT;
544                                         printf INSTRUCTION_FORMAT, '', '<!>', '.WARN';
545                                         my $pos = debugpos $progs, $func, $ip;
546                                         printf OPERAND_FORMAT, "$_ (in $pos)";
547                                         print INSTRUCTION_SEPARATOR;
548                                 }
549                         }
550                 }
551
552                 print PRE_MARK_STATEMENT
553                         if $highlight and $highlight->{$ip};
554
555                 my $showip = $opprop->{isjump};
556                 printf INSTRUCTION_FORMAT, $showip ? $ip : '', $highlight->{$ip} ? '<!>' : '', $op;
557
558                 my $cnt = 0;
559                 for my $o(qw(a b c))
560                 {
561                         next
562                                 if not defined $opprop->{$o};
563                         print OPERAND_SEPARATOR
564                                 if $cnt++;
565                         print PRE_MARK_OPERAND
566                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
567                         $operand->($ip, $opprop->{$o}, $ipt->{$o});
568                         print POST_MARK_OPERAND
569                                 if $highlight and $highlight->{$ip} and $highlight->{$ip}{$o};
570                 }
571
572                 print POST_MARK_STATEMENT
573                         if $highlight and $highlight->{$ip};
574
575                 print INSTRUCTION_SEPARATOR;
576         }
577 }
578
579 sub find_uninitialized_locals($$)
580 {
581         my ($progs, $func) = @_;
582
583         return
584                 if $func->{first_statement} < 0; # builtin
585
586         print STDERR "Checking $func->{debugname}...\n";
587
588         my $p = $func->{parm_start};
589         for(0..($func->{numparms}-1))
590         {
591                 $p += $func->{parm_size}[$_];
592         }
593
594         use constant WATCHME_R => 1;
595         use constant WATCHME_W => 2;
596         use constant WATCHME_X => 4;
597         use constant WATCHME_T => 8;
598         my %watchme = map { $_ => WATCHME_X } ($func->{parm_start} .. ($func->{parm_start} + $func->{locals} - 1));
599
600         for(keys %{$progs->{temps}})
601         {
602                 next
603                         if exists $watchme{$_};
604                 if($progs->{temps}{$_})
605                 {
606                         # shared temp
607                         $watchme{$_} = WATCHME_T | WATCHME_X
608                 }
609                 else
610                 {
611                         # unique temp
612                         $watchme{$_} = WATCHME_X
613                 }
614         }
615
616         $watchme{$_} |= WATCHME_R
617                 for keys %{$func->{globals_read}};
618         $watchme{$_} |= WATCHME_W
619                 for keys %{$func->{globals_written}};
620
621         my %write_places = ();
622         for my $ofs(keys %{$func->{globals_written}})
623         {
624                 next
625                         unless exists $watchme{$ofs} and $watchme{$ofs} & WATCHME_X;
626                 for my $ip(keys %{$func->{globals_written}{$ofs}})
627                 {
628                         for my $op(keys %{$func->{globals_written}{$ofs}{$ip}})
629                         {
630                                 push @{$write_places{$ip}{$op}}, $ofs;
631                         }
632                 }
633         }
634
635         for(keys %watchme)
636         {
637                 delete $watchme{$_}
638                         if ($watchme{$_} & (WATCHME_R | WATCHME_W | WATCHME_X)) != (WATCHME_R | WATCHME_W | WATCHME_X);
639         }
640
641         return
642                 if not keys %watchme;
643
644         for(keys %watchme)
645         {
646                 $watchme{$_} = {
647                         flags => $watchme{$_},
648                         valid => [0, undef, undef]
649                 };
650         }
651
652         # mark parameters as initialized
653         for($func->{parm_start} .. ($p-1))
654         {
655                 $watchme{$_}{valid} = [1, undef, undef]
656                         if defined $watchme{$_};
657         }
658
659         my %warned = ();
660         my %ip_seen = ();
661         run_nfa $progs, $func->{first_statement}, \%watchme,
662                 sub {
663                         my ($h) = @_;
664                         return { map { $_ => { %{$h->{$_}} } } keys %$h };
665                 },
666                 sub {
667                         my ($ip, $state) = @_;
668
669                         my $s = $ip_seen{$ip};
670                         if($s)
671                         {
672                                 # if $state is stronger or equal to $s, return 1
673
674                                 for(keys %$state)
675                                 {
676                                         if($state->{$_}{valid}[0] < $s->{$_})
677                                         {
678                                                 # The current state is LESS valid than the previously run one. We NEED to run this.
679                                                 # The saved state can safely become the intersection [citation needed].
680                                                 for(keys %$state)
681                                                 {
682                                                         $s->{$_} = $state->{$_}{valid}[0]
683                                                                 if $state->{$_}{valid}[0] < $s->{$_};
684                                                 }
685                                                 return 0;
686                                         }
687                                 }
688                                 # if we get here, $state is stronger or equal. No need to try it.
689                                 return 1;
690                         }
691                         else
692                         {
693                                 # Never seen this IP yet.
694                                 $ip_seen{$ip} = { map { ($_ => $state->{$_}{valid}[0]); } keys %$state };
695                                 return 0;
696                         }
697                 },
698                 sub {
699                         my ($ip, $state, $s, $c) = @_;
700                         my $op = $s->{op};
701
702                         # QCVM BUG: RETURN always takes vector, there is no float equivalent
703                         my $return_hack = $c->{isreturn} // 0;
704
705                         if($op eq 'STORE_V')
706                         {
707                                 # COMPILER BUG of QCC: params are always copied using STORE_V
708                                 if($s->{b} >= 4 && $s->{b} < 28) # parameter range
709                                 {
710                                         $return_hack = 1;
711                                 }
712                         }
713
714                         if($c->{isinvalid})
715                         {
716                                 ++$warned{$ip}{''}{"Invalid opcode"};
717                         }
718                         for(qw(a b c))
719                         {
720                                 my $type = $c->{$_};
721                                 next
722                                         unless defined $type;
723
724                                 my $ofs = $s->{$_};
725
726                                 my $read = sub
727                                 {
728                                         my ($ofs) = @_;
729                                         ++$return_hack
730                                                 if $return_hack;
731                                         return
732                                                 if not exists $state->{$ofs};
733                                         my $valid = $state->{$ofs}{valid};
734                                         if($valid->[0] == 0)
735                                         {
736                                                 # COMPILER BUG of FTEQCC: AND and OR may take uninitialized as second argument (logicops)
737                                                 if($return_hack <= 2 and ($op ne 'OR' && $op ne 'AND' || $_ ne 'b'))
738                                                 {
739                                                         ++$warned{$ip}{$_}{"Use of uninitialized value"};
740                                                 }
741                                         }
742                                         elsif($valid->[0] < 0)
743                                         {
744                                                 # COMPILER BUG of FTEQCC: AND and OR may take uninitialized as second argument (logicops)
745                                                 if($return_hack <= 2 and ($op ne 'OR' && $op ne 'AND' || $_ ne 'b'))
746                                                 {
747                                                         ++$warned{$ip}{$_}{"Use of temporary across CALL"};
748                                                 }
749                                         }
750                                         else
751                                         {
752                                                 # it's VALID
753                                                 if(defined $valid->[1])
754                                                 {
755                                                         delete $write_places{$valid->[1]}{$valid->[2]};
756                                                 }
757                                         }
758                                 };
759                                 my $write = sub
760                                 {
761                                         my ($ofs) = @_;
762                                         $state->{$ofs}{valid} = [1, $ip, $_]
763                                                 if exists $state->{$ofs};
764                                 };
765
766                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
767                                 {
768                                         $read->($ofs);
769                                 }
770                                 elsif($type eq 'inglobalvec')
771                                 {
772                                         $read->($ofs);
773                                         $read->($ofs+1);
774                                         $read->($ofs+2);
775                                 }
776                                 elsif($type eq 'outglobal')
777                                 {
778                                         $write->($ofs);
779                                 }
780                                 elsif($type eq 'outglobalvec')
781                                 {
782                                         $write->($ofs);
783                                         $write->($ofs+1);
784                                         $write->($ofs+2);
785                                 }
786                                 elsif($type eq 'ipoffset')
787                                 {
788                                         ++$warned{$ip}{$_}{"Endless loop"}
789                                                 if $ofs == 0;
790                                         ++$warned{$ip}{$_}{"No-operation jump"}
791                                                 if $ofs == 1;
792                                 }
793                         }
794                         if($c->{iscall})
795                         {
796                                 # builtin calls may clobber stuff
797                                 my $func = $s->{a};
798                                 my $funcid = $progs->{globals}[$func]{v}{int};
799                                 my $funcobj = $progs->{functions}[$funcid];
800                                 if(!$funcobj || $funcobj->{first_statement} >= 0)
801                                 {
802                                         # invalidate temps
803                                         for(values %$state)
804                                         {
805                                                 if($_->{flags} & WATCHME_T)
806                                                 {
807                                                         $_->{valid} = [-1, undef, undef];
808                                                 }
809                                         }
810                                 }
811                         }
812
813                         return 0;
814                 };
815
816         for my $ip(keys %write_places)
817         {
818                 for my $operand(keys %{$write_places{$ip}})
819                 {
820                         # TODO verify it
821                         my %left = map { $_ => 1 } @{$write_places{$ip}{$operand}};
822                         my $isread = 0;
823
824                         my %writeplace_seen = ();
825                         run_nfa $progs, $ip+1, \%left,
826                                 sub
827                                 {
828                                         return { %{$_[0]} };
829                                 },
830                                 sub
831                                 {
832                                         my ($ip, $state) = @_;
833                                         return $writeplace_seen{"$ip " . join " ", sort keys %$state}++;
834                                 },
835                                 sub
836                                 {
837                                         my ($ip, $state, $s, $c) = @_;
838                                         for(qw(a b c))
839                                         {
840                                                 my $type = $c->{$_};
841                                                 next
842                                                         unless defined $type;
843
844                                                 my $ofs = $s->{$_};
845                                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
846                                                 {
847                                                         if($state->{$ofs})
848                                                         {
849                                                                 $isread = 1;
850                                                                 return -1; # exit TOTALLY
851                                                         }
852                                                 }
853                                                 elsif($type eq 'inglobalvec')
854                                                 {
855                                                         if($state->{$ofs} || $state->{$ofs+1} || $state->{$ofs+2})
856                                                         {
857                                                                 $isread = 1;
858                                                                 return -1; # exit TOTALLY
859                                                         }
860                                                 }
861                                                 elsif($type eq 'outglobal')
862                                                 {
863                                                         delete $state->{$ofs};
864                                                         return 1
865                                                                 if !%$state;
866                                                 }
867                                                 elsif($type eq 'outglobalvec')
868                                                 {
869                                                         delete $state->{$ofs};
870                                                         delete $state->{$ofs+1};
871                                                         delete $state->{$ofs+2};
872                                                         return 1
873                                                                 if !%$state;
874                                                 }
875                                         }
876                                         return 0;
877                                 };
878
879                         if(!$isread)
880                         {
881                                 ++$warned{$ip}{$operand}{"Value is never used"};
882                         }
883                 }
884         }
885
886         my %solid_seen = ();
887         run_nfa $progs, $func->{first_statement}, do { my $state = -1; \$state; },
888                 sub
889                 {
890                         my $state = ${$_[0]};
891                         return \$state;
892                 },
893                 sub
894                 {
895                         my ($ip, $state) = @_;
896                         return $solid_seen{"$ip $$state"}++;
897                 },
898                 sub
899                 {
900                         my ($ip, $state, $s, $c) = @_;
901
902                         if($s->{op} eq 'ADDRESS')
903                         {
904                                 my $field_ptr_ofs = $s->{b};
905                                 my $def = $progs->{globaldef_byoffset}->($field_ptr_ofs);
906                                 use Data::Dumper;
907                                 if (($def->{globaltype} eq 'read_only' || $def->{globaltype} eq 'const') &&
908                                                 grep { $_ eq 'solid' } @{$progs->{entityfieldnames}[$progs->{globals}[$field_ptr_ofs]{v}{int}]})
909                                 {
910                                         # Taking address of 'solid' for subsequent write!
911                                         # TODO check if this address is then actually used in STOREP.
912                                         $$state = $ip;
913                                 }
914                         }
915
916                         if($c->{iscall})
917                         {
918                                 # TODO check if the entity passed is actually the one on which solid was set.
919                                 my $func = $s->{a};
920                                 if ($progs->{builtins}{setmodel}{$func} || $progs->{builtins}{setorigin}{$func} || $progs->{builtins}{setsize}{$func})
921                                 {
922                                         # All is clean.
923                                         $$state = -1;
924                                 }
925                         }
926
927                         if($c->{isreturn})
928                         {
929                                 if ($$state >= 0) {
930                                         ++$warned{$$state}{''}{"Changing .solid without setmodel/setsize breaks area grid linking in Quake [write is here]"};
931                                         ++$warned{$ip}{''}{"Changing .solid without setmodel/setsize breaks area grid linking in Quake [return is here]"};
932                                 }
933                         }
934
935                         return 0;
936                 };
937
938         disassemble_function($progs, $func, \%warned)
939                 if keys %warned;
940 }
941
942 use constant DEFAULTGLOBALS => [
943         "OFS_NULL",
944         "OFS_RETURN",
945         "OFS_RETURN[1]",
946         "OFS_RETURN[2]",
947         "OFS_PARM0",
948         "OFS_PARM0[1]",
949         "OFS_PARM0[2]",
950         "OFS_PARM1",
951         "OFS_PARM1[1]",
952         "OFS_PARM1[2]",
953         "OFS_PARM2",
954         "OFS_PARM2[1]",
955         "OFS_PARM2[2]",
956         "OFS_PARM3",
957         "OFS_PARM3[1]",
958         "OFS_PARM3[2]",
959         "OFS_PARM4",
960         "OFS_PARM4[1]",
961         "OFS_PARM4[2]",
962         "OFS_PARM5",
963         "OFS_PARM5[1]",
964         "OFS_PARM5[2]",
965         "OFS_PARM6",
966         "OFS_PARM6[1]",
967         "OFS_PARM6[2]",
968         "OFS_PARM7",
969         "OFS_PARM7[1]",
970         "OFS_PARM7[2]"
971 ];
972
973 sub defaultglobal($)
974 {
975         my ($ofs) = @_;
976         if($ofs < @{(DEFAULTGLOBALS)})
977         {
978                 return { ofs => $ofs, s_name => undef, debugname => DEFAULTGLOBALS->[$ofs], type => undef };
979         }
980         return { ofs => $ofs, s_name => undef, debugname => "<undefined>\@$ofs", type => undef };
981 }
982
983 sub detect_constants($)
984 {
985         my ($progs) = @_;
986         use constant GLOBALFLAG_R => 1; # read
987         use constant GLOBALFLAG_W => 2; # written
988         use constant GLOBALFLAG_S => 4; # saved
989         use constant GLOBALFLAG_I => 8; # initialized
990         use constant GLOBALFLAG_N => 16; # named
991         use constant GLOBALFLAG_Q => 32; # unique to function
992         use constant GLOBALFLAG_U => 64; # unused
993         use constant GLOBALFLAG_P => 128; # possibly parameter passing
994         use constant GLOBALFLAG_D => 256; # has a def
995         my @globalflags = (GLOBALFLAG_Q | GLOBALFLAG_U) x (@{$progs->{globals}} + 2);
996
997         for(@{$progs->{functions}})
998         {
999                 for(keys %{$_->{globals_used}})
1000                 {
1001                         if($globalflags[$_] & GLOBALFLAG_U)
1002                         {
1003                                 $globalflags[$_] &= ~GLOBALFLAG_U;
1004                         }
1005                         elsif($globalflags[$_] & GLOBALFLAG_Q)
1006                         {
1007                                 $globalflags[$_] &= ~GLOBALFLAG_Q;
1008                         }
1009                 }
1010                 $globalflags[$_] |= GLOBALFLAG_R
1011                         for keys %{$_->{globals_read}};
1012                 $globalflags[$_] |= GLOBALFLAG_W
1013                         for keys %{$_->{globals_written}};
1014                 next
1015                         if $_->{first_statement} < 0;
1016                 for my $ip($_->{first_statement} .. (@{$progs->{statements}}-1))
1017                 {
1018                         my $s = $progs->{statements}[$ip];
1019                         if($s->{op} eq 'STORE_V')
1020                         {
1021                                 $globalflags[$s->{a}] |= GLOBALFLAG_P
1022                                         if $s->{b} >= $_->{parm_start} and $s->{b} < $_->{parm_start} + $_->{locals};
1023                                 $globalflags[$s->{a}+1] |= GLOBALFLAG_P
1024                                         if $s->{b}+1 >= $_->{parm_start} and $s->{b}+1 < $_->{parm_start} + $_->{locals};
1025                                 $globalflags[$s->{a}+2] |= GLOBALFLAG_P
1026                                         if $s->{b}+2 >= $_->{parm_start} and $s->{b}+2 < $_->{parm_start} + $_->{locals};
1027                         }
1028                         elsif($s->{op} =~ /^STORE_/)
1029                         {
1030                                 $globalflags[$s->{a}] |= GLOBALFLAG_P
1031                                         if $s->{b} >= $_->{parm_start} and $s->{b} < $_->{parm_start} + $_->{locals};
1032                         }
1033                         else
1034                         {
1035                                 last;
1036                         }
1037                 }
1038         }
1039
1040         # parameter passing globals are only ever used in STORE_ instructions
1041         for my $s(@{$progs->{statements}})
1042         {
1043                 next
1044                         if $s->{op} =~ /^STORE_/;
1045
1046                 my $c = checkop $s->{op};
1047
1048                 for(qw(a b c))
1049                 {
1050                         my $type = $c->{$_};
1051                         next
1052                                 unless defined $type;
1053
1054                         my $ofs = $s->{$_};
1055                         if($type eq 'inglobal' || $type eq 'inglobalfunc' || $type eq 'outglobal')
1056                         {
1057                                 $globalflags[$ofs] &= ~GLOBALFLAG_P;
1058                         }
1059                         if($type eq 'inglobalvec' || $type eq 'outglobalvec')
1060                         {
1061                                 $globalflags[$ofs] &= ~GLOBALFLAG_P;
1062                                 $globalflags[$ofs+1] &= ~GLOBALFLAG_P;
1063                                 $globalflags[$ofs+2] &= ~GLOBALFLAG_P;
1064                         }
1065                 }
1066         }
1067
1068         my %offsets_saved = ();
1069         for(@{$progs->{globaldefs}})
1070         {
1071                 my $type = $_->{type};
1072                 my $name = $progs->{getstring}->($_->{s_name});
1073                 $name = ''
1074                         if $name eq 'IMMEDIATE'; # for fteqcc I had: or $name =~ /^\./;
1075                 $_->{debugname} = $name
1076                         if $name ne '';
1077                 $globalflags[$_->{ofs}] |= GLOBALFLAG_D;
1078                 if($type->{save})
1079                 {
1080                         $globalflags[$_->{ofs}] |= GLOBALFLAG_S;
1081                 }
1082                 if(defined $_->{debugname})
1083                 {
1084                         $globalflags[$_->{ofs}] |= GLOBALFLAG_N;
1085                 }
1086         }
1087         # fix up vectors
1088         my @extradefs = ();
1089         for(@{$progs->{globaldefs}})
1090         {
1091                 my $type = $_->{type};
1092                 for my $i(1..(typesize($type->{type})-1))
1093                 {
1094                         # add missing def
1095                         if(!($globalflags[$_->{ofs}+$i] & GLOBALFLAG_D))
1096                         {
1097                                 print "Missing globaldef for a component@{[defined $_->{debugname} ? ' of ' . $_->{debugname} : '']} at $_->{ofs}+$i\n";
1098                                 push @extradefs, {
1099                                         type => {
1100                                                 saved => 0,
1101                                                 type => 'float'
1102                                         },
1103                                         ofs => $_->{ofs} + $i,
1104                                         debugname => defined $_->{debugname} ? $_->{debugname} . "[$i]" : undef
1105                                 };
1106                         }
1107                         # "saved" and "named" states hit adjacent globals too
1108                         $globalflags[$_->{ofs}+$i] |= $globalflags[$_->{ofs}] & (GLOBALFLAG_S | GLOBALFLAG_N | GLOBALFLAG_D);
1109                 }
1110         }
1111         push @{$progs->{globaldefs}}, @extradefs;
1112
1113         my %offsets_initialized = ();
1114         for(0..(@{$progs->{globals}}-1))
1115         {
1116                 if($progs->{globals}[$_]{v}{int})
1117                 {
1118                         $globalflags[$_] |= GLOBALFLAG_I;
1119                 }
1120         }
1121
1122         my @globaltypes = (undef) x @{$progs->{globals}};
1123
1124         my %istemp = ();
1125         for(0..(@{$progs->{globals}}-1))
1126         {
1127                 next
1128                         if $_ < @{(DEFAULTGLOBALS)};
1129                 if(($globalflags[$_] & (GLOBALFLAG_R | GLOBALFLAG_W)) == 0)
1130                 {
1131                         $globaltypes[$_] = "unused";
1132                 }
1133                 elsif(($globalflags[$_] & (GLOBALFLAG_R | GLOBALFLAG_W)) == GLOBALFLAG_R)
1134                 {
1135                         # so it is ro
1136                         if(($globalflags[$_] & GLOBALFLAG_N) == GLOBALFLAG_N)
1137                         {
1138                                 $globaltypes[$_] = "read_only";
1139                         }
1140                         elsif(($globalflags[$_] & GLOBALFLAG_S) == 0)
1141                         {
1142                                 $globaltypes[$_] = "const";
1143                         }
1144                         else
1145                         {
1146                                 $globaltypes[$_] = "read_only";
1147                         }
1148                 }
1149                 elsif(($globalflags[$_] & (GLOBALFLAG_R | GLOBALFLAG_W)) == GLOBALFLAG_W)
1150                 {
1151                         $globaltypes[$_] = "write_only";
1152                 }
1153                 else
1154                 {
1155                         # now we know it is rw
1156                         if(($globalflags[$_] & GLOBALFLAG_N) == GLOBALFLAG_N)
1157                         {
1158                                 $globaltypes[$_] = "global";
1159                         }
1160                         elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I)) == 0)
1161                         {
1162                                 if($globalflags[$_] & GLOBALFLAG_P)
1163                                 {
1164                                         $globaltypes[$_] = "OFS_PARM";
1165                                 }
1166                                 elsif($globalflags[$_] & GLOBALFLAG_Q)
1167                                 {
1168                                         $globaltypes[$_] = "uniquetemp";
1169                                         $istemp{$_} = 0;
1170                                 }
1171                                 else
1172                                 {
1173                                         $globaltypes[$_] = "temp";
1174                                         $istemp{$_} = 1;
1175                                 }
1176                         }
1177                         elsif(($globalflags[$_] & (GLOBALFLAG_S | GLOBALFLAG_I)) == GLOBALFLAG_I)
1178                         {
1179                                 $globaltypes[$_] = "not_saved";
1180                         }
1181                         else
1182                         {
1183                                 $globaltypes[$_] = "global";
1184                         }
1185                 }
1186         }
1187         $progs->{temps} = \%istemp;
1188
1189         # globaldefs
1190         my @globaldefs = (undef) x @{$progs->{globals}};
1191         for(@{$progs->{globaldefs}})
1192         {
1193                 $globaldefs[$_->{ofs}] //= $_
1194                         if defined $_->{debugname};
1195         }
1196         for(@{$progs->{globaldefs}})
1197         {
1198                 $globaldefs[$_->{ofs}] //= $_;
1199         }
1200         for(0..(@{$progs->{globals}}-1))
1201         {
1202                 $globaldefs[$_] //= {
1203                         ofs => $_,
1204                         s_name => undef,
1205                         debugname => undef,
1206                         type => undef
1207                 };
1208         }
1209         for(0..(@{(DEFAULTGLOBALS)}-1))
1210         {
1211                 $globaldefs[$_] = { ofs => $_, s_name => undef, debugname => DEFAULTGLOBALS->[$_], type => undef };
1212                 $globaltypes[$_] = 'defglobal';
1213         }
1214         my %globaldefs_namecount = ();
1215         for(@globaldefs)
1216         {
1217                 $_->{globaltype} = $globaltypes[$_->{ofs}];
1218                 if(defined $_->{debugname})
1219                 {
1220                         # already has debugname
1221                 }
1222                 elsif($_->{globaltype} eq 'const')
1223                 {
1224                         $_->{debugname} = get_constant($progs, $progs->{globals}[$_->{ofs}]{v}, $_->{type}{type});
1225                 }
1226                 else
1227                 {
1228                         $_->{debugname} = "$_->{globaltype}_$_->{ofs}";
1229                 }
1230                 ++$globaldefs_namecount{$_->{debugname}};
1231         }
1232         for(@globaldefs)
1233         {
1234                 next
1235                         if $globaldefs_namecount{$_->{debugname}} <= 1 && !$ENV{FORCE_OFFSETS};
1236                 #print "Not unique: $_->{debugname} at $_->{ofs}\n";
1237                 $_->{debugname} .= "\@$_->{ofs}";
1238         }
1239         $progs->{globaldef_byoffset} = sub
1240         {
1241                 my ($ofs) = @_;
1242                 my $def = $globaldefs[$ofs];
1243                 return $def;
1244         };
1245 }
1246
1247 sub parse_progs($$)
1248 {
1249         my ($fh, $lnofh) = @_;
1250
1251         my %p = ();
1252
1253         print STDERR "Parsing header...\n";
1254         $p{header} = parse_section $fh, DPROGRAMS_T, 0, undef, 1;
1255         
1256         if (defined $lnofh) {
1257                 print STDERR "Parsing LNO...\n";
1258                 my $lnoheader = parse_section $lnofh, LNOHEADER_T, 0, undef, 1;
1259                 eval {
1260                         die "Not a LNOF"
1261                                 if $lnoheader->{lnotype} != unpack 'V', 'LNOF';
1262                         die "Not version 1"
1263                                 if $lnoheader->{version} != 1;
1264                         die "Not same count of globaldefs"
1265                                 if $lnoheader->{numglobaldefs} != $p{header}{numglobaldefs};
1266                         die "Not same count of globals"
1267                                 if $lnoheader->{numglobals} != $p{header}{numglobals};
1268                         die "Not same count of fielddefs"
1269                                 if $lnoheader->{numfielddefs} != $p{header}{numfielddefs};
1270                         die "Not same count of statements"
1271                                 if $lnoheader->{numstatements} != $p{header}{numstatements};
1272                         $p{lno} = [parse_section $lnofh, LNO_T, 24, undef, $lnoheader->{numstatements}];
1273                         eval {
1274                                 $p{lno} = [parse_section $lnofh, LNO_T, 24, undef, $lnoheader->{numstatements} * 2];
1275                                 $p{cno} = [splice $p{lno}, $lnoheader->{numstatements}];
1276                                 print STDERR "Cool, this LNO even has column number info!\n";
1277                         };
1278                 } or warn "Skipping LNO: $@";
1279         }
1280
1281         print STDERR "Parsing strings...\n";
1282         $p{strings} = get_section $fh, $p{header}{ofs_strings}, $p{header}{numstrings};
1283         $p{getstring} = sub
1284         {
1285                 my ($startpos) = @_;
1286                 my $endpos = index $p{strings}, "\0", $startpos;
1287                 return substr $p{strings}, $startpos, $endpos - $startpos;
1288         };
1289
1290         print STDERR "Parsing globals...\n";
1291         $p{globals} = [parse_section $fh, DGLOBAL_T, $p{header}{ofs_globals}, undef, $p{header}{numglobals}];
1292
1293         print STDERR "Parsing globaldefs...\n";
1294         $p{globaldefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_globaldefs}, undef, $p{header}{numglobaldefs}];
1295
1296         print STDERR "Range checking globaldefs...\n";
1297         for(0 .. (@{$p{globaldefs}}-1))
1298         {
1299                 my $g = $p{globaldefs}[$_];
1300                 die "Out of range name in globaldef $_"
1301                         if $g->{s_name} < 0 || $g->{s_name} >= length $p{strings};
1302                 my $name = $p{getstring}->($g->{s_name});
1303                 die "Out of range ofs $g->{ofs} in globaldef $_ (name: \"$name\")"
1304                         if $g->{ofs} >= $p{globals};
1305         }
1306
1307         print STDERR "Parsing fielddefs...\n";
1308         $p{fielddefs} = [parse_section $fh, DDEF_T, $p{header}{ofs_fielddefs}, undef, $p{header}{numfielddefs}];
1309
1310         print STDERR "Range checking fielddefs...\n";
1311         for(0 .. (@{$p{fielddefs}}-1))
1312         {
1313                 my $g = $p{fielddefs}[$_];
1314                 die "Out of range name in fielddef $_"
1315                         if $g->{s_name} < 0 || $g->{s_name} >= length $p{strings};
1316                 my $name = $p{getstring}->($g->{s_name});
1317                 die "Out of range ofs $g->{ofs} in fielddef $_ (name: \"$name\")"
1318                         if $g->{ofs} >= $p{header}{entityfields};
1319                 push @{$p{entityfieldnames}[$g->{ofs}]}, $name;
1320         }
1321
1322         print STDERR "Parsing statements...\n";
1323         $p{statements} = [parse_section $fh, DSTATEMENT_T, $p{header}{ofs_statements}, undef, $p{header}{numstatements}];
1324
1325         print STDERR "Parsing functions...\n";
1326         $p{functions} = [parse_section $fh, DFUNCTION_T, $p{header}{ofs_functions}, undef, $p{header}{numfunctions}];
1327
1328         print STDERR "Range checking functions...\n";
1329         for(0 .. (@{$p{functions}} - 1))
1330         {
1331                 my $f = $p{functions}[$_];
1332                 die "Out of range name in function $_"
1333                         if $f->{s_name} < 0 || $f->{s_name} >= length $p{strings};
1334                 my $name = $p{getstring}->($f->{s_name});
1335                 die "Out of range file in function $_"
1336                         if $f->{s_file} < 0 || $f->{s_file} >= length $p{strings};
1337                 my $file = $p{getstring}->($f->{s_file});
1338                 die "Out of range first_statement in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1339                         if $f->{first_statement} >= @{$p{statements}};
1340                 if($f->{first_statement} >= 0)
1341                 {
1342                         die "Out of range parm_start in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1343                                 if $f->{parm_start} < 0 || $f->{parm_start} >= @{$p{globals}};
1344                         die "Out of range locals in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1345                                 if $f->{locals} < 0 || $f->{parm_start} + $f->{locals} > @{$p{globals}};
1346                         die "Out of range numparms $f->{numparms} in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1347                                 if $f->{numparms} < 0 || $f->{numparms} > 8;
1348                         my $totalparms = 0;
1349                         for(0..($f->{numparms}-1))
1350                         {
1351                                 die "Out of range parm_size[$_] in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1352                                         unless { 0 => 1, 1 => 1, 3 => 1 }->{$f->{parm_size}[$_]};
1353                                 $totalparms += $f->{parm_size}[$_];
1354                         }
1355                         die "Out of range parms in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1356                                 if $f->{parm_start} + $totalparms > @{$p{globals}};
1357                         die "More parms than locals in function $_ (name: \"$name\", file: \"$file\", first statement: $f->{first_statement})"
1358                                 if $totalparms > $f->{locals};
1359                 }
1360         }
1361
1362         print STDERR "Range checking statements...\n";
1363         for my $ip(0 .. (@{$p{statements}}-1))
1364         {
1365                 my $s = $p{statements}[$ip];
1366                 my $c = checkop $s->{op};
1367
1368                 for(qw(a b c))
1369                 {
1370                         my $type = $c->{$_};
1371                         next
1372                                 unless defined $type;
1373
1374                         if($type eq 'inglobal' || $type eq 'inglobalfunc')
1375                         {
1376                                 $s->{$_} &= 0xFFFF;
1377                                 die "Out of range global offset in statement $ip - cannot continue"
1378                                         if $s->{$_} >= @{$p{globals}};
1379                         }
1380                         elsif($type eq 'inglobalvec')
1381                         {
1382                                 $s->{$_} &= 0xFFFF;
1383                                 if($c->{isreturn})
1384                                 {
1385                                         die "Out of range global offset in statement $ip - cannot continue"
1386                                                 if $s->{$_} >= @{$p{globals}};
1387                                         print "Potentially out of range global offset in statement $ip - may crash engines"
1388                                                 if $s->{$_} >= @{$p{globals}}-2;
1389                                 }
1390                                 else
1391                                 {
1392                                         die "Out of range global offset in statement $ip - cannot continue"
1393                                                 if $s->{$_} >= @{$p{globals}}-2;
1394                                 }
1395                         }
1396                         elsif($type eq 'outglobal')
1397                         {
1398                                 $s->{$_} &= 0xFFFF;
1399                                 die "Out of range global offset in statement $ip - cannot continue"
1400                                         if $s->{$_} >= @{$p{globals}};
1401                         }
1402                         elsif($type eq 'outglobalvec')
1403                         {
1404                                 $s->{$_} &= 0xFFFF;
1405                                 die "Out of range global offset in statement $ip - cannot continue"
1406                                         if $s->{$_} >= @{$p{globals}}-2;
1407                         }
1408                         elsif($type eq 'ipoffset')
1409                         {
1410                                 die "Out of range GOTO/IF/IFNOT in statement $ip - cannot continue"
1411                                         if $ip + $s->{$_} < 0 || $ip + $s->{$_} >= @{$p{statements}};
1412                         }
1413                 }
1414         }
1415
1416         print STDERR "Looking for error(), setmodel(), setorigin(), setsize()...\n";
1417         $p{builtins} = { error => {}, setmodel => {}, setorigin => {}, setsize => {} };
1418         for(@{$p{globaldefs}})
1419         {
1420                 my $name = $p{getstring}($_->{s_name});
1421                 next
1422                         if not exists $p{builtins}{$name};
1423                 my $v = $p{globals}[$_->{ofs}]{v}{int};
1424                 next
1425                         if $v <= 0 || $v >= @{$p{functions}};
1426                 my $first = $p{functions}[$v]{first_statement};
1427                 next
1428                         if $first >= 0;
1429                 print STDERR "Detected $name() at offset $_->{ofs} (builtin #@{[-$first]})\n";
1430                 $p{builtins}{$name}{$_->{ofs}} = 1;
1431         }
1432
1433         print STDERR "Scanning functions...\n";
1434         for(@{$p{functions}})
1435         {
1436                 my $file = $p{getstring}->($_->{s_file});
1437                 my $name = $p{getstring}->($_->{s_name});
1438                 $name = "$file:$name"
1439                         if length $file;
1440                 $_->{debugname} = $name;
1441
1442                 next
1443                         if $_->{first_statement} < 0;
1444
1445                 my %statements = ();
1446                 my %come_from = ();
1447                 my %go_to = ();
1448                 my %globals_read = ();
1449                 my %globals_written = ();
1450                 my %globals_used = ();
1451
1452                 if($_->{first_statement} >= 0)
1453                 {
1454                         run_nfa \%p, $_->{first_statement}, "", id, nfa_default_state_checker,
1455                                 sub
1456                                 {
1457                                         my ($ip, $state, $s, $c) = @_;
1458                                         ++$statements{$ip};
1459
1460                                         if(my $j = $c->{isjump})
1461                                         {
1462                                                 my $t = $ip + $s->{$j};
1463                                                 $come_from{$t}{$ip} = $c->{isconditional};
1464                                                 $go_to{$ip}{$t} = $c->{isconditional};
1465                                         }
1466
1467                                         for my $o(qw(a b c))
1468                                         {
1469                                                 my $type = $c->{$o}
1470                                                         or next;
1471                                                 my $ofs = $s->{$o};
1472
1473                                                 my $read = sub
1474                                                 {
1475                                                         my ($ofs) = @_;
1476                                                         $globals_read{$ofs}{$ip}{$o} = 1;
1477                                                         $globals_used{$ofs} = 1;
1478                                                 };
1479                                                 my $write = sub
1480                                                 {
1481                                                         my ($ofs) = @_;
1482                                                         $globals_written{$ofs}{$ip}{$o} = 1;
1483                                                         $globals_used{$ofs} = 1;
1484                                                 };
1485
1486                                                 if($type eq 'inglobal' || $type eq 'inglobalfunc')
1487                                                 {
1488                                                         $read->($ofs);
1489                                                 }
1490                                                 elsif($type eq 'inglobalvec')
1491                                                 {
1492                                                         $read->($ofs);
1493                                                         $read->($ofs+1);
1494                                                         $read->($ofs+2);
1495                                                 }
1496                                                 elsif($type eq 'outglobal')
1497                                                 {
1498                                                         $write->($ofs);
1499                                                 }
1500                                                 elsif($type eq 'outglobalvec')
1501                                                 {
1502                                                         $write->($ofs);
1503                                                         $write->($ofs+1);
1504                                                         $write->($ofs+2);
1505                                                 }
1506                                         }
1507
1508                                         return 0;
1509                                 };
1510                 }
1511
1512                 $_->{statements} = \%statements;
1513                 $_->{come_from} = \%come_from;
1514                 $_->{go_to} = \%go_to;
1515                 $_->{globals_read} = \%globals_read;
1516                 $_->{globals_written} = \%globals_written;
1517                 $_->{globals_used} = \%globals_used;
1518
1519                 # using this info, we could now identify basic blocks
1520         }
1521
1522         print STDERR "Detecting constants and temps, and naming...\n";
1523         detect_constants \%p;
1524
1525         if($ENV{DUMP})
1526         {
1527                 use Data::Dumper;
1528                 print Dumper \%p;
1529                 return;
1530         }
1531
1532         # what do we want to do?
1533         my $checkfunc = \&find_uninitialized_locals;
1534         if($ENV{DISASSEMBLE})
1535         {
1536                 $checkfunc = \&disassemble_function;
1537         }
1538         for(sort { $a->{debugname} cmp $b->{debugname} } @{$p{functions}})
1539         {
1540                 $checkfunc->(\%p, $_);
1541         }
1542 }
1543
1544 for my $progs (@ARGV) {
1545         my $lno = "$progs.lno";
1546         $lno =~ s/\.dat\.lno$/.lno/;
1547
1548         open my $fh, '<', $progs
1549                 or die "$progs: $!";
1550
1551         open my $lnofh, '<', $lno
1552                 or warn "$lno: $!";
1553
1554         parse_progs $fh, $lnofh;
1555 }