|
996
|
1 package Language::INTERCAL::Sick;
|
|
|
2
|
|
|
3 # Compiler/user interface/whatnot for CLC-INTERCAL
|
|
|
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/Sick.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use File::Basename;
|
|
|
19 use File::Spec::Functions;
|
|
|
20 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
21 use Language::INTERCAL::Charset '1.-94.-2', qw(charset_name toascii charset);
|
|
|
22 use Language::INTERCAL::GenericIO '1.-94.-2';
|
|
|
23 use Language::INTERCAL::Backend '1.-94.-2', qw(backend generate_code);
|
|
|
24 use Language::INTERCAL::Interpreter '1.-94.-2';
|
|
|
25
|
|
|
26 sub new {
|
|
|
27 @_ == 2 or croak "Usage: new Language::INTERCAL::Sick(RC)";
|
|
|
28 my ($class, $rc) = @_;
|
|
|
29 bless {
|
|
|
30 object_option => {
|
|
|
31 backend => '',
|
|
|
32 bug => 1,
|
|
|
33 charset => '',
|
|
|
34 name => '%o',
|
|
|
35 optimise => 0,
|
|
|
36 output => '%p.%s',
|
|
|
37 preload => [],
|
|
|
38 suffix => '',
|
|
|
39 trace => undef,
|
|
|
40 trace_fh => undef,
|
|
|
41 ubug => 0.01,
|
|
|
42 verbose => 0,
|
|
|
43 },
|
|
|
44 shared_option => {
|
|
|
45 default_backend => 'Object',
|
|
|
46 default_charset => [],
|
|
|
47 default_extra => [],
|
|
|
48 default_suffix => [],
|
|
|
49 preload_callback => undef,
|
|
|
50 },
|
|
|
51 sources => [],
|
|
|
52 filepath => {},
|
|
|
53 shared_filepath => {},
|
|
|
54 int_cache => {},
|
|
|
55 loaded => 0,
|
|
|
56 rc => $rc,
|
|
|
57 theft_server => 0,
|
|
|
58 server => 0,
|
|
|
59 }, $class;
|
|
|
60 }
|
|
|
61
|
|
|
62 sub reset {
|
|
|
63 @_ == 1 or croak "Usage: SICK->reset";
|
|
|
64 my ($sick) = @_;
|
|
|
65 $sick->{loaded} = 0;
|
|
|
66 $sick->{sources} = [];
|
|
|
67 $sick;
|
|
|
68 }
|
|
|
69
|
|
|
70 my %checkoption = (
|
|
|
71 backend => \&_load_backend,
|
|
|
72 bug => \&_check_bug,
|
|
|
73 charset => \&_load_charset,
|
|
|
74 default_backend => \&_load_backend,
|
|
|
75 default_charset => \&_load_charset,
|
|
|
76 default_extra => \&_check_extra,
|
|
|
77 default_suffix => \&_check_suffix,
|
|
|
78 optimise => \&_check_bool,
|
|
|
79 preload => \&_check_object,
|
|
|
80 preload_callback => \&_check_callback,
|
|
|
81 trace => \&_check_bool,
|
|
|
82 trace_fh => \&_check_filehandle,
|
|
|
83 ubug => \&_check_bug,
|
|
|
84 verbose => \&_check_filehandle,
|
|
|
85 );
|
|
|
86
|
|
|
87 my %object_type = (
|
|
|
88 IACC => 'COMPILER',
|
|
|
89 COMPILER => 'COMPILER',
|
|
|
90 ASSEMBLER => 'COMPILER',
|
|
|
91 RUNCOMPILER => 'COMPILER',
|
|
|
92 BASE => 'ONEONLY',
|
|
|
93 POSTPRE => 'ONEONLY',
|
|
|
94 EXTENSION => 'REPEAT',
|
|
|
95 OPTION => 'REPEAT',
|
|
|
96 OPTIMISER => 'REPEAT',
|
|
|
97 );
|
|
|
98
|
|
|
99 sub option {
|
|
|
100 @_ == 2 or @_ == 3 or croak "Usage: SICK->option(NAME [, VALUE])";
|
|
|
101 @_ == 2 ? shift->getoption(@_) : shift->setoption(@_);
|
|
|
102 }
|
|
|
103
|
|
|
104 sub getoption {
|
|
|
105 @_ == 2 or croak "Usage: SICK->getoption(NAME)";
|
|
|
106 my ($sick, $name) = @_;
|
|
|
107 my $value = exists $sick->{object_option}{$name}
|
|
|
108 ? $sick->{object_option}{$name}
|
|
|
109 : exists $sick->{shared_option}{$name}
|
|
|
110 ? $sick->{shared_option}{$name}
|
|
|
111 : die "Unknown option $name\n";
|
|
|
112 return $value unless ref $value;
|
|
|
113 return $value if UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO');
|
|
|
114 return @$value if 'ARRAY' eq ref $value;
|
|
|
115 return map { ($_ => [@{$value->{$_}}]) } keys %$value
|
|
|
116 if 'HASH' eq ref $value;
|
|
|
117 return (); # should never get here
|
|
|
118 }
|
|
|
119
|
|
|
120 sub setoption {
|
|
|
121 @_ == 3 or croak "Usage: SICK->setoption(NAME, VALUE)";
|
|
|
122 my ($sick, $name, $value) = @_;
|
|
|
123 my $hash = exists $sick->{object_option}{$name}
|
|
|
124 ? $sick->{object_option}
|
|
|
125 : exists $sick->{shared_option}{$name}
|
|
|
126 ? $sick->{shared_option}
|
|
|
127 : die "Unknown option $name\n";
|
|
|
128 if (exists $checkoption{$name}) {
|
|
|
129 $value = $checkoption{$name}->($name, $sick, $value);
|
|
|
130 }
|
|
|
131 if (! ref $hash->{$name}) {
|
|
|
132 $hash->{$name} = $value;
|
|
|
133 } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
|
|
|
134 $hash->{$name} = $value;
|
|
|
135 } elsif ('ARRAY' eq ref $hash->{$name}) {
|
|
|
136 push @{$hash->{$name}}, $value;
|
|
|
137 } elsif ('HASH' eq ref $hash->{$name}) {
|
|
|
138 my ($key, $as, @add) = @$value;
|
|
|
139 if (exists $hash->{$name}{$key}) {
|
|
|
140 $hash->{$name}{$key}[0] = $as;
|
|
|
141 } else {
|
|
|
142 $hash->{$name}{$key} = [$as];
|
|
|
143 }
|
|
|
144 push @{$hash->{$name}{$key}}, @add;
|
|
|
145 } else {
|
|
|
146 # not supposed to get here
|
|
|
147 die "Cannot set option $name\n";
|
|
|
148 }
|
|
|
149 $sick;
|
|
|
150 }
|
|
|
151
|
|
|
152 sub clearoption {
|
|
|
153 @_ == 2 or croak "Usage: SICK->clearoption(NAME)";
|
|
|
154 my ($sick, $name) = @_;
|
|
|
155 my $hash = exists $sick->{object_option}{$name}
|
|
|
156 ? $sick->{object_option}
|
|
|
157 : exists $sick->{shared_option}{$name}
|
|
|
158 ? $sick->{shared_option}
|
|
|
159 : die "Unknown option $name\n";
|
|
|
160 if (ref $hash->{$name}) {
|
|
|
161 if (UNIVERSAL::isa($hash->{$name}, 'Language::INTERCAL::GenericIO')) {
|
|
|
162 $hash->{$name} = 0;
|
|
|
163 } elsif ('ARRAY' eq ref $hash->{$name}) {
|
|
|
164 $hash->{$name} = [];
|
|
|
165 } elsif ('HASH' eq ref $hash->{$name}) {
|
|
|
166 $hash->{$name} = {};
|
|
|
167 } else {
|
|
|
168 die "Cannot clear option $name\n";
|
|
|
169 }
|
|
|
170 } else {
|
|
|
171 die "Cannot clear option $name\n";
|
|
|
172 }
|
|
|
173 $sick;
|
|
|
174 }
|
|
|
175
|
|
|
176 sub alloptions {
|
|
|
177 @_ == 1 or @_ == 2 or croak "Usage: SICK->alloptions [(shared)]";
|
|
|
178 my ($sick, $shared) = @_;
|
|
|
179 my %vals = ();
|
|
|
180 my @hash = ();
|
|
|
181 push @hash, 'object_option' if ! defined $shared || ! $shared;
|
|
|
182 push @hash, 'shared_option' if ! defined $shared || ! $shared;
|
|
|
183 for my $hash (@hash) {
|
|
|
184 while (my ($name, $value) = each %{$sick->{$hash}}) {
|
|
|
185 if (! ref $value) {
|
|
|
186 # nothing, but we don't want to be caught in next cases
|
|
|
187 } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
|
|
|
188 # nothing, but we don't want to be caught in next cases
|
|
|
189 } elsif ('ARRAY' eq ref $value) {
|
|
|
190 # a shallow copy will do -- we know values are strings
|
|
|
191 $value = [ @$value ];
|
|
|
192 } elsif ('HASH' eq ref $value) {
|
|
|
193 # two level deep copy: the values are arrays of strings
|
|
|
194 my %v = ();
|
|
|
195 while (my ($key, $val) = each %$value) {
|
|
|
196 $v{$key} = [ @$val ];
|
|
|
197 }
|
|
|
198 $value = \%v;
|
|
|
199 } elsif (ref $value) {
|
|
|
200 # WTF?
|
|
|
201 $value = undef;
|
|
|
202 }
|
|
|
203 $vals{$name} = $value;
|
|
|
204 }
|
|
|
205 }
|
|
|
206 %vals;
|
|
|
207 }
|
|
|
208
|
|
|
209 sub source {
|
|
|
210 @_ == 2 or croak "Usage: SICK->source(FILENAME)";
|
|
|
211 my ($sick, $file) = @_;
|
|
|
212 $file = _check_file($sick, $file);
|
|
|
213 push @{$sick->{sources}}, {
|
|
|
214 'source' => $file,
|
|
|
215 'option' => { $sick->alloptions(0) }, # don't copy shared options
|
|
|
216 'filepath' => $sick->{filepath},
|
|
|
217 };
|
|
|
218 $sick->{loaded} = 0;
|
|
|
219 $sick;
|
|
|
220 }
|
|
|
221
|
|
|
222 sub load_objects {
|
|
|
223 @_ == 1 or croak "Usage: SICK->load_objects()";
|
|
|
224 my ($sick) = @_;
|
|
|
225 return $sick if $sick->{loaded};
|
|
|
226 for (my $i = 0; $i < @{$sick->{sources}}; $i++) {
|
|
|
227 my $object = $sick->{sources}[$i];
|
|
|
228 next if exists $object->{object};
|
|
|
229 my $o = $object->{option};
|
|
|
230 my ($obj, $fn, $base, $is_src) = _load_source($sick, $object, $o);
|
|
|
231 $object->{is_src} = $is_src;
|
|
|
232 $object->{base} = $base;
|
|
|
233 $object->{object} = $obj;
|
|
|
234 $object->{filename} = $fn;
|
|
|
235 }
|
|
|
236 $sick->{loaded} = 1;
|
|
|
237 $sick;
|
|
|
238 }
|
|
|
239
|
|
|
240 sub save_objects {
|
|
|
241 @_ == 2 or croak "Usage: SICK->save_objects(AND_KEEP?)";
|
|
|
242 my ($sick, $keep) = @_;
|
|
|
243 $sick->load_objects();
|
|
|
244 for my $object (@{$sick->{sources}}) {
|
|
|
245 my $o = $object->{option};
|
|
|
246 my $backend = $o->{backend};
|
|
|
247 next unless $object->{is_src} || $backend ne 'Object';
|
|
|
248 my $out = $o->{output};
|
|
|
249 next if $out eq '';
|
|
|
250 $backend = $sick->{shared_option}{default_backend}
|
|
|
251 if $backend eq '';
|
|
|
252 my $v = $o->{verbose} ? sub {
|
|
|
253 my ($name) = @_;
|
|
|
254 $o->{verbose}->read_text($name eq '' ? 'Running...'
|
|
|
255 : "Saving $name... ");
|
|
|
256 } : '';
|
|
|
257 my $orig = $object->{source};
|
|
|
258 $orig =~ s/\.[^.]*$//;
|
|
|
259 my %op = (
|
|
|
260 verbose => $v,
|
|
|
261 );
|
|
|
262 generate_code($object->{object}, $backend, $o->{name},
|
|
|
263 $object->{base}, $out, $orig, \%op);
|
|
|
264 $o->{verbose}->read_text("OK\n") if $o->{verbose};
|
|
|
265 undef $object unless $keep;
|
|
|
266 }
|
|
|
267 $sick;
|
|
|
268 }
|
|
|
269
|
|
|
270 sub theft_server {
|
|
|
271 @_ == 2 or croak "Usage: SICK->theft_server(SERVER)";
|
|
|
272 my ($sick, $server) = @_;
|
|
|
273 $sick->{theft_server} = $server;
|
|
|
274 $sick;
|
|
|
275 }
|
|
|
276
|
|
|
277 sub server {
|
|
|
278 @_ == 2 or croak "Usage: SICK->server(SERVER)";
|
|
|
279 my ($sick, $server) = @_;
|
|
|
280 $sick->{server} = $server;
|
|
|
281 $sick;
|
|
|
282 }
|
|
|
283
|
|
|
284 sub get_object {
|
|
|
285 @_ == 2 or croak "Usage: SICK->get_object(NAME)";
|
|
|
286 my ($sick, $name) = @_;
|
|
|
287 for my $o (@{$sick->{sources}}) {
|
|
|
288 next if $o->{source} ne $name;
|
|
|
289 return $o->{object};
|
|
|
290 }
|
|
|
291 undef;
|
|
|
292 }
|
|
|
293
|
|
|
294
|
|
|
295 sub all_objects {
|
|
|
296 @_ == 2 || @_ == 3
|
|
|
297 or croak "Usage: SICK->all_objects(CALLBACK [, JUST_FLAGS])";
|
|
|
298 my ($sick, $callback, $just_flags) = @_;
|
|
|
299 for my $search (@{$sick->{rc}->getoption('include')}) {
|
|
|
300 opendir(SEARCH, $search) or next;
|
|
|
301 while (defined (my $ent = readdir SEARCH)) {
|
|
|
302 $ent =~ /^(.*)\.io$/ or next;
|
|
|
303 my $name = $1;
|
|
|
304 my $file = catfile($search, $ent);
|
|
|
305 -f $file or next;
|
|
|
306 eval {
|
|
|
307 my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $file);
|
|
|
308 my $ob = Language::INTERCAL::Object->write($fh, $just_flags);
|
|
|
309 my $type = undef;
|
|
|
310 $ob->has_flag('TYPE')
|
|
|
311 and $type = $ob->flag_value('TYPE');
|
|
|
312 $callback->($name, $file, $type, $ob);
|
|
|
313 };
|
|
|
314 }
|
|
|
315 closedir SEARCH;
|
|
|
316 }
|
|
|
317 $sick;
|
|
|
318 }
|
|
|
319
|
|
|
320 # private methods follow
|
|
|
321
|
|
|
322 sub _check_bool {
|
|
|
323 my ($name, $sick, $value) = @_;
|
|
|
324 return $value if $value =~ /^\d+$/;
|
|
|
325 return 1 if $value =~ /^t(?:rue)?$/i;
|
|
|
326 return 1 if $value =~ /^y(?:es)?$/i;
|
|
|
327 return 0 if $value =~ /^f(?:alse)?$/i;
|
|
|
328 return 0 if $value =~ /^n(?:o)?$/i;
|
|
|
329 die "Invalid value for $name\: '$value'\n";
|
|
|
330 }
|
|
|
331
|
|
|
332 sub _check_filehandle {
|
|
|
333 my ($name, $sick, $value) = @_;
|
|
|
334 return $value if ref $value &&
|
|
|
335 UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO');
|
|
|
336 return undef if $value =~ /^\d+$/ && $value == 0;
|
|
|
337 return undef if $value =~ /^n(?:one)?$/i;
|
|
|
338 die "Invalid filehandle value '$value'\n";
|
|
|
339 }
|
|
|
340
|
|
|
341 sub _check_path {
|
|
|
342 my ($name, $sick, $value) = @_;
|
|
|
343 return $value if -d $value;
|
|
|
344 die "Invalid path '$value'\n";
|
|
|
345 }
|
|
|
346
|
|
|
347 sub _check_bug {
|
|
|
348 my ($name, $sick, $value) = @_;
|
|
|
349 $value =~ /^(?:\d+(?:\.\d*)?|\.\d+)$/
|
|
|
350 or die "Value '$value' is not a positive number\n";
|
|
|
351 $value <= 100
|
|
|
352 or die "Value '$value' is too large for a probability\n";
|
|
|
353 $value;
|
|
|
354 }
|
|
|
355
|
|
|
356 sub _check_extra {
|
|
|
357 my ($name, $sick, $value) = @_;
|
|
|
358 ref $value && ref $value eq 'ARRAY'
|
|
|
359 or die "Invalid value for $name (must be a array ref)\n";
|
|
|
360 @$value == 3
|
|
|
361 or die "Invalid value for $name (requires three elements)\n";
|
|
|
362 my ($extra, $preload, $as) = @$value;
|
|
|
363 ref $preload && ref $preload eq 'ARRAY'
|
|
|
364 or die "Invalid value for $name (preloads must be array ref)\n";
|
|
|
365 [$extra, $preload, $as];
|
|
|
366 }
|
|
|
367
|
|
|
368 sub _check_suffix {
|
|
|
369 my ($name, $sick, $value) = @_;
|
|
|
370 ref $value && ref $value eq 'ARRAY'
|
|
|
371 or die "Invalid value for $name (must be a array ref)\n";
|
|
|
372 @$value == 3
|
|
|
373 or die "Invalid value for $name (requires three elements)\n";
|
|
|
374 my ($suffix, $as, $map) = @$value;
|
|
|
375 ref $map && ref $map eq 'HASH'
|
|
|
376 or die "Invalid value for $name (third element must be hash ref)\n";
|
|
|
377 exists $map->{''} && ref $map->{''} && ref $map->{''} eq 'ARRAY'
|
|
|
378 or die "Invalid value for $name (preloads must be array ref)\n";
|
|
|
379 # suffix map have alternatives expressed as something like
|
|
|
380 # ./2:3:4:5:6:7/i => .2i .3i ... .7i
|
|
|
381 # ./l:n:g:t://i => .li .ni .gi .ti .lni .nli ...
|
|
|
382 # note that we have no nesting of alternatives; use different rules
|
|
|
383 my @resplit = ();
|
|
|
384 my $regex = '';
|
|
|
385 while ($suffix =~ s#^(.*?)/##) {
|
|
|
386 $regex .= quotemeta($1);
|
|
|
387 $suffix =~ s#^(.*?)/##
|
|
|
388 or die "Invalid value for $name\: unclosed / in suffix\n";
|
|
|
389 my @extra = split(/:/, $1);
|
|
|
390 for my $extra (@extra) {
|
|
|
391 exists $map->{$extra} or next;
|
|
|
392 ref $map->{$extra} && ref $map->{$extra} eq 'ARRAY'
|
|
|
393 or die "Invalid value for $name " .
|
|
|
394 "(preloads for $extra must be array ref)\n";
|
|
|
395 }
|
|
|
396 my $extra = join('|', map { quotemeta } @extra);
|
|
|
397 my $star = $suffix =~ s#^:## ? '*' : '';
|
|
|
398 $regex .= '((?:' . $extra . ')' . $star . ')';
|
|
|
399 push @resplit, qr/^($extra)/;
|
|
|
400 }
|
|
|
401 $regex .= quotemeta($suffix) . '$';
|
|
|
402 $regex = qr/$regex/i;
|
|
|
403 return [$regex, $as, \@resplit, $map];
|
|
|
404 }
|
|
|
405
|
|
|
406 sub _find_file {
|
|
|
407 my ($sick, $value, $ftype, $cache, $path) = @_;
|
|
|
408 return $cache->{$value} if exists $cache->{$value};
|
|
|
409 # try opening file from current directory
|
|
|
410 if (-f $value) {
|
|
|
411 $cache->{$value} = $value;
|
|
|
412 return $value;
|
|
|
413 }
|
|
|
414 if (! file_name_is_absolute($value)) {
|
|
|
415 my ($file, $dir) = fileparse($value);
|
|
|
416 $path = $sick->{rc}->getoption('include') if ! defined $path;
|
|
|
417 for my $search (@$path) {
|
|
|
418 my $n = catfile($search, $dir, $file);
|
|
|
419 $n = canonpath($n);
|
|
|
420 if (-f $n) {
|
|
|
421 $cache->{$value} = $n;
|
|
|
422 return $n;
|
|
|
423 }
|
|
|
424 }
|
|
|
425 }
|
|
|
426 die "Cannot find $ftype \"$value\"\n";
|
|
|
427 }
|
|
|
428
|
|
|
429 sub _check_file {
|
|
|
430 my ($sick, $value) = @_;
|
|
|
431 _find_file($sick, $value, 'file',
|
|
|
432 $sick->{filecache},
|
|
|
433 $sick->{rc}->getoption('include'));
|
|
|
434 $value;
|
|
|
435 }
|
|
|
436
|
|
|
437 sub _find_object {
|
|
|
438 my ($sick, $value, $cache, $path) = @_;
|
|
|
439 if ($value !~ /\.ior?$/) {
|
|
|
440 # try adding suffix first
|
|
|
441 my $v = eval {
|
|
|
442 _find_file($sick, $value . '.io', 'object', $cache, $path);
|
|
|
443 };
|
|
|
444 unless ($@) {
|
|
|
445 return $v . 'r' if -f $v . 'r';
|
|
|
446 return $v;
|
|
|
447 }
|
|
|
448 }
|
|
|
449 _find_file($sick, $value, 'object', $cache, $path);
|
|
|
450 }
|
|
|
451
|
|
|
452 sub _check_object {
|
|
|
453 my ($name, $sick, $value) = @_;
|
|
|
454 # _find_object($sick, $value,
|
|
|
455 # $sick->{filecache},
|
|
|
456 # $sick->{rc}->getoption('include'));
|
|
|
457 $value;
|
|
|
458 }
|
|
|
459
|
|
|
460 sub _check_callback {
|
|
|
461 my ($name, $sick, $value) = @_;
|
|
|
462 ! $value and return $value; # unset callback
|
|
|
463 ref $value && UNIVERSAL::isa($value, 'CODE')
|
|
|
464 and return [$value];
|
|
|
465 ref $value && UNIVERSAL::isa($value, 'ARRAY')
|
|
|
466 or die "Invalid callback, must be a CODE or ARRAY reference\n";
|
|
|
467 ref $value->[0] && UNIVERSAL::isa($value->[0], 'CODE')
|
|
|
468 or die "Invalid callback, first element must be a CODE reference\n";
|
|
|
469 $value;
|
|
|
470 }
|
|
|
471
|
|
|
472 sub _open_file {
|
|
|
473 my ($sick, $source, $cache, $path) = @_;
|
|
|
474 my $fn = _find_file($sick, $source, 'file', $cache, $path);
|
|
|
475 my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $fn);
|
|
|
476 ($fn, $fh);
|
|
|
477 }
|
|
|
478
|
|
|
479 sub _load_backend {
|
|
|
480 my ($name, $sick, $value) = @_;
|
|
|
481 defined backend($value)
|
|
|
482 or die "Invalid backend: $value";
|
|
|
483 $value;
|
|
|
484 }
|
|
|
485
|
|
|
486 sub _load_charset {
|
|
|
487 my ($name, $sick, $value) = @_;
|
|
|
488 defined charset_name($value)
|
|
|
489 or die "Invalid charset: $value\n";
|
|
|
490 $value;
|
|
|
491 }
|
|
|
492
|
|
|
493 sub _load_source {
|
|
|
494 my ($sick, $source, $o) = @_;
|
|
|
495 my ($fn, $fh) = _open_file($sick, $source->{source},
|
|
|
496 $source->{filepath},
|
|
|
497 $sick->{rc}->getoption('include'));
|
|
|
498 $o->{verbose}->read_text("$fn... ") if $o->{verbose};
|
|
|
499 my $base = $fn;
|
|
|
500 my $suffix = '';
|
|
|
501 if ($o->{suffix}) {
|
|
|
502 $suffix = $o->{suffix};
|
|
|
503 $suffix = '.' . $suffix if $suffix !~ /^\./;
|
|
|
504 $base =~ s/(\.[^.]*)$//; # remove and ignore suffix
|
|
|
505 } elsif ($base =~ s/(\.[^.]*)$//) {
|
|
|
506 $suffix = lc($1);
|
|
|
507 }
|
|
|
508 # first see if it is a real object (you never know)
|
|
|
509 my $int = eval {
|
|
|
510 Language::INTERCAL::Interpreter->write($sick->{rc}, $fh);
|
|
|
511 };
|
|
|
512 if (defined $int && ref $int) {
|
|
|
513 $o->{verbose}->read_text("[COMPILER OBJECT]\n") if $o->{verbose};
|
|
|
514 $int->server($sick->{server});
|
|
|
515 $int->theft_server($sick->{theft_server});
|
|
|
516 $int->setreg('TRFH', $o->{trace_fh}) if defined $o->{trace_fh};
|
|
|
517 $int->setreg('TM', $o->{trace}) if defined $o->{trace};
|
|
|
518 return ($int, $fn, $base, 0);
|
|
|
519 }
|
|
|
520 # failed for whatever reason, we'll try loading as a source
|
|
|
521 $fh->reset();
|
|
|
522 my @preload = @{$o->{preload}};
|
|
|
523 @preload = _guess_preloads($sick, $suffix, $o)
|
|
|
524 unless @preload;
|
|
|
525 # try to find a compiler
|
|
|
526 my @options = ();
|
|
|
527 my @compiler = ();
|
|
|
528 my %preloaded = ();
|
|
|
529 for my $p (@preload, 'postpre') {
|
|
|
530 next if $p eq '';
|
|
|
531 _preload($sick, $p, $source->{filepath}, $o, \%preloaded,
|
|
|
532 \@options, \@compiler);
|
|
|
533 }
|
|
|
534 exists $preloaded{COMPILER}
|
|
|
535 or die "Invalid preload list: no compiler\n";
|
|
|
536 # load the compiler and run it if required
|
|
|
537 if ($compiler[1]) {
|
|
|
538 # compiler saved using RunObject
|
|
|
539 $int = $compiler[0];
|
|
|
540 } else {
|
|
|
541 # compiler saved using Object - create a new interpreter and run the
|
|
|
542 # compiler in it
|
|
|
543 $int = Language::INTERCAL::Interpreter->new($sick->{rc});
|
|
|
544 unshift @options, $compiler[0];
|
|
|
545 }
|
|
|
546 $int->server($sick->{server});
|
|
|
547 $int->theft_server($sick->{theft_server});
|
|
|
548 $int->setreg('TRFH', $o->{trace_fh}) if defined $o->{trace_fh};
|
|
|
549 $int->setreg('TM', $o->{trace}) if defined $o->{trace};
|
|
|
550 my $obj = $int->object;
|
|
|
551 if ($o->{bug} > 0) {
|
|
|
552 $obj->setbug(0, $o->{bug});
|
|
|
553 } else {
|
|
|
554 $obj->setbug(1, $o->{ubug});
|
|
|
555 }
|
|
|
556 # execute all the options
|
|
|
557 for my $p (@options) {
|
|
|
558 $int->start(1)->run($p)->stop();
|
|
|
559 }
|
|
|
560 # do we need to guess character set?
|
|
|
561 my $chr = $o->{charset};
|
|
|
562 if ($chr eq '') {
|
|
|
563 $chr = _guess_charset($sick, $source->{source}, $fh);
|
|
|
564 }
|
|
|
565 $fh->write_charset($chr);
|
|
|
566 $fh->reset();
|
|
|
567 # now read file
|
|
|
568 my $line = 1;
|
|
|
569 my $col = 1;
|
|
|
570 my $scount = 0;
|
|
|
571 my $text = $fh->write_text('');
|
|
|
572 $o->{verbose}->read_text("\n source: " . length($text) . " bytes")
|
|
|
573 if $o->{verbose};
|
|
|
574 $obj->source($text);
|
|
|
575 $int->verbose_compile($o->{verbose});
|
|
|
576 $int->compile($text);
|
|
|
577 $o->{verbose}->read_text(" [object: " . _int_size($obj) . " bytes]")
|
|
|
578 if $o->{verbose};
|
|
|
579 $o->{verbose}->read_text("\n") if $o->{verbose};
|
|
|
580 return ($int, $fn, $base, 1);
|
|
|
581 }
|
|
|
582
|
|
|
583 sub _preload {
|
|
|
584 my ($sick, $file, $cache, $o, $preloaded, $options, $compiler) = @_;
|
|
|
585 my $fn = _find_object($sick, $file, $cache,
|
|
|
586 $sick->{rc}->getoption('include'));
|
|
|
587 $o->{verbose}->read_text("\n [$file: $fn") if $o->{verbose};
|
|
|
588 my ($ci, $size);
|
|
|
589 if (exists $sick->{int_cache}{$fn}) {
|
|
|
590 ($ci, $size) = @{$sick->{int_cache}{$fn}};
|
|
|
591 if ($o->{verbose} && ! $size) {
|
|
|
592 $sick->{int_cache}{$fn}[1] = $size = _int_size($ci);
|
|
|
593 }
|
|
|
594 } else {
|
|
|
595 my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $fn);
|
|
|
596 $ci = Language::INTERCAL::Interpreter->write($sick->{rc}, $fh);
|
|
|
597 $size = $o->{verbose} ? _int_size($ci) : 0;
|
|
|
598 $sick->{int_cache}{$fn} = [$ci, $size];
|
|
|
599 }
|
|
|
600 $ci->object->has_flag('TYPE')
|
|
|
601 or die "Invalid object - did not provide a type\n";
|
|
|
602 my $ct = $ci->object->flag_value('TYPE');
|
|
|
603 exists $object_type{$ct} or die "Invalid object type: $ct\n";
|
|
|
604 my $ot = $object_type{$ct};
|
|
|
605 if ($ot eq 'COMPILER') {
|
|
|
606 exists $preloaded->{$ct}
|
|
|
607 and die "Invalid preloads list - compiler " .
|
|
|
608 "$preloaded->{$ot} already loaded\n";
|
|
|
609 $preloaded->{$ot} = $file;
|
|
|
610 $compiler->[0] = $ci;
|
|
|
611 $compiler->[1] = $ct eq 'RUNCOMPILER';
|
|
|
612 } elsif ($ot eq 'ONEONLY') {
|
|
|
613 exists $preloaded->{$ct}
|
|
|
614 and die "Invalid preloads list - \L$ct\E " .
|
|
|
615 "$preloaded->{$ct} already loaded\n";
|
|
|
616 $preloaded->{$ct} = $file;
|
|
|
617 push @$options, $ci;
|
|
|
618 } elsif ($ot eq 'REPEAT') {
|
|
|
619 push @$options, $ci;
|
|
|
620 } else {
|
|
|
621 die "Internal error, unmapped type $ot\n";
|
|
|
622 }
|
|
|
623 # if they want to do additional checks, let them
|
|
|
624 if ($sick->{shared_option}{preload_callback}) {
|
|
|
625 my ($code, @args) = @{$sick->{shared_option}{preload_callback}};
|
|
|
626 $code->($sick, $file, $fn, $ct, @args);
|
|
|
627 }
|
|
|
628 $o->{verbose}->read_text(": type \L$ct\E: $size bytes]") if $o->{verbose};
|
|
|
629 }
|
|
|
630
|
|
|
631 sub _guess_extra {
|
|
|
632 my ($sick, $extra) = @_;
|
|
|
633 for my $xd (@{$sick->{shared_option}{default_extra}}) {
|
|
|
634 my ($x, $preload, $as) = @$xd;
|
|
|
635 next if $x ne $extra;
|
|
|
636 return ($preload, $as);
|
|
|
637 }
|
|
|
638 ();
|
|
|
639 }
|
|
|
640
|
|
|
641 sub _guess_preloads {
|
|
|
642 my ($sick, $suffix, $o) = @_;
|
|
|
643 # must guess preloads from suffix
|
|
|
644 for my $sd (@{$sick->{shared_option}{default_suffix}}) {
|
|
|
645 my ($regex, $as, $resplit, $map) = @$sd;
|
|
|
646 next unless ref $resplit;
|
|
|
647 my @extra = $suffix =~ $regex;
|
|
|
648 next unless @extra;
|
|
|
649 if (@$resplit) {
|
|
|
650 my @e = ();
|
|
|
651 for my $r (@$resplit) {
|
|
|
652 my $e = shift @extra;
|
|
|
653 next unless defined $e;
|
|
|
654 while ($e =~ s/$r//) {
|
|
|
655 push @e, $1;
|
|
|
656 }
|
|
|
657 die "Internal error in _guess_preloads\n" if $e ne '';
|
|
|
658 }
|
|
|
659 @extra = @e;
|
|
|
660 } else {
|
|
|
661 @extra = ();
|
|
|
662 }
|
|
|
663 my @preloads = ();
|
|
|
664 my %preloads = ();
|
|
|
665 for my $p (@{$map->{''}}) {
|
|
|
666 my $q = $p;
|
|
|
667 if ($q =~ s/^\?//) {
|
|
|
668 next unless $o->{optimise};
|
|
|
669 }
|
|
|
670 push @preloads, $q;
|
|
|
671 $preloads{$q} = 1;
|
|
|
672 }
|
|
|
673 my @as = ( $as );
|
|
|
674 my %as = ( $as => 1 );
|
|
|
675 for my $extra (@extra) {
|
|
|
676 my ($_p, $a);
|
|
|
677 if (exists $map->{$extra}) {
|
|
|
678 ($_p, $a) = @{$map->{$extra}};
|
|
|
679 } else {
|
|
|
680 ($_p, $a) = _guess_extra($sick, $extra);
|
|
|
681 die "Inconsistent sickrc: $extra?\n" unless defined $_p;
|
|
|
682 }
|
|
|
683 for my $p (@$_p) {
|
|
|
684 my $q = $p;
|
|
|
685 if ($q =~ s/^\?//) {
|
|
|
686 next unless $o->{optimise};
|
|
|
687 }
|
|
|
688 next if exists $preloads{$q};
|
|
|
689 push @preloads, $q;
|
|
|
690 $preloads{$q} = 1;
|
|
|
691 }
|
|
|
692 next if $a eq '' || exists $as{$a};
|
|
|
693 push @as, $a;
|
|
|
694 $as{$a} = 1;
|
|
|
695 }
|
|
|
696 $o->{verbose}->read_text(" [" . join(' + ', @as) . "]")
|
|
|
697 if $o->{verbose};
|
|
|
698 return @preloads;
|
|
|
699 }
|
|
|
700 die "Cannot guess file type\n";
|
|
|
701 }
|
|
|
702
|
|
|
703 sub _guess_charset {
|
|
|
704 my ($sick, $source, $fh) = @_;
|
|
|
705 my %counts = ();
|
|
|
706 for my $name (@{$sick->{shared_option}{default_charset}}) {
|
|
|
707 eval {
|
|
|
708 my $cnv = toascii($name);
|
|
|
709 my $count = 0;
|
|
|
710 while ((my $line = $fh->write_binary(4096)) ne '') {
|
|
|
711 my $cl = &$cnv($line);
|
|
|
712 $count++ while $line =~ /DO|PLEASE/ig;
|
|
|
713 }
|
|
|
714 $counts{$name} = $count;
|
|
|
715 };
|
|
|
716 $fh->reset();
|
|
|
717 }
|
|
|
718 my @counts =
|
|
|
719 sort {$counts{$b} <=> $counts{$a}} grep {$counts{$_}} keys %counts;
|
|
|
720 if (@counts == 0 && $fh->write_binary(1) eq '') {
|
|
|
721 $fh->reset();
|
|
|
722 @counts = qw(ASCII);
|
|
|
723 $counts{ASCII} = 1;
|
|
|
724 }
|
|
|
725 if (! @counts || $counts{$counts[0]} < 1) {
|
|
|
726 my $cr = $sick->{object_option}{verbose} ? "\n" : "";
|
|
|
727 die "${cr}File \"$source\": cannot guess character set\n";
|
|
|
728 }
|
|
|
729 $counts[0];
|
|
|
730 }
|
|
|
731
|
|
|
732 sub _int_size {
|
|
|
733 my ($int) = @_;
|
|
|
734 my $size = 0;
|
|
|
735 my $fh = new Language::INTERCAL::GenericIO 'COUNT', 'r', \$size;
|
|
|
736 $int->read($fh);
|
|
|
737 $size;
|
|
|
738 }
|
|
|
739
|
|
|
740 1
|
