|
996
|
1 package Language::INTERCAL::Object;
|
|
|
2
|
|
|
3 # Object file library
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Object.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Config;
|
|
|
19 use POSIX 'strftime';
|
|
|
20 use Language::INTERCAL::Exporter '1.-94.-2',
|
|
|
21 qw(import is_intercal_number compare_version require_version);
|
|
|
22 use Language::INTERCAL::GenericIO '1.-94.-2',
|
|
|
23 qw($stdwrite $stdread $stdsplat $devnull);
|
|
|
24 use Language::INTERCAL::Optimiser '1.-94.-2';
|
|
|
25 use Language::INTERCAL::Parser '1.-94.-2';
|
|
|
26 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
27 use Language::INTERCAL::ByteCode '1.-94.-2',
|
|
|
28 qw(BC_STS BC_CRE BC_DES BC_NOT BC_DSX BC_LAB BC_QUA BC_BUG
|
|
|
29 BC_FLA BC_STR BC_USG
|
|
|
30 BC bc_skip BCget is_constant);
|
|
|
31 use vars qw(@EXPORT_OK);
|
|
|
32 @EXPORT_OK = qw(find_code forall_code make_code);
|
|
|
33
|
|
|
34 # oldest objects we can read and understand
|
|
|
35 use constant MIN_VERSION => '1.-94.-4';
|
|
|
36
|
|
|
37 sub new {
|
|
|
38 @_ == 1 or croak "Usage: new Language::INTERCAL::Object";
|
|
|
39 my ($class) = @_;
|
|
|
40 my $s = Language::INTERCAL::SymbolTable->new();
|
|
|
41 my @p = (
|
|
|
42 Language::INTERCAL::Parser->new($s),
|
|
|
43 Language::INTERCAL::Parser->new($s),
|
|
|
44 );
|
|
|
45 my $o = Language::INTERCAL::Optimiser->new();
|
|
|
46 my @now = gmtime(time);
|
|
|
47 my @ts = map { strftime($_, @now) } qw(%Y %m %d %H %M %S);
|
|
|
48 _new($class, $s, \@p, $o, \@ts, $VERSION);
|
|
|
49 }
|
|
|
50
|
|
|
51 sub _new {
|
|
|
52 my ($class, $s, $p, $o, $ts, $perv) = @_;
|
|
|
53 bless {
|
|
|
54 'read_fh' => $stdread,
|
|
|
55 'write_fh' => $stdwrite,
|
|
|
56 'splat_fh' => $stdsplat,
|
|
|
57 'trace_fh' => $stdsplat,
|
|
|
58 'rs_fh' => $devnull,
|
|
|
59 'optimiser' => $o,
|
|
|
60 'thread' => [],
|
|
|
61 'flags' => {},
|
|
|
62 'code' => ['', {}],
|
|
|
63 'source' => '',
|
|
|
64 'symbols' => $s,
|
|
|
65 'parsers' => $p,
|
|
|
66 'bug' => [0, 1],
|
|
|
67 'timestamp' => $ts,
|
|
|
68 'perversion' => $perv,
|
|
|
69 }, $class;
|
|
|
70 }
|
|
|
71
|
|
|
72 sub perversion {
|
|
|
73 @_ == 1 or croak "Usage: OBJECT->perversion";
|
|
|
74 my ($object) = @_;
|
|
|
75 $object->{perversion};
|
|
|
76 }
|
|
|
77
|
|
|
78 sub setbug {
|
|
|
79 @_ == 3 or croak "Usage: OBJECT->setbug(TYPE, VALUE)";
|
|
|
80 my ($object, $type, $value) = @_;
|
|
|
81 $value < 0 || $value > 100 and croak "Invalid BUG value";
|
|
|
82 $object->{bug} = [$type ? 1 : 0, $value];
|
|
|
83 $object;
|
|
|
84 }
|
|
|
85
|
|
|
86 sub add_flag {
|
|
|
87 @_ == 3 or croak "Usage: OBJECT->add_flag(NAME, VALUE)";
|
|
|
88 my ($object, $flag, $value) = @_;
|
|
|
89 $object->{flags}{$flag} = $value;
|
|
|
90 $object;
|
|
|
91 }
|
|
|
92
|
|
|
93 sub has_flag {
|
|
|
94 @_ == 2 or croak "Usage: OBJECT->has_flag(NAME)";
|
|
|
95 my ($object, $flag) = @_;
|
|
|
96 exists $object->{flags}{$flag};
|
|
|
97 }
|
|
|
98
|
|
|
99 sub flag_value {
|
|
|
100 @_ == 2 or croak "Usage: OBJECT->flag_value(NAME)";
|
|
|
101 my ($object, $flag) = @_;
|
|
|
102 $object->{flags}{$flag};
|
|
|
103 }
|
|
|
104
|
|
|
105 sub delete_flag {
|
|
|
106 @_ == 2 or croak "Usage: OBJECT->delete_flag(NAME)";
|
|
|
107 my ($object, $flag) = @_;
|
|
|
108 delete $object->{flags}{$flag};
|
|
|
109 $object;
|
|
|
110 }
|
|
|
111
|
|
|
112 sub all_flags {
|
|
|
113 @_ == 1 or croak "Usage: OBJECT->all_flags";
|
|
|
114 my ($object) = @_;
|
|
|
115 keys %{$object->{flags}};
|
|
|
116 }
|
|
|
117
|
|
|
118 sub symboltable {
|
|
|
119 @_ == 1 or croak "Usage: OBJECT->symboltable";
|
|
|
120 my ($object) = @_;
|
|
|
121 $object->{symbols};
|
|
|
122 }
|
|
|
123
|
|
|
124 sub num_parsers {
|
|
|
125 @_ == 1 or croak "Usage: OBJECT->num_parsers";
|
|
|
126 my ($object) = @_;
|
|
|
127 scalar @{$object->{parsers}};
|
|
|
128 }
|
|
|
129
|
|
|
130 sub parser {
|
|
|
131 @_ == 2 or croak "Usage: OBJECT->parser(NUMBER)";
|
|
|
132 my ($object, $number) = @_;
|
|
|
133 $number < 1 || $number > @{$object->{parsers}}
|
|
|
134 and croak "Invalid NUMBER";
|
|
|
135 $object->{parsers}[$number - 1];
|
|
|
136 }
|
|
|
137
|
|
|
138 sub shift_parsers {
|
|
|
139 @_ == 1 or croak "Usage: OBJECT->shift_parsers";
|
|
|
140 my ($object) = @_;
|
|
|
141 shift @{$object->{parsers}};
|
|
|
142 my $p = Language::INTERCAL::Parser->new($object->{symbols});
|
|
|
143 push @{$object->{parsers}}, $p;
|
|
|
144 }
|
|
|
145
|
|
|
146 sub write {
|
|
|
147 @_ == 2 || @_ == 3 || @_ == 4
|
|
|
148 or croak "Usage: write Language::INTERCAL::Object"
|
|
|
149 . "(FILEHANDLE [, JUST_FLAGS [, AVOID_SKIP?]])";
|
|
|
150 my ($class, $fh, $fonly, $ask) = @_;
|
|
|
151 unless ($ask) {
|
|
|
152 while (1) {
|
|
|
153 my $line = $fh->write_text();
|
|
|
154 croak "Invalid Object Format (no __END__)"
|
|
|
155 if ! defined $line || $line eq '';
|
|
|
156 last if $line =~ /__END__/ || $line =~ /__DATA__/;
|
|
|
157 }
|
|
|
158 }
|
|
|
159 my $line = $fh->write_text();
|
|
|
160 $line =~ /^CLC-INTERCAL (\S+) Object File\n$/
|
|
|
161 or croak "Invalid Object Format ($line)";
|
|
|
162 my $perversion = $1;
|
|
|
163 is_intercal_number($perversion)
|
|
|
164 or croak "Invalid Object Perversion ($perversion)";
|
|
|
165 compare_version($perversion, MIN_VERSION) >= 0
|
|
|
166 or croak "Object too old to load with this perversion of sick";
|
|
|
167 require_version Language::INTERCAL::Object $perversion;
|
|
|
168 my @timestamp = unpack('vCCCCC', $fh->write_binary(7));
|
|
|
169 my $fcount = unpack('v', $fh->write_binary(2));
|
|
|
170 my %flags = ();
|
|
|
171 while ($fcount-- > 0) {
|
|
|
172 my $flen = unpack('v', $fh->write_binary(2));
|
|
|
173 my $fname = $fh->write_binary($flen);
|
|
|
174 my $fvalue = '';
|
|
|
175 $fvalue = $1 if $fname =~ s/=(.*)$//;
|
|
|
176 $flags{$fname} = $fvalue;
|
|
|
177 }
|
|
|
178 my ($o, @p, $code, %code, $syms, $source);
|
|
|
179 unless ($fonly) {
|
|
|
180 my ($fmask, $fsize);
|
|
|
181 if (exists $flags{__object_format}) {
|
|
|
182 $fmask = 'vvvvvvvCCvvv';
|
|
|
183 $fsize = 22;
|
|
|
184 } else {
|
|
|
185 $fmask = 'vvvvvvCCCvvv';
|
|
|
186 $fsize = 21;
|
|
|
187 }
|
|
|
188 my $clen = unpack('v', $fh->write_binary(2));
|
|
|
189 $code = $fh->write_binary($clen);
|
|
|
190 my $ns = unpack('v', $fh->write_binary(2));
|
|
|
191 %code = ();
|
|
|
192 while ($ns-- > 0) {
|
|
|
193 my ($sval, $nr) = unpack('vv', $fh->write_binary(4));
|
|
|
194 my @r = ();
|
|
|
195 while (@r < $nr) {
|
|
|
196 my ($ju, $sl, $ls, $ll, $ds, $dl, $ge, $ab, $qu, $xs, $xl, $rl) =
|
|
|
197 unpack($fmask, $fh->write_binary($fsize));
|
|
|
198 my $ru = $fh->write_binary($rl);
|
|
|
199 if ($ge == 255) {
|
|
|
200 $ge = unpack('v', $fh->write_binary(2));
|
|
|
201 }
|
|
|
202 my @rb = split(//, unpack('b*', $ru));
|
|
|
203 my @ru = grep { $rb[$_] } (0..$#rb);
|
|
|
204 push @r,
|
|
|
205 [$ju, $sl, $ls, $ll, $ds, $dl, $ge, $ab, $qu, $xs, $xl, @ru];
|
|
|
206 }
|
|
|
207 $code{$sval} = \@r;
|
|
|
208 }
|
|
|
209 my $slen = unpack('v', $fh->write_binary(2)) || 0;
|
|
|
210 $source = $fh->write_binary($slen);
|
|
|
211 $syms = Language::INTERCAL::SymbolTable->write($fh);
|
|
|
212 my $psize = unpack('v', $fh->write_binary(2)) || 0;
|
|
|
213 @p = ();
|
|
|
214 while (@p < $psize) {
|
|
|
215 push @p, Language::INTERCAL::Parser->write($fh, $syms);
|
|
|
216 }
|
|
|
217 $o = Language::INTERCAL::Optimiser->write($fh);
|
|
|
218 }
|
|
|
219 my $obj = _new($class, $syms, \@p, $o, \@timestamp, $perversion);
|
|
|
220 $obj->{code} = [$code, \%code];
|
|
|
221 $obj->{source} = $source;
|
|
|
222 $obj->{flags} = \%flags;
|
|
|
223 $obj;
|
|
|
224 }
|
|
|
225
|
|
|
226 sub read {
|
|
|
227 @_ == 2 or croak "Usage: read Language::INTERCAL::Object(FILEHANDLE)";
|
|
|
228 my ($obj, $fh) = @_;
|
|
|
229 $fh->read_text($Config{startperl} . "\n");
|
|
|
230 $fh->read_text('eval \'exec /usr/bin/perl -w -S $0 ${1+"$@"}\'' . "\n");
|
|
|
231 $fh->read_text(" if 0; # not running under some shell\n");
|
|
|
232 $fh->read_text("# GENERATED BY CLC-INTERCAL $VERSION\n");
|
|
|
233 $fh->read_text("# TO MODIFY, EDIT SOURCE AND REPACKAGE\n");
|
|
|
234 $fh->read_text("\n");
|
|
|
235 $fh->read_text("use Getopt::Long;\n");
|
|
|
236 $fh->read_text("use Language::INTERCAL::GenericIO '$VERSION';\n");
|
|
|
237 $fh->read_text("use Language::INTERCAL::Interpreter '$VERSION';\n");
|
|
|
238 $fh->read_text("use Language::INTERCAL::Server '$VERSION';\n");
|
|
|
239 $fh->read_text("use Language::INTERCAL::Rcfile '$VERSION';\n");
|
|
|
240 $fh->read_text("\n");
|
|
|
241 $fh->read_text("my \$rc = Language::INTERCAL::Rcfile->new();\n");
|
|
|
242 $fh->read_text("if (defined &Getopt::Long::Configure) {\n");
|
|
|
243 $fh->read_text(" Getopt::Long::Configure qw(no_ignore_case auto_abbrev permute bundling pass_through);\n");
|
|
|
244 $fh->read_text("} else {\n");
|
|
|
245 $fh->read_text(" \$Getopt::Long::ignorecase = 0;\n");
|
|
|
246 $fh->read_text(" \$Getopt::Long::autoabbrev = 1;\n");
|
|
|
247 $fh->read_text(" \$Getopt::Long::order = \$Getopt::Long::PERMUTE;\n");
|
|
|
248 $fh->read_text(" \$Getopt::Long::bundling = 1;\n");
|
|
|
249 $fh->read_text("}\n");
|
|
|
250 $fh->read_text("my \$wimp = 0;\n");
|
|
|
251 $fh->read_text("my \$trace = 0;\n");
|
|
|
252 $fh->read_text("my \$stdtrace = undef;\n");
|
|
|
253 $fh->read_text("GetOptions(\n");
|
|
|
254 $fh->read_text(" 'wimp!' => \\\$wimp,\n");
|
|
|
255 $fh->read_text(" 'trace!' => \\\$trace,\n");
|
|
|
256 $fh->read_text(" 'stdtrace=s' => \\\$stdtrace,\n");
|
|
|
257 $fh->read_text(" 'nouserrc' => sub { \$rc->setoption('nouserrc', 1) },\n");
|
|
|
258 $fh->read_text(" 'rcfile=s' => sub { \$rc->setoption(\@_) },\n");
|
|
|
259 $fh->read_text(");\n");
|
|
|
260 $fh->read_text("\$rc->load();\n");
|
|
|
261 $fh->read_text("my \$fh = Language::INTERCAL::GenericIO->new('FILE', 'w', \\*DATA);\n");
|
|
|
262 $fh->read_text("my \$int = Language::INTERCAL::Interpreter->write(\$rc, \$fh, 1);\n");
|
|
|
263 $fh->read_text("if (defined \$stdtrace) {\n");
|
|
|
264 $fh->read_text(" \$trace = 1;\n");
|
|
|
265 $fh->read_text(" my \$mode = \$stdtrace =~ s/^([ra]),//i ? lc(\$1) : 'r';\n");
|
|
|
266 $fh->read_text(" my \$th = Language::INTERCAL::GenericIO->new('FILE', \$mode, \$stdtrace);\n");
|
|
|
267 $fh->read_text(" \$int->setreg('\@TRFH', \$th);\n");
|
|
|
268 $fh->read_text("}\n");
|
|
|
269 $fh->read_text("\$int->setreg('\%WT', \$wimp);\n");
|
|
|
270 $fh->read_text("\$int->setreg('\%TM', \$trace);\n");
|
|
|
271 $fh->read_text("\$int->setreg('^AV', \\\@ARGV);\n");
|
|
|
272 $fh->read_text("\$int->setreg('^EV', [map { \"\$_=\$ENV{\$_}\" } keys \%ENV]);\n");
|
|
|
273 $fh->read_text("\$int->start()->run()->stop();\n");
|
|
|
274 $fh->read_text("\n");
|
|
|
275 $fh->read_text("__DATA__\n");
|
|
|
276 $fh->read_text("CLC-INTERCAL $VERSION Object File\n");
|
|
|
277 $fh->read_binary(pack('vCCCCC', @{$obj->{timestamp}}));
|
|
|
278 $obj->{flags}{__object_format} = 1;
|
|
|
279 my @flags = keys %{$obj->{flags}};
|
|
|
280 $fh->read_binary(pack('v', scalar @flags));
|
|
|
281 for my $fname (@flags) {
|
|
|
282 my $fvalue = $obj->{flags}{$fname};
|
|
|
283 my $flag = "$fname=$fvalue";
|
|
|
284 $fh->read_binary(pack('v/a*', $flag));
|
|
|
285 }
|
|
|
286 my ($cs, $cp) = @{$obj->{code}};
|
|
|
287 my @cp = keys %$cp;
|
|
|
288 $fh->read_binary(pack('v/a* v', $cs, scalar @cp));
|
|
|
289 for my $s (@cp) {
|
|
|
290 my $p = $cp->{$s};
|
|
|
291 $fh->read_binary(pack('vv', $s, scalar @$p));
|
|
|
292 for my $q (@$p) {
|
|
|
293 my ($ju, $sl, $ls, $ll, $ds, $dl, $ge, $ab, $qu, $xs, $xl, @ru) =
|
|
|
294 @$q;
|
|
|
295 my $ru = '';
|
|
|
296 vec($ru, $_, 1) = 1 for @ru;
|
|
|
297 $fh->read_binary(pack('vvvvvvvCCvv v/a*', $ju, $sl, $ls, $ll,
|
|
|
298 $ds, $dl, $ge, $ab,
|
|
|
299 $qu, $xs, $xl, $ru));
|
|
|
300 }
|
|
|
301 }
|
|
|
302 my $source = defined $obj->{source} ? $obj->{source} : '';
|
|
|
303 $fh->read_binary(pack('v/a*', $source));
|
|
|
304 $obj->{symbols}->read($fh);
|
|
|
305 $fh->read_binary(pack('v', scalar @{$obj->{parsers}}));
|
|
|
306 for my $p (@{$obj->{parsers}}) {
|
|
|
307 $p->read($fh);
|
|
|
308 }
|
|
|
309 $obj->{optimiser}->read($fh);
|
|
|
310 $obj;
|
|
|
311 }
|
|
|
312
|
|
|
313 sub make_code {
|
|
|
314 @_ == 2 or croak "Usage: OBJECT->make_code(NEWCODE)";
|
|
|
315 my ($obj, $newcode) = @_;
|
|
|
316 my %obj = (bug => [0, 0]);
|
|
|
317 _setcode($obj, \%obj, $newcode);
|
|
|
318 wantarray ? @{$obj{code}} : $obj{code}[0];
|
|
|
319 }
|
|
|
320
|
|
|
321 sub setcode {
|
|
|
322 @_ == 3 or croak "Usage: OBJECT->set_code(CODE, CPTR)";
|
|
|
323 my ($obj, $code, $cptr) = @_;
|
|
|
324 $obj->{code} = [$code, $cptr];
|
|
|
325 $obj;
|
|
|
326 }
|
|
|
327
|
|
|
328 sub code {
|
|
|
329 @_ == 1 || @_ == 2 or croak "Usage: OBJECT->code [(NEWCODE)]";
|
|
|
330 my $obj = shift;
|
|
|
331 my @oldcode = @{$obj->{code}};
|
|
|
332 if (@_) {
|
|
|
333 my $newcode = shift;
|
|
|
334 _setcode($obj, $obj, $newcode);
|
|
|
335 }
|
|
|
336 wantarray ? @oldcode : $oldcode[0];
|
|
|
337 }
|
|
|
338
|
|
|
339 sub source {
|
|
|
340 @_ == 1 || @_ == 2 or croak "Usage: OBJECT->source [(NEWSOURCE)]";
|
|
|
341 my $obj = shift;
|
|
|
342 if (@_) {
|
|
|
343 my $oldsource = $obj->{source};
|
|
|
344 $obj->{source} = shift;
|
|
|
345 length $obj->{source} > 0xffff
|
|
|
346 and faint(SP_INDIGESTION);
|
|
|
347 return $oldsource;
|
|
|
348 }
|
|
|
349 $obj->{source};
|
|
|
350 }
|
|
|
351
|
|
|
352 sub forall_code {
|
|
|
353 @_ == 3 or croak "Usage: forall_code(CPTR, RULES, CODE)";
|
|
|
354 my ($cptr, $rules, $co) = @_;
|
|
|
355 for my $sptr (sort { $a <=> $b } keys %$cptr) {
|
|
|
356 for my $p (@{$cptr->{$sptr}}) {
|
|
|
357 my ($ju, $sl, $ls, $ll, $ds, $dl, $ge,
|
|
|
358 $ab, $qu, $xs, $xl, @ru) = @$p;
|
|
|
359 $co->($xs, $xl, $sptr, $sl, $ab,
|
|
|
360 $ls, $ll, $ds, $dl, $ge, $qu);
|
|
|
361 }
|
|
|
362 }
|
|
|
363 }
|
|
|
364
|
|
|
365 sub find_code {
|
|
|
366 @_ == 3 or croak "Usage: find_code(CPTR, SPTR, RULES)";
|
|
|
367 my ($cptr, $sptr, $rules) = @_;
|
|
|
368 # if possible, find a valid statement
|
|
|
369 if (exists $cptr->{$sptr}) {
|
|
|
370 TRY:
|
|
|
371 for my $p (@{$cptr->{$sptr}}) {
|
|
|
372 my ($ju, $sl, $ls, $ll, $ds, $dl, $ge,
|
|
|
373 $ab, $qu, $xs, $xl, @ru) = @$p;
|
|
|
374 if ($rules) {
|
|
|
375 for my $rn (@ru) {
|
|
|
376 next TRY if ! $rules->[$rn];
|
|
|
377 next TRY if ! ${$rules->[$rn]};
|
|
|
378 }
|
|
|
379 }
|
|
|
380 # the first one found is the best as we have already sorted the
|
|
|
381 # list in _setcode
|
|
|
382 return ($xs, $xl, $sl, $ab, $ls, $ll, $ds, $dl, $ge, $qu);
|
|
|
383 }
|
|
|
384 }
|
|
|
385 # no valid statement; determine the length of the comment
|
|
|
386 my @later = grep { $_ > $sptr } keys %$cptr;
|
|
|
387 my $len = undef;
|
|
|
388 if (@later) {
|
|
|
389 my ($next) = sort { $a <=> $b } @later;
|
|
|
390 $len = $next - $sptr;
|
|
|
391 }
|
|
|
392 return (undef, $sptr, $len, 0);
|
|
|
393 }
|
|
|
394
|
|
|
395 sub _addcode {
|
|
|
396 my ($js, $cf) = @_;
|
|
|
397 my $fp = index($$js, $cf);
|
|
|
398 return $fp if $fp >= 0;
|
|
|
399 $fp = length($$js);
|
|
|
400 $$js .= $cf;
|
|
|
401 return $fp;
|
|
|
402 }
|
|
|
403
|
|
|
404 sub _optimise {
|
|
|
405 my ($obj, $code, $seen) = @_;
|
|
|
406 return $code if ! exists $obj->{optimiser};
|
|
|
407 return $seen->{$code} if exists $seen->{$code};
|
|
|
408 $seen->{$code} = $obj->{optimiser}->optimise($code);
|
|
|
409 return $seen->{$code};
|
|
|
410 }
|
|
|
411
|
|
|
412 sub _setcode {
|
|
|
413 my ($pobj, $obj, $code) = @_;
|
|
|
414 my %optimise = ();
|
|
|
415 my %code = ();
|
|
|
416 my $joincode = '';
|
|
|
417 my $sts = pack('C', BC_STS);
|
|
|
418 my @code = @{ref $code ? $code : [$code]};
|
|
|
419 if (@code && $obj->{bug}[1] > rand(100)) {
|
|
|
420 my $bpos = int(rand scalar @code);
|
|
|
421 $code[$bpos] .= pack('C*', BC_BUG, BC($obj->{bug}[0] ? 1 : 0));
|
|
|
422 }
|
|
|
423 STATEMENT:
|
|
|
424 for my $cv (@code) {
|
|
|
425 next if $cv eq '';
|
|
|
426 my $ep = length $cv;
|
|
|
427 unless (substr($cv, 0, 1) eq $sts) {
|
|
|
428 my $bc = sprintf("%02X", ord(substr($cv, 0, 1)));
|
|
|
429 faint(SP_INVALID, $bc, "_setcode");
|
|
|
430 }
|
|
|
431 my $ncp = 1;
|
|
|
432 my $start = BCget($cv, \$ncp, $ep);
|
|
|
433 my $len = BCget($cv, \$ncp, $ep);
|
|
|
434 my $junk = BCget($cv, \$ncp, $ep);
|
|
|
435 my $count = BCget($cv, \$ncp, $ep);
|
|
|
436 my @rules = ();
|
|
|
437 while (@rules < $count) {
|
|
|
438 push @rules, BCget($cv, \$ncp, $ep);
|
|
|
439 }
|
|
|
440 @rules = sort { $a <=> $b } @rules;
|
|
|
441 my $gerund = 0;
|
|
|
442 my $abstain = 0;
|
|
|
443 my $quantum = 0;
|
|
|
444 my @label = (0, 0);
|
|
|
445 my @dsx = (0, 0);
|
|
|
446 while ($ncp < $ep) {
|
|
|
447 my $byte = ord(substr($cv, $ncp++, 1));
|
|
|
448 if ($byte == BC_NOT) {
|
|
|
449 $abstain = 1;
|
|
|
450 next;
|
|
|
451 }
|
|
|
452 if ($byte == BC_QUA) {
|
|
|
453 $quantum = 1;
|
|
|
454 next;
|
|
|
455 }
|
|
|
456 if ($byte == BC_LAB) {
|
|
|
457 $ncp < $ep or faint(SP_INVALID, '(end of statement)', 'LAB');
|
|
|
458 if (is_constant(ord(substr($cv, $ncp, 1)))) {
|
|
|
459 $label[0] = BCget($cv, \$ncp, $ep);
|
|
|
460 $label[1] = 0;
|
|
|
461 } else {
|
|
|
462 my $diff = bc_skip($cv, $ncp, $ep);
|
|
|
463 $label[0] = _addcode(\$joincode, substr($cv, $ncp, $diff));
|
|
|
464 $label[1] = $diff;
|
|
|
465 $ncp += $diff;
|
|
|
466 }
|
|
|
467 next;
|
|
|
468 }
|
|
|
469 if ($byte == BC_DSX) {
|
|
|
470 $ncp < $ep or faint(SP_INVALID, '(end of statement)', 'DSX');
|
|
|
471 if (is_constant(ord(substr($cv, $ncp, 1)))) {
|
|
|
472 $dsx[0] = 1 + BCget($cv, \$ncp, $ep);
|
|
|
473 $dsx[1] = 0;
|
|
|
474 } else {
|
|
|
475 my $diff = bc_skip($cv, $ncp, $ep);
|
|
|
476 $dsx[0] = _addcode(\$joincode, substr($cv, $ncp, $diff));
|
|
|
477 $dsx[1] = $diff;
|
|
|
478 $ncp += $diff;
|
|
|
479 }
|
|
|
480 next;
|
|
|
481 }
|
|
|
482 if ($byte == BC_USG) {
|
|
|
483 my $vcp = $ncp;
|
|
|
484 $gerund = BCget($cv, \$vcp, $ep);
|
|
|
485 $ncp--;
|
|
|
486 last;
|
|
|
487 }
|
|
|
488 $gerund = $byte;
|
|
|
489 $ncp--;
|
|
|
490 last;
|
|
|
491 }
|
|
|
492 my $addcode = substr($cv, $ncp, $ep - $ncp);
|
|
|
493 if ($gerund == BC_FLA) {
|
|
|
494 # try executing this now...
|
|
|
495 my $fb = $ncp + 1;
|
|
|
496 my ($flag, $value);
|
|
|
497 if (substr($cv, $fb, 1) eq chr(BC_STR)) {
|
|
|
498 $fb++;
|
|
|
499 my $length = BCget($cv, \$fb, $ep);
|
|
|
500 faint(SP_INVALID, 'flag name has wrong length', '_setcode')
|
|
|
501 if $length + $fb > $ep;
|
|
|
502 $flag = substr($cv, $fb, $length);
|
|
|
503 $fb += $length;
|
|
|
504 } else {
|
|
|
505 my $length = BCget($cv, \$fb, $ep);
|
|
|
506 $flag = '';
|
|
|
507 while (length $flag < $length) {
|
|
|
508 $flag .= chr(BCget($cv, \$fb, $ep));
|
|
|
509 }
|
|
|
510 }
|
|
|
511 if (substr($cv, $fb, 1) eq chr(BC_STR)) {
|
|
|
512 $fb++;
|
|
|
513 my $length = BCget($cv, \$fb, $ep);
|
|
|
514 faint(SP_INVALID, 'flag name has wrong length', '_setcode')
|
|
|
515 if $length + $fb > $ep;
|
|
|
516 $value = substr($cv, $fb, $length);
|
|
|
517 $fb += $length;
|
|
|
518 } else {
|
|
|
519 my $length = BCget($cv, \$fb, $ep);
|
|
|
520 $value = '';
|
|
|
521 while (length $value < $length) {
|
|
|
522 $value .= chr(BCget($cv, \$fb, $ep));
|
|
|
523 }
|
|
|
524 }
|
|
|
525 faint(SP_INVALID, 'extra code after flag', '_setcode')
|
|
|
526 if $fb != $ep;
|
|
|
527 $pobj->{flags}{$flag} = $value unless $abstain;
|
|
|
528 $addcode = chr(BC_FLA);
|
|
|
529 $abstain = 1;
|
|
|
530 }
|
|
|
531 my @objcode = (
|
|
|
532 _addcode(\$joincode, $addcode),
|
|
|
533 length($addcode),
|
|
|
534 );
|
|
|
535 # look for the very same thing...
|
|
|
536 my @addit = (
|
|
|
537 $junk, $len,
|
|
|
538 $label[0], $label[1],
|
|
|
539 $dsx[0], $dsx[1],
|
|
|
540 $gerund, $abstain, $quantum,
|
|
|
541 $objcode[0], $objcode[1],
|
|
|
542 @rules,
|
|
|
543 );
|
|
|
544 if (exists $code{$start}{$junk}{$len}) {
|
|
|
545 TRY:
|
|
|
546 for my $p (@{$code{$start}{$junk}{$len}}) {
|
|
|
547 next TRY if @addit != @$p;
|
|
|
548 # the following works because @rules are sorted
|
|
|
549 for (my $i = 0; $i < @addit; $i++) {
|
|
|
550 next TRY if $p->[$i] != $addit[$i];
|
|
|
551 }
|
|
|
552 # yup, it's the very same - no need to add it then
|
|
|
553 next STATEMENT;
|
|
|
554 }
|
|
|
555 }
|
|
|
556 # we'll have to add this one
|
|
|
557 push @{$code{$start}{$junk}{$len}}, \@addit;
|
|
|
558 }
|
|
|
559 length $joincode > 0xffff
|
|
|
560 and faint(SP_INDIGESTION);
|
|
|
561 # now go and transform each value of %code... note that we sort the
|
|
|
562 # array so that noncomments are always before comments, and shorter
|
|
|
563 # comments are preferred over longer; however within the same comment
|
|
|
564 # length (or within the noncomment group) we prefer longer source
|
|
|
565 # code; all else being equal, we prefer things which use more grammar
|
|
|
566 # rules
|
|
|
567 for my $sp (keys %code) {
|
|
|
568 my @elems = ();
|
|
|
569 for my $j (sort { $a <=> $b } keys %{$code{$sp}}) {
|
|
|
570 for my $l (sort { $b <=> $a } keys %{$code{$sp}{$j}}) {
|
|
|
571 push @elems, sort {
|
|
|
572 scalar @$a <=> scalar @$b
|
|
|
573 } @{$code{$sp}{$j}{$l}};
|
|
|
574 }
|
|
|
575 }
|
|
|
576 $code{$sp} = \@elems;
|
|
|
577 }
|
|
|
578 $obj->{code} = [$joincode, \%code];
|
|
|
579 }
|
|
|
580
|
|
|
581 1;
|
