|
996
|
1 #!/usr/bin/perl -w
|
|
|
2
|
|
|
3 eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
|
|
|
4 if 0; # not running under some shell
|
|
|
5
|
|
|
6 # Simple INTERCAL desk calculator
|
|
|
7
|
|
|
8 # This file is part of CLC-INTERCAL
|
|
|
9
|
|
|
10 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
11
|
|
|
12 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
13 # and distribute it is granted provided that the conditions set out in the
|
|
|
14 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
15
|
|
|
16 require 5.005;
|
|
|
17
|
|
|
18 use strict;
|
|
|
19 use Getopt::Long;
|
|
|
20 use IO::File;
|
|
|
21 use Config '%Config';
|
|
|
22
|
|
|
23 use vars qw($VERSION $PERVERSION);
|
|
|
24 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/ICALC bin/intercalc 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
25
|
|
|
26 use Language::INTERCAL::Sick '1.-94.-2';
|
|
|
27 use Language::INTERCAL::Rcfile '1.-94.-2';
|
|
|
28 use Language::INTERCAL::Interface '1.-94.-2';
|
|
|
29 use Language::INTERCAL::Server '1.-94.-2';
|
|
|
30 use Language::INTERCAL::ReadNumbers '1.-94.-2', qw(roman roman_type);
|
|
|
31
|
|
|
32 my %roman_ok = map { ( roman_type($_) => 1 ) } qw(CLC ARCHAIC WIMPMODE);
|
|
|
33
|
|
|
34 my %object_types = (
|
|
|
35 COMPILER => 'LANGUAGE',
|
|
|
36 BASE => 'BASE',
|
|
|
37 EXTENSION => 'OPTION',
|
|
|
38 OPTION => 'OPTION',
|
|
|
39 POSTPRE => undef,
|
|
|
40 );
|
|
|
41
|
|
|
42 my %menu_defs = (
|
|
|
43 LANGUAGE => [ 'Language', \&_change_language, 0 ],
|
|
|
44 BASE => [ 'Base', \&_change_base, 0 ],
|
|
|
45 OPTION => [ 'Options', \&_toggle_option, 1 ],
|
|
|
46 );
|
|
|
47
|
|
|
48 my %escape_defs = (
|
|
|
49 'a' => [\&_about, undef, undef, undef],
|
|
|
50 'b' => [\&_change_base, 'BASE', undef, 'bases'],
|
|
|
51 'c' => [\&_sickrc, undef, undef, undef],
|
|
|
52 'g' => [\&_give_up, undef, undef, undef],
|
|
|
53 'h' => [\&_history, '0', undef, undef],
|
|
|
54 'l' => [\&_change_language, 'LANGUAGE', '+', 'languages'],
|
|
|
55 'm' => [\&_change_mode, '0', undef, undef],
|
|
|
56 'o' => [\&_toggle_option, 'OPTION', undef, 'options'],
|
|
|
57 'r' => [\&_read_or_readas, '0', undef, undef],
|
|
|
58 't' => [\&_trace, '0', undef, undef],
|
|
|
59 'v' => [\&_version, undef, undef, undef],
|
|
|
60 'w' => [\&_write_file, '', undef, undef],
|
|
|
61 '?' => [\&_help, undef, undef, undef],
|
|
|
62 # secret undocumented escape to be used in an undocumented way
|
|
|
63 "\0" => [\&_undocumented, undef, undef, undef],
|
|
|
64 );
|
|
|
65
|
|
|
66 if (defined &Getopt::Long::Configure) {
|
|
|
67 Getopt::Long::Configure qw(no_ignore_case auto_abbrev permute bundling);
|
|
|
68 } else {
|
|
|
69 $Getopt::Long::ignorecase = 0;
|
|
|
70 $Getopt::Long::autoabbrev = 1;
|
|
|
71 $Getopt::Long::order = $Getopt::Long::PERMUTE;
|
|
|
72 $Getopt::Long::bundling = 1;
|
|
|
73 }
|
|
|
74
|
|
|
75 my $rcfile = new Language::INTERCAL::Rcfile;
|
|
|
76 my $compiler = new Language::INTERCAL::Sick($rcfile);
|
|
|
77 my $setoption = sub { $compiler->setoption(@_) };
|
|
|
78 my $language = undef;
|
|
|
79 my @options = ();
|
|
|
80 my $mode = undef;
|
|
|
81 my $user_interface = '';
|
|
|
82 my $history = 5;
|
|
|
83 my @history = ();
|
|
|
84 my $command = '';
|
|
|
85
|
|
|
86 GetOptions(
|
|
|
87 # User Interface Options
|
|
|
88 'graphic|X' => sub { $user_interface = 'X' },
|
|
|
89 'curses|c' => sub { $user_interface = 'Curses' },
|
|
|
90 'line' => sub { $user_interface = 'Line' },
|
|
|
91 'batch' => sub { $user_interface = 'None' },
|
|
|
92 'interface|i=s' => \$user_interface,
|
|
|
93 # source language and compile options
|
|
|
94 'bug=i' => $setoption,
|
|
|
95 'ubug=i' => $setoption,
|
|
|
96 'include|I=s' => sub { $rcfile->setoption(@_) },
|
|
|
97 'language|l=s' => \$language,
|
|
|
98 'option|o=s' => \@options,
|
|
|
99 'mode|m=s' => \$mode,
|
|
|
100 # misc options
|
|
|
101 'nouserrc' => sub { $rcfile->setoption('nouserrc', 1) },
|
|
|
102 'rcfile|r=s' => sub { $rcfile->setoption(@_) },
|
|
|
103 ) or usage();
|
|
|
104
|
|
|
105 $rcfile->load;
|
|
|
106
|
|
|
107 my $savestate = undef;
|
|
|
108 my $current_file = undef;
|
|
|
109 if (@ARGV) {
|
|
|
110 @ARGV == 1 or usage();
|
|
|
111 my ($msg, $reload) = load_state($ARGV[0]);
|
|
|
112 print $msg;
|
|
|
113 }
|
|
|
114
|
|
|
115 my $base = undef;
|
|
|
116 my $objects_found = find_objects();
|
|
|
117 set_defaults();
|
|
|
118
|
|
|
119 my $progname = $0;
|
|
|
120 $progname =~ s#^.*/##;
|
|
|
121
|
|
|
122 my @about_text = (
|
|
|
123 "About $progname",
|
|
|
124 '',
|
|
|
125 "Distributed with CLC-INTERCAL $VERSION",
|
|
|
126 );
|
|
|
127
|
|
|
128 my @copyright = split(/\n/, <<EOC);
|
|
|
129 Copyright (c) 2006-2008 Claudio Calvelli <intercal\@sdf.lonestar.org>
|
|
|
130 (Please include the word INTERLEAVING in the subject when emailing that
|
|
|
131 address, or the email may be ignored)
|
|
|
132
|
|
|
133 In addition to the above, permission is hereby granted to use, misuse,
|
|
|
134 modify, distribute, break, fix again, etcetera CLC-INTERCAL-$VERSION
|
|
|
135 provided that the following conditions are met:
|
|
|
136
|
|
|
137 1. Redistributions of source code must retain the above copyright
|
|
|
138 notice, this list of conditions and the following disclaimer.
|
|
|
139 2. Redistributions in binary form must reproduce the above copyright
|
|
|
140 notice, this list of conditions and the following disclaimer in the
|
|
|
141 documentation and/or other materials provided with the distribution.
|
|
|
142 3. Neither the name of the Author nor the names of its contributors
|
|
|
143 may be used to endorse or promote products derived from this software
|
|
|
144 without specific prior written permission.
|
|
|
145
|
|
|
146 THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
|
|
|
147 ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
|
|
148 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
|
|
149 ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
|
|
|
150 FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|
|
151 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
|
|
152 OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
|
|
153 HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
|
|
154 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
|
|
155 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
|
|
156 SUCH DAMAGE.
|
|
|
157 EOC
|
|
|
158
|
|
|
159 my @for = ("Help for $progname");
|
|
|
160
|
|
|
161 my @help_text = split(/\n/, <<'EOH');
|
|
|
162 For information about CLC-INTERCAL, please RTFM.
|
|
|
163
|
|
|
164 For information about the calculator, please press
|
|
|
165 keys at random until you figure out what they do.
|
|
|
166
|
|
|
167 For any other queries, please ask them somewhere else.
|
|
|
168
|
|
|
169 We hope this information helped. Thank you for contacting us.
|
|
|
170 EOH
|
|
|
171
|
|
|
172 my $server = Language::INTERCAL::Server->new();
|
|
|
173 my $ui = Language::INTERCAL::Interface->new($server,
|
|
|
174 $user_interface,
|
|
|
175 $rcfile->getitem('SPEAK'));
|
|
|
176 my $about_object = undef;
|
|
|
177 my $help_object = undef;
|
|
|
178 my $trace_object = undef;
|
|
|
179 my $history_object = undef;
|
|
|
180
|
|
|
181 # End of common initialisations - now run the main loop
|
|
|
182 my $running = 1;
|
|
|
183 my %calculator;
|
|
|
184 _init_calculator();
|
|
|
185 my $calcptr = \%calculator;
|
|
|
186 my $give_up = 0;
|
|
|
187 my $reserved = 0;
|
|
|
188 my $memories = undef;
|
|
|
189 my $main_window = undef;
|
|
|
190 while ($running) {
|
|
|
191 create_calculator();
|
|
|
192 if (! $ui->has_window) {
|
|
|
193 run_linemode();
|
|
|
194 } else {
|
|
|
195 run_windowmode();
|
|
|
196 }
|
|
|
197 $calculator{object} && ! defined $savestate
|
|
|
198 and $savestate = $calculator{object}->get_state();
|
|
|
199 }
|
|
|
200 exit 0;
|
|
|
201
|
|
|
202 sub _init_calculator {
|
|
|
203 my $read_data = '';
|
|
|
204 my $read_fh = Language::INTERCAL::GenericIO->new('STRING', 'r',
|
|
|
205 \$read_data);
|
|
|
206 $calculator{read_data} = \$read_data;
|
|
|
207 $calculator{read_fh} = $read_fh;
|
|
|
208 my $write_data = '';
|
|
|
209 my $write_object = bless \$write_data, 'WOBJ';
|
|
|
210 my $write_fh = Language::INTERCAL::GenericIO->new('OBJECT', 'w',
|
|
|
211 $write_object);
|
|
|
212 $calculator{write_fh} = $write_fh;
|
|
|
213 my $trace_object = bless ['', 0], 'TOBJ';
|
|
|
214 my $trace_fh = Language::INTERCAL::GenericIO->new('OBJECT', 'r',
|
|
|
215 $trace_object);
|
|
|
216 $calculator{trace_object} = $trace_object;
|
|
|
217 $calculator{trace_fh} = $trace_fh;
|
|
|
218 $calculator{memory} = [];
|
|
|
219 }
|
|
|
220
|
|
|
221 sub run_linemode {
|
|
|
222 $| = 1;
|
|
|
223 $ui->complete(\&_complete);
|
|
|
224 my $stdread = $ui->stdread;
|
|
|
225 my $prompt = $ui->is_interactive || $ui->is_terminal ? 'INTERCALC> ' : '';
|
|
|
226 &{$calculator{finish}}(0) if exists $calculator{finish};
|
|
|
227 $calculator{running} = 1;
|
|
|
228 while ($calculator{running}) {
|
|
|
229 if (exists $calculator{is_wimp} && $calculator{is_wimp}) {
|
|
|
230 my $msg = make_wimp();
|
|
|
231 my $len = 0;
|
|
|
232 for my $l (@$msg) {
|
|
|
233 $len = length $l if $len < length $l;
|
|
|
234 }
|
|
|
235 my $dash = '=' x $len;
|
|
|
236 $stdread->read_text("$_\n") for ('', $dash, '', @$msg, '', $dash);
|
|
|
237 $calculator{is_wimp} = 0;
|
|
|
238 }
|
|
|
239 my $line = $ui->getline($prompt);
|
|
|
240 if (defined $line && $line ne '') {
|
|
|
241 chomp $line;
|
|
|
242 next unless $line =~ /\S/;
|
|
|
243 # check for escapes
|
|
|
244 if ($line =~ s/^\`\s*//) {
|
|
|
245 my $res = eval { process_escape($line); };
|
|
|
246 $give_up = 0 if $@;
|
|
|
247 $stdread->read_text($@ ? $@ : $res);
|
|
|
248 } else {
|
|
|
249 $command = $line;
|
|
|
250 _calculate();
|
|
|
251 }
|
|
|
252 } else {
|
|
|
253 _stop_calculator();
|
|
|
254 }
|
|
|
255 }
|
|
|
256 }
|
|
|
257
|
|
|
258 sub run_windowmode {
|
|
|
259 $main_window and $ui->close($main_window);
|
|
|
260 my @menus = make_menus($ui);
|
|
|
261 my @interface = make_interface(1);
|
|
|
262 $main_window =
|
|
|
263 $ui->window('Calculator', \&_give_up, \@interface,
|
|
|
264 \@menus, \&_after_action);
|
|
|
265 if ($calculator{has_memory}) {
|
|
|
266 $ui->set_text("memory$_", '') for (1..$history, '');
|
|
|
267 }
|
|
|
268 if (@history) {
|
|
|
269 my $hp = 0;
|
|
|
270 my $cmd = 0;
|
|
|
271 for my $hl (@history) {
|
|
|
272 last if $cmd && $hp > $history;
|
|
|
273 my ($type, $line) = @$hl;
|
|
|
274 if ($type eq 'c' && ! $cmd) {
|
|
|
275 $cmd = 1;
|
|
|
276 $ui->set_text('command', $line);
|
|
|
277 }
|
|
|
278 if ($type eq 'r' && $hp <= $history) {
|
|
|
279 my $index = $hp || '';
|
|
|
280 if ($calculator{has_memory}) {
|
|
|
281 my $m = '';
|
|
|
282 $m = $1 if $line =~ s/^(\S+)\s//;
|
|
|
283 $ui->set_text("memory$index", $m);
|
|
|
284 }
|
|
|
285 $ui->set_text("display$index", $line);
|
|
|
286 $hp++;
|
|
|
287 }
|
|
|
288 }
|
|
|
289 }
|
|
|
290 $ui->start();
|
|
|
291 &{$calculator{finish}}(1) if exists $calculator{finish};
|
|
|
292 _clear_status();
|
|
|
293 _enable_keys();
|
|
|
294 _tick_menus();
|
|
|
295 if (exists $calculator{is_wimp} && $calculator{is_wimp}) {
|
|
|
296 my $wimp = undef;
|
|
|
297 _popup(\$wimp, make_wimp(), [], 'WIMP', 0);
|
|
|
298 $calculator{is_wimp} = 0;
|
|
|
299 }
|
|
|
300 $ui->run;
|
|
|
301 }
|
|
|
302
|
|
|
303 sub create_calculator {
|
|
|
304 if ($mode =~ /^oic(\d+)?$/i) {
|
|
|
305 if ($1) {
|
|
|
306 $memories = $1;
|
|
|
307 } elsif (! $memories) {
|
|
|
308 $memories = 100;
|
|
|
309 }
|
|
|
310 my $digits = length($memories - 1);
|
|
|
311 bless $calcptr, 'OIC';
|
|
|
312 $calculator{nmems} = $memories;
|
|
|
313 if (@{$calculator{memory}} < $memories) {
|
|
|
314 push @{$calculator{memory}},
|
|
|
315 (0) x ($memories - @{$calculator{memory}});
|
|
|
316 }
|
|
|
317 $calculator{digits} = $digits;
|
|
|
318 $calculator{format} = "m%0${digits}d";
|
|
|
319 $calculator{regex} = qr/^m(\d{1,$digits})/i;
|
|
|
320 $calculator{has_memory} = 1;
|
|
|
321 $calculator{mode} = 'oic';
|
|
|
322 $calculator{display_size} = 40;
|
|
|
323 delete $calculator{finish};
|
|
|
324 } else {
|
|
|
325 $mode =~ /^(?:full|expr)$/i or die "Invalid mode $mode\n";
|
|
|
326 $mode = lc($mode);
|
|
|
327 bless $calcptr, 'INC';
|
|
|
328 $calculator{has_memory} = 0;
|
|
|
329 $calculator{mode} = $mode;
|
|
|
330 $calculator{display_size} = 48;
|
|
|
331 $calculator{finish} = \&_finish,
|
|
|
332 $calculator{cache} = {};
|
|
|
333 }
|
|
|
334 }
|
|
|
335
|
|
|
336 sub load_state {
|
|
|
337 my ($file) = @_;
|
|
|
338 my ($data, $m, $l, $b, @h, @o);
|
|
|
339 eval {
|
|
|
340 open(STATE, '<', $file) or die "$file: $!\n";
|
|
|
341 while (1) {
|
|
|
342 my $line = <STATE>;
|
|
|
343 defined $line or die "Invalid object: no magic\n";
|
|
|
344 last if $line =~ /__INTERCALC__STATE__/;
|
|
|
345 }
|
|
|
346 while (<STATE>) {
|
|
|
347 chomp;
|
|
|
348 /DATA/ and last;
|
|
|
349 /MODE\s+(.*)$/ and $m = $1;
|
|
|
350 /LANG\s+(.*)$/ and $l = $1;
|
|
|
351 /BASE\s+(.*)$/ and $b = $1;
|
|
|
352 /OPTS\s+(.*)$/ and push @o, $1;
|
|
|
353 /HIST\s+(\S+)\s+(.*)$/ and push @h, [$1, $2];
|
|
|
354 }
|
|
|
355 local $/ = undef;
|
|
|
356 $data = <STATE>;
|
|
|
357 close STATE;
|
|
|
358 $data eq '' && lc($m) ne 'oic'
|
|
|
359 and die "Invalid object: seems to be truncated\n";
|
|
|
360 };
|
|
|
361 return ($@, 0) if $@;
|
|
|
362 $savestate = $data;
|
|
|
363 $mode = $m;
|
|
|
364 $language = $l;
|
|
|
365 @options = @o;
|
|
|
366 $base = $b;
|
|
|
367 delete $calculator{need_reload};
|
|
|
368 $current_file = $file;
|
|
|
369 @history = @h;
|
|
|
370 $history_object and _history_trace('', 0, 1);
|
|
|
371 $trace_object and _history_trace('', 1, 1);
|
|
|
372 $file =~ s/^.*\///;
|
|
|
373 ("Loaded state from $file\n", 1);
|
|
|
374 }
|
|
|
375
|
|
|
376 sub save_state {
|
|
|
377 my ($file, $force) = @_;
|
|
|
378 eval {
|
|
|
379 my $fm = $force ? O_TRUNC : O_EXCL;
|
|
|
380 my $fh = IO::File->new($file, O_WRONLY | O_CREAT | $fm, 0777)
|
|
|
381 or die "$file: $!\n";
|
|
|
382 print $fh $Config{sharpbang}, ' ', $Config{sh}, "\n" or die "$file: $!\n"
|
|
|
383 if $Config{sharpbang};
|
|
|
384 my $p = $0;
|
|
|
385 $p =~ s/^.*blib\/script/$Config{installscript}/;
|
|
|
386 $p =~ s/'/\\'/g;
|
|
|
387 print $fh <<EOF or die "$file: $!\n";
|
|
|
388 # Generated by intercalc, part of CLC-INTERCAL $VERSION
|
|
|
389 # Execute this program to restart the calculator
|
|
|
390 # Do not attempt to edit if you value your sanity
|
|
|
391
|
|
|
392 # Note: this program runs under $Config{sh} and then calls the real calculator
|
|
|
393 # executable - this is because some system can't use an interpreted program as
|
|
|
394 # an interpreter; you can, of course, just run "intercalc FILENAME"
|
|
|
395
|
|
|
396 exec '$^X' -w '$p' \$0
|
|
|
397
|
|
|
398 __END__
|
|
|
399 __INTERCALC__STATE__
|
|
|
400 MODE $mode
|
|
|
401 EOF
|
|
|
402 if ($calculator{loaded}) {
|
|
|
403 print $fh "BASE $calculator{loaded}{BASE}\n" or die "$file: $!\n";
|
|
|
404 print $fh "LANG $calculator{loaded}{LANGUAGE}\n" or die "$file: $!\n";
|
|
|
405 print $fh "OPTS $_\n" for keys %{$calculator{loaded}{OPTION}};
|
|
|
406 } else {
|
|
|
407 print $fh "LANG $language\n" or die "$file: $!\n";
|
|
|
408 print $fh "BASE $base\n" or die "$file: $!\n";
|
|
|
409 print $fh "OPTS $_\n" or die "$file: $!\n" for @options;
|
|
|
410 }
|
|
|
411 print $fh "HIST $_->[0] $_->[1]\n" or die "$file: $!\n" for @history;
|
|
|
412 print $fh "DATA\n" or die "$file: $!\n";
|
|
|
413 if ($calculator{object}) {
|
|
|
414 print $fh $calculator{object}->get_state or die "$file: $!\n";
|
|
|
415 }
|
|
|
416 close $fh;
|
|
|
417 };
|
|
|
418 return $@ if $@;
|
|
|
419 $current_file = $file;
|
|
|
420 $file =~ s/^.*\///;
|
|
|
421 "State saved to $file\n";
|
|
|
422 }
|
|
|
423
|
|
|
424 sub set_defaults {
|
|
|
425 my %prog_options = $rcfile->program_options('INTERCALC');
|
|
|
426
|
|
|
427 if (! defined $language) {
|
|
|
428 # see if they have a default language - and use any default options
|
|
|
429 # specified with it if they don't have any on the command line
|
|
|
430 if (exists $prog_options{LANGUAGE}) {
|
|
|
431 @options = grep { ! /^\?/ } @{$prog_options{LANGUAGE}[1]{''}}
|
|
|
432 if @options == 0;
|
|
|
433 $language = $prog_options{LANGUAGE}[0];
|
|
|
434 } else {
|
|
|
435 $language = 'sick';
|
|
|
436 }
|
|
|
437 }
|
|
|
438
|
|
|
439 if (! defined $mode) {
|
|
|
440 # see if they have a default mode
|
|
|
441 if (exists $prog_options{MODE}) {
|
|
|
442 $mode = $prog_options{MODE}[0];
|
|
|
443 } else {
|
|
|
444 $mode = 'full';
|
|
|
445 }
|
|
|
446 }
|
|
|
447
|
|
|
448 my %base = map { ($_ => 1) } @{$objects_found->{BASE}};
|
|
|
449 my @base = grep { exists $base{$_} } @options;
|
|
|
450 if (@base) {
|
|
|
451 $base = pop @base;
|
|
|
452 @options = grep { ! exists $base{$_} } @options;
|
|
|
453 } else {
|
|
|
454 ($base) = sort { $a <=> $b } @{$objects_found->{BASE}};
|
|
|
455 }
|
|
|
456 }
|
|
|
457
|
|
|
458 sub make_wimp {
|
|
|
459 my $ugly = 69 + int(rand 65467);
|
|
|
460 my $beautiful = roman($ugly, roman_type('CLC'));
|
|
|
461 [split(/\n/, <<EOH)];
|
|
|
462 You have requested the 'wimp' compiler option. This means that
|
|
|
463 the display output will use those ugly digits where you could
|
|
|
464 have some beautiful Roman numerals instead.
|
|
|
465
|
|
|
466 Compare the ugly $ugly with the beautiful $beautiful.
|
|
|
467
|
|
|
468 It also means that you are a WIMP WIMP WIMP WIMP.
|
|
|
469
|
|
|
470 As a penance, write "I AM A WIMP" M (sorry, 1000) times.
|
|
|
471 EOH
|
|
|
472 }
|
|
|
473
|
|
|
474 sub make_interface {
|
|
|
475 my ($complete) = @_;
|
|
|
476 my @interface = ();
|
|
|
477 $complete and push @interface, (
|
|
|
478 'vstack', border => 2, data =>
|
|
|
479 # title
|
|
|
480 ['hstack', data =>
|
|
|
481 ['text', value => "CLC-INTERCAL $VERSION", align => 'c'],
|
|
|
482 ],
|
|
|
483 # history and display
|
|
|
484 ['vstack', data =>
|
|
|
485 (map {
|
|
|
486 ['hstack', data =>
|
|
|
487 ($calculator{has_memory}
|
|
|
488 ? ['text', value => '', size => 1 + $calculator{digits},
|
|
|
489 align => 'l', name => "memory$_"]
|
|
|
490 : ()),
|
|
|
491 ['text', value => ' ' x $calculator{display_size},
|
|
|
492 align => 'r', name => "display$_"],
|
|
|
493 ],
|
|
|
494 } (reverse (1..$history)), ''),
|
|
|
495 ],
|
|
|
496 );
|
|
|
497 if ($calculator{mode} eq 'oic') {
|
|
|
498 $complete and push @interface, (
|
|
|
499 # command
|
|
|
500 ['hstack', data =>
|
|
|
501 ['text', value => '', align => 'l', size => 32, name => 'command'],
|
|
|
502 ],
|
|
|
503 );
|
|
|
504 push @interface, (
|
|
|
505 # keyboard
|
|
|
506 ['table', columns => 4, border => 2, data =>
|
|
|
507 # keyboard - row 1
|
|
|
508 ['key', name => 'Give Up', key => [qw(g G)], action => \&_give_up],
|
|
|
509 'l',
|
|
|
510 ['key', name => 'About', key => [qw(a A)], action => \&_about],
|
|
|
511 'l',
|
|
|
512 # keyboard - row 2
|
|
|
513 ['key', name => '7', key => '7', action => \&_addkey],
|
|
|
514 ['key', name => '8', key => '8', action => \&_addkey],
|
|
|
515 ['key', name => '9', key => '9', action => \&_addkey],
|
|
|
516 ['key', name => '?', key => [qw(? h H)], action => \&_help],
|
|
|
517 # keyboard - row 3
|
|
|
518 ['key', name => '4', key => '4', action => \&_addkey],
|
|
|
519 ['key', name => '5', key => '5', action => \&_addkey],
|
|
|
520 ['key', name => '6', key => '6', action => \&_addkey],
|
|
|
521 ['key', name => '<-', key => ["\cH", 'Left', 'BackSpace'], action => \&_delkey],
|
|
|
522 # keyboard - row 4
|
|
|
523 ['key', name => '1', key => '1', action => \&_addkey],
|
|
|
524 ['key', name => '2', key => '2', action => \&_addkey],
|
|
|
525 ['key', name => '3', key => '3', action => \&_addkey],
|
|
|
526 ['key', name => 'C', key => [qw(c C)], action => \&_clear],
|
|
|
527 # keyboard - row 5
|
|
|
528 ['key', name => '.', key => '.', action => \&_addkey],
|
|
|
529 ['key', name => '0', key => '0', action => \&_addkey],
|
|
|
530 ['key', name => '-', key => '-', action => \&_addkey],
|
|
|
531 ['key', name => 'M', key => [qw(m M)], action => \&_addkey],
|
|
|
532 ],
|
|
|
533 );
|
|
|
534 } elsif ($calculator{mode} eq 'expr') {
|
|
|
535 $complete and push @interface, (
|
|
|
536 # command
|
|
|
537 ['hstack', data =>
|
|
|
538 ['text', value => '', align => 'l', size => 48, name => 'command'],
|
|
|
539 ],
|
|
|
540 );
|
|
|
541 push @interface, (
|
|
|
542 # keyboard
|
|
|
543 ['table', border => 2, columns => 7, data =>
|
|
|
544 (map {
|
|
|
545 ['key',
|
|
|
546 name => $_,
|
|
|
547 key => /[a-z]/i ? [lc($_), uc($_)] : $_,
|
|
|
548 action => \&_addkey]
|
|
|
549 } (
|
|
|
550 qw(. < - S U B Y), # row 1
|
|
|
551 qw(: / 7 8 9 ' ¢), # row 2
|
|
|
552 ',', qw(\ 4 5 6 " &), # row 3
|
|
|
553 qw(; $ 1 2 3 ! V), # row 4
|
|
|
554 qw(@ ~ * 0), '#', qw(+ ¥), # row 5
|
|
|
555 )),
|
|
|
556 # row 6
|
|
|
557 ['key', name => 'Do It', key => ["\cJ", "\cM", qw(Enter Return Linefeed d D)], action => \&_calculate],
|
|
|
558 'l',
|
|
|
559 ['key', name => 'Give Up', key => [qw(g G)], action => \&_give_up],
|
|
|
560 'l',
|
|
|
561 'l',
|
|
|
562 ['key', name => '^', key => '^', action => \&_addkey],
|
|
|
563 ['key', name => '?', key => '?', action => \&_addkey],
|
|
|
564 # row 7
|
|
|
565 ['key', name => 'Clear', key => [qw(c C)], action => \&_clear],
|
|
|
566 'l',
|
|
|
567 ['key', name => 'backspace', key => ["\cH", 'Left', 'BackSpace'], action => \&_delkey],
|
|
|
568 'l',
|
|
|
569 'l',
|
|
|
570 ['key', name => '%', key => '%', action => \&_addkey],
|
|
|
571 ['key', name => '|', key => '|', action => \&_addkey],
|
|
|
572 # row 8
|
|
|
573 ['key', name => 'Help', key => [qw(h H)], action => \&_help],
|
|
|
574 'l',
|
|
|
575 ['key', name => 'About', key => [qw(a A)], action => \&_about],
|
|
|
576 'l',
|
|
|
577 'l',
|
|
|
578 ['key', name => 'space', key => ' ', action => \&_addkey],
|
|
|
579 'l',
|
|
|
580 ],
|
|
|
581 );
|
|
|
582 } else {
|
|
|
583 $complete and push @interface, (
|
|
|
584 # command
|
|
|
585 ['hstack', data =>
|
|
|
586 ['text', value => '', align => 'l', size => 49, name => 'command'],
|
|
|
587 ],
|
|
|
588 );
|
|
|
589 push @interface, (
|
|
|
590 # keyboard
|
|
|
591 ['table', border => 2, columns => 8, data =>
|
|
|
592 (map {
|
|
|
593 ['key',
|
|
|
594 name => $_,
|
|
|
595 key => /[a-z]/i ? [lc($_), uc($_)] : $_,
|
|
|
596 action => \&_addkey]
|
|
|
597 } (
|
|
|
598 qw(. 0 1 2 3 4), '#', qw(<),
|
|
|
599 qw(: 5 6 7 8 9 + -),
|
|
|
600 ',', qw(A B C D E ' "),
|
|
|
601 qw(; F G H I J), '(', ')',
|
|
|
602 qw(@ K L M N O [ ]),
|
|
|
603 qw(% P Q R S T ! *),
|
|
|
604 qw(^ U V W X Y & |),
|
|
|
605 qw($ Z / \ ~ ¢ ¥ ?),
|
|
|
606 )),
|
|
|
607 ['key', name => 'F1: Help', key => 'F1', action => \&_help],
|
|
|
608 'l',
|
|
|
609 ['key', name => 'space', key => ' ', action => \&_addkey],
|
|
|
610 'l',
|
|
|
611 ['key', name => 'backspace', key => ["\cH", 'Left', 'BackSpace'], action => \&_delkey],
|
|
|
612 'l',
|
|
|
613 ['key', name => 'F2: About', key => 'F2', action => \&_about],
|
|
|
614 'l',
|
|
|
615 ['key', name => 'F3: Give Up', key => 'F3', action => \&_give_up],
|
|
|
616 'l',
|
|
|
617 ['key', name => 'F4: Clear', key => 'F4', action => \&_clear],
|
|
|
618 'l',
|
|
|
619 ['key', name => 'F5: Do It', key => ["\cJ", "\cM", qw(Enter Return Linefeed F5)], action => \&_calculate],
|
|
|
620 'l',
|
|
|
621 ['key', name => 'F6: Res\'d', key => 'F6', action => \&_reserved],
|
|
|
622 'l',
|
|
|
623 ],
|
|
|
624 );
|
|
|
625 }
|
|
|
626 @interface;
|
|
|
627 }
|
|
|
628
|
|
|
629 sub find_objects {
|
|
|
630 my %of = ();
|
|
|
631 my $code = sub {
|
|
|
632 my ($name, $file, $type, $object) = @_;
|
|
|
633 exists $object_types{uc($type)} or return;
|
|
|
634 my $ot = $object_types{uc($type)};
|
|
|
635 defined $ot or return;
|
|
|
636 $of{$ot}{$name} = 1;
|
|
|
637 };
|
|
|
638 $compiler->all_objects($code, 1);
|
|
|
639 my %ol = map { ($_ => [sort keys %{$of{$_}}]) } keys %of;
|
|
|
640 $ol{MODE} = [qw(Expr Full OIC)];
|
|
|
641 return \%ol;
|
|
|
642 }
|
|
|
643
|
|
|
644 sub process_escape {
|
|
|
645 my ($line) = @_;
|
|
|
646 $line =~ s/^(.)\s*// or die "Invalid escape\n";
|
|
|
647 my $esc = lc($1);
|
|
|
648 exists $escape_defs{$esc} or die "Invalid escape `$esc\n";
|
|
|
649 $line =~ s/\s+$//;
|
|
|
650 my ($action, $list, $term, $names) = @{$escape_defs{$esc}};
|
|
|
651 if ($line ne '' && ! defined $list) {
|
|
|
652 die "Escape `$esc does not take arguments\n";
|
|
|
653 }
|
|
|
654 my $menu = $names;
|
|
|
655 my $multi = 0;
|
|
|
656 if ($list) {
|
|
|
657 my $_a;
|
|
|
658 ($menu, $_a, $multi) = @{$menu_defs{$list}};
|
|
|
659 }
|
|
|
660 if ($line eq '' && defined $list) {
|
|
|
661 $list eq '' and die "Escape `$esc requires an argument\n";
|
|
|
662 if ($list) {
|
|
|
663 my $loaded = $calculator{need_reload}
|
|
|
664 || $calculator{loaded}
|
|
|
665 || {};
|
|
|
666 my @l = map {
|
|
|
667 my $star =
|
|
|
668 ($multi ? (exists $loaded->{$list}{$_})
|
|
|
669 : ($_ eq ($loaded->{$list} || '')))
|
|
|
670 ? '*'
|
|
|
671 : '';
|
|
|
672 $star . $_;
|
|
|
673 } @{$objects_found->{$list}};
|
|
|
674 return "Available $names: " . join(', ', @l) . "\n";
|
|
|
675 }
|
|
|
676 }
|
|
|
677 if ($list) {
|
|
|
678 my $n = lc($list);
|
|
|
679 my $data = $line;
|
|
|
680 if (defined $term) {
|
|
|
681 my $i = index($line, $term);
|
|
|
682 $data = substr($line, 0, $i) if $i >= 0;
|
|
|
683 }
|
|
|
684 grep { $data eq $_ } @{$objects_found->{$list}}
|
|
|
685 or return "Invalid $n: $data\n";
|
|
|
686 }
|
|
|
687 $action->($ui, $menu, $line);
|
|
|
688 }
|
|
|
689
|
|
|
690 sub make_menus {
|
|
|
691 my ($ui) = @_;
|
|
|
692 my @menus = (
|
|
|
693 [ File =>
|
|
|
694 [ 'Write In', action => \&_write, enabled => 1 ],
|
|
|
695 [ 'Read Out', action => \&_read, enabled => 0 ],
|
|
|
696 [ 'Read As', action => \&_read_as, enabled => 1 ],
|
|
|
697 [ 'Give Up', action => \&_give_up, enabled => 1 ],
|
|
|
698 ],
|
|
|
699 [ Edit =>
|
|
|
700 [ 'Backspace', action => \&_delkey, enabled => 0, ],
|
|
|
701 ($ui->can_paste
|
|
|
702 ? ([ 'Paste', action => \&_paste, enabled => 1, ])
|
|
|
703 : ()
|
|
|
704 ),
|
|
|
705 [ 'Save settings', action => \&_sickrc, enabled => 1 ],
|
|
|
706 ],
|
|
|
707 );
|
|
|
708 for my $key (qw(LANGUAGE BASE OPTION)) {
|
|
|
709 exists $menu_defs{$key} or next;
|
|
|
710 my ($name, $action, $multi) = @{$menu_defs{$key}};
|
|
|
711 push @menus,
|
|
|
712 [ $name =>
|
|
|
713 map {
|
|
|
714 [ $_, action => $action, enabled => 1, ticked => 0, ]
|
|
|
715 } @{$objects_found->{$key}},
|
|
|
716 ];
|
|
|
717 }
|
|
|
718 push @menus,
|
|
|
719 [ Mode =>
|
|
|
720 map {
|
|
|
721 my $ticked = lc($_) eq lc($mode);
|
|
|
722 [ $_, action => \&_change_mode, enabled => 1, ticked => $ticked ]
|
|
|
723 } @{$objects_found->{MODE}},
|
|
|
724 ],
|
|
|
725 [ Window =>
|
|
|
726 [ 'About', action => \&_about, enabled => 1 ],
|
|
|
727 [ 'Help', action => \&_help, enabled => 1 ],
|
|
|
728 [ 'History', action => \&_history_w, enabled => 1 ],
|
|
|
729 [ 'Trace', action => \&_trace_w, enabled => 1 ],
|
|
|
730 ];
|
|
|
731 @menus;
|
|
|
732 }
|
|
|
733
|
|
|
734 sub _tick_menus {
|
|
|
735 for my $key (qw(LANGUAGE BASE OPTION)) {
|
|
|
736 exists $menu_defs{$key} or next;
|
|
|
737 my $loaded = $calculator{loaded}{$key};
|
|
|
738 my ($name, $action, $multi) = @{$menu_defs{$key}};
|
|
|
739 for my $obj (@{$objects_found->{$key}}) {
|
|
|
740 my $t = $multi ? (exists $loaded->{$obj}) : ($obj eq $loaded);
|
|
|
741 $ui->tick_menu($t, $name, $obj);
|
|
|
742 }
|
|
|
743 }
|
|
|
744 for my $obj (@{$objects_found->{MODE}}) {
|
|
|
745 $ui->tick_menu(lc($mode) eq lc($obj), 'Mode', $obj);
|
|
|
746 }
|
|
|
747 }
|
|
|
748
|
|
|
749 sub _finish {
|
|
|
750 my ($haswindow) = @_;
|
|
|
751 my $status = $haswindow
|
|
|
752 ? sub { _status(shift); $ui->update() }
|
|
|
753 : sub { $ui->stdread->read_text(shift() . "\n") };
|
|
|
754 my $msg = 'Loading';
|
|
|
755 if ($calculator{object} && ! $calculator{full_restart}) {
|
|
|
756 my $loaded = $calculator{need_reload} || $calculator{loaded};
|
|
|
757 $language = $loaded->{LANGUAGE};
|
|
|
758 $base = $loaded->{BASE};
|
|
|
759 $calculator{loaded} = {
|
|
|
760 LANGUAGE => $language,
|
|
|
761 BASE => $base,
|
|
|
762 OPTION => $loaded->{OPTION},
|
|
|
763 };
|
|
|
764 delete $calculator{need_reload};
|
|
|
765 delete $calculator{full_restart};
|
|
|
766 my $obj = $calculator{object};
|
|
|
767 $calculator{s_line} =
|
|
|
768 $obj->getreg($calculator{mode} eq 'full' ? 'FS' : 'ES')->number;
|
|
|
769 return;
|
|
|
770 }
|
|
|
771 if ($calculator{need_reload}) {
|
|
|
772 $language = $calculator{need_reload}{LANGUAGE};
|
|
|
773 $base = $calculator{need_reload}{BASE};
|
|
|
774 @options = keys %{$calculator{need_reload}{OPTION}};
|
|
|
775 delete $calculator{need_reload};
|
|
|
776 delete $calculator{full_restart};
|
|
|
777 $msg = 'Reloading';
|
|
|
778 }
|
|
|
779 delete $calculator{full_restart};
|
|
|
780 $status->("$msg compiler (" . join(', ', $language, $base, @options) . ")");
|
|
|
781 my $old_object = $calculator{object};
|
|
|
782 eval {
|
|
|
783 $compiler->reset();
|
|
|
784 my $old_server = $old_object ? $old_object->theft_server : undef;
|
|
|
785 delete $calculator{object};
|
|
|
786 $calculator{loaded} = {
|
|
|
787 LANGUAGE => undef,
|
|
|
788 BASE => undef,
|
|
|
789 OPTION => {},
|
|
|
790 };
|
|
|
791 $calculator{trace_object}->enable(0);
|
|
|
792 $compiler->setoption('trace_fh', $calculator{trace_fh});
|
|
|
793 $compiler->setoption('trace', 0);
|
|
|
794 $compiler->setoption('preload_callback', [\&_preload_callback]);
|
|
|
795 $compiler->setoption('default_charset', $_)
|
|
|
796 for $rcfile->getitem('WRITE');
|
|
|
797 $compiler->setoption('default_backend', 'Run');
|
|
|
798 $compiler->clearoption('preload');
|
|
|
799 $compiler->setoption('preload', $language);
|
|
|
800 $compiler->setoption('preload', $base);
|
|
|
801 $compiler->setoption('preload', $_) for @options;
|
|
|
802 $compiler->source('null.iacc');
|
|
|
803 $compiler->server($server);
|
|
|
804 $compiler->theft_server($old_server);
|
|
|
805 $compiler->load_objects();
|
|
|
806 delete $calculator{need_reload};
|
|
|
807 my $obj = $compiler->get_object('null.iacc')
|
|
|
808 or die "Internal error: no compiler object\n";
|
|
|
809 exists $calculator{loaded}{LANGUAGE}
|
|
|
810 or die "Internal error: no compiler loaded\n";
|
|
|
811 $calculator{loaded}{BASE}
|
|
|
812 or _preload_callback($compiler, $base);
|
|
|
813 exists $calculator{loaded}{OPTION}
|
|
|
814 or $calculator{loaded}{OPTION} = {};
|
|
|
815 # we need to run null.iacc (even though it doesn't do anything)
|
|
|
816 # to initialise the interpreter
|
|
|
817 $obj->start(0)->run()->stop();
|
|
|
818 $calculator{object} = $obj;
|
|
|
819 $calculator{parser} = $obj->{object}->parser(1);
|
|
|
820 $calculator{s_space} = $obj->getreg('SS')->number;
|
|
|
821 $calculator{s_statement} = $obj->getreg('PS')->number;
|
|
|
822 $calculator{s_line} =
|
|
|
823 $obj->getreg($calculator{mode} eq 'full' ? 'FS' : 'ES')->number;
|
|
|
824 $obj->setreg('ORFH', $calculator{read_fh});
|
|
|
825 $obj->setreg('OSFH', $calculator{read_fh});
|
|
|
826 $obj->setreg('OWFH', $calculator{write_fh});
|
|
|
827 $obj->setreg('TRFH', $calculator{trace_fh});
|
|
|
828 $obj->theft_callback(\&_being_robbed);
|
|
|
829 my $rt = $obj->getreg('RT')->number;
|
|
|
830 if (! exists $roman_ok{$rt}) {
|
|
|
831 $obj->setreg('RT', 'CLC');
|
|
|
832 }
|
|
|
833 $calculator{is_wimp} = 1
|
|
|
834 if ! exists $calculator{is_wimp} && $obj->getreg('WT')->number;
|
|
|
835 $savestate and $obj->set_state($savestate, 0);
|
|
|
836 $savestate = undef;
|
|
|
837 $obj->record_grammar(1);
|
|
|
838 $calculator{trace_object}->enable(1);
|
|
|
839 $status->("Done \L$msg compiler");
|
|
|
840 };
|
|
|
841 if ($@) {
|
|
|
842 my $e = $haswindow ? _shorten($@) : $@;
|
|
|
843 $status->($e);
|
|
|
844 if ($old_object) {
|
|
|
845 $calculator{object} = $old_object;
|
|
|
846 } else {
|
|
|
847 sleep 2 if $ui->has_window;
|
|
|
848 exit 1;
|
|
|
849 }
|
|
|
850 }
|
|
|
851 }
|
|
|
852
|
|
|
853 sub _shorten {
|
|
|
854 my ($e) = @_;
|
|
|
855 # make the message as short as possible to fit in the status line
|
|
|
856 $e =~ s/\s+/ /g;
|
|
|
857 $e =~ s/^ //;
|
|
|
858 $e =~ s/[ \.]+$//;
|
|
|
859 $e =~ s/undefined subroutine &(?:main::|Language::INTERCAL::)?(\S+)/&$1?/i;
|
|
|
860 $e =~ s/called at \S*\/Language\/INTERCAL\//at /i
|
|
|
861 or $e =~ s/ at \S*\// at /i;
|
|
|
862 $e =~ s/Language::INTERCAL:://g;
|
|
|
863 $e =~ s/main:://g;
|
|
|
864 $e =~ s/via package/in/g;
|
|
|
865 $e =~ s/ line /:/g;
|
|
|
866 $e;
|
|
|
867 }
|
|
|
868
|
|
|
869 sub _preload_callback {
|
|
|
870 my ($compiler, $file, $fn, $ct) = @_;
|
|
|
871 exists $object_types{uc($ct)}
|
|
|
872 or die "Invalid object type ($ct) for intercalc\n";
|
|
|
873 my $rt = $object_types{uc($ct)};
|
|
|
874 defined $rt or return;
|
|
|
875 exists $menu_defs{$rt} or return;
|
|
|
876 my ($name, $action, $multi) = @{$menu_defs{$rt}};
|
|
|
877 if ($multi) {
|
|
|
878 $calculator{loaded}{$rt}{$file} = 1;
|
|
|
879 } else {
|
|
|
880 $calculator{loaded}{$rt} = $file;
|
|
|
881 }
|
|
|
882 }
|
|
|
883
|
|
|
884 sub _being_robbed {
|
|
|
885 my ($obj, $type, $reg) = @_;
|
|
|
886 $type = $type =~ /steal/i ? 'stolen' : 'smuggled away';
|
|
|
887 _status("Register $reg has been $type");
|
|
|
888 1;
|
|
|
889 }
|
|
|
890
|
|
|
891 sub _enable_keys {
|
|
|
892 my $enable_all = $ui->pending_events();
|
|
|
893 $ui->forall('key',
|
|
|
894 sub {
|
|
|
895 my ($ui, $key, $name, $action) = @_;
|
|
|
896 $enable_all = 1 if ! $enable_all && $ui->pending_events();
|
|
|
897 if ($action == \&_addkey) {
|
|
|
898 $name = ' ' if $name eq 'space';
|
|
|
899 $enable_all || defined $calcptr->can_add($name)
|
|
|
900 ? $ui->enable($key)
|
|
|
901 : $ui->disable($key);
|
|
|
902 return 1;
|
|
|
903 }
|
|
|
904 if ($action == \&_delkey) {
|
|
|
905 $command ne ''
|
|
|
906 ? $ui->enable($key)
|
|
|
907 : $ui->disable($key);
|
|
|
908 return 1;
|
|
|
909 }
|
|
|
910 if ($action == \&_calculate) {
|
|
|
911 $enable_all || $calcptr->can_run()
|
|
|
912 ? $ui->enable($key)
|
|
|
913 : $ui->disable($key);
|
|
|
914 return 1;
|
|
|
915 }
|
|
|
916 return 1;
|
|
|
917 });
|
|
|
918 $ui->enable_menu($enable_all || $command ne '', 'Edit', 'Backspace');
|
|
|
919 $ui->enable_menu($enable_all || defined $current_file, 'File', 'Read Out');
|
|
|
920 }
|
|
|
921
|
|
|
922 sub _paste {
|
|
|
923 $give_up = 0;
|
|
|
924 $ui->do_paste;
|
|
|
925 }
|
|
|
926
|
|
|
927 sub _popup {
|
|
|
928 my ($object, $list1, $list2, $title, $redo) = @_;
|
|
|
929 $give_up = 0;
|
|
|
930 if ($ui->has_window) {
|
|
|
931 _clear_status();
|
|
|
932 my @inner = ();
|
|
|
933 for my $i (@$list2) {
|
|
|
934 if (ref $i) {
|
|
|
935 push @inner,
|
|
|
936 ['text', value => $i->[0] . ' ', align => 'l'],
|
|
|
937 ['text', value => $i->[1] . ' ', align => 'r'],
|
|
|
938 ['text', value => $i->[2], align => 'l'];
|
|
|
939 } else {
|
|
|
940 push @inner,
|
|
|
941 ['text', value => $i, align => 'l'],
|
|
|
942 'l',
|
|
|
943 'l';
|
|
|
944 }
|
|
|
945 }
|
|
|
946 my $inner = [ 'table', columns => 3, alterable => 1, data => @inner];
|
|
|
947 if (! $$object) {
|
|
|
948 my $destroy = sub {
|
|
|
949 $$object = undef;
|
|
|
950 $give_up = 0;
|
|
|
951 _clear_status();
|
|
|
952 1;
|
|
|
953 };
|
|
|
954 my $close = sub {
|
|
|
955 $ui->close($$object) if $$object;
|
|
|
956 $$object = undef;
|
|
|
957 $give_up = 0;
|
|
|
958 _clear_status();
|
|
|
959 };
|
|
|
960 $$object = $ui->window($title, $destroy, [
|
|
|
961 'vstack', border => 2, data =>
|
|
|
962 ['vstack', data =>
|
|
|
963 (map { ['text', value => $_, align => 'c'] } @$list1),
|
|
|
964 (@$list1 && @$list2 ? (['text', value => '']) : ()),
|
|
|
965 $inner,
|
|
|
966 ['text', value => ''],
|
|
|
967 ['key',
|
|
|
968 name => 'OK',
|
|
|
969 key => ["\cJ", "\cM", qw(Enter Return Linefeed)],
|
|
|
970 action => $close
|
|
|
971 ],
|
|
|
972 ],
|
|
|
973 ]);
|
|
|
974 } elsif ($redo) {
|
|
|
975 $ui->alter_data($$object, $inner);
|
|
|
976 }
|
|
|
977 $ui->show($$object);
|
|
|
978 } else {
|
|
|
979 my $stdread = $ui->stdread;
|
|
|
980 $stdread->read_text("$_\n") for @$list1;
|
|
|
981 $stdread->read_text("\n") if @$list1 && @$list2;
|
|
|
982 $stdread->read_text("$_\n") for @$list2;
|
|
|
983 }
|
|
|
984 }
|
|
|
985
|
|
|
986 sub _stop_calculator {
|
|
|
987 $calculator{running} = $running = 0;
|
|
|
988 $ui->stop if $ui->has_window;
|
|
|
989 }
|
|
|
990
|
|
|
991 sub _restart_calculator {
|
|
|
992 my ($full_restart) = @_;
|
|
|
993 $calculator{running} = 0;
|
|
|
994 $calculator{full_restart} = 1 if $full_restart;
|
|
|
995 $running = 1;
|
|
|
996 $ui->stop if $ui->has_window;
|
|
|
997 }
|
|
|
998
|
|
|
999 sub _about {
|
|
|
1000 _popup(\$about_object, \@about_text, \@copyright, 'About', 0);
|
|
|
1001 '';
|
|
|
1002 }
|
|
|
1003
|
|
|
1004 sub _help {
|
|
|
1005 _popup(\$help_object, \@for, \@help_text, 'Help', 0);
|
|
|
1006 '';
|
|
|
1007 }
|
|
|
1008
|
|
|
1009 sub _reserved {
|
|
|
1010 $give_up = 0;
|
|
|
1011 $reserved++;
|
|
|
1012 $reserved == 1 and return "That key is reserved. Don't press it again";
|
|
|
1013 $reserved == 2 and return "I really mean it. Don't press that key";
|
|
|
1014 $reserved > 2 and do {
|
|
|
1015 _status("Well, you've asked for it. Didn't I tell you?");
|
|
|
1016 $ui->update();
|
|
|
1017 _stop_calculator();
|
|
|
1018 };
|
|
|
1019 '';
|
|
|
1020 }
|
|
|
1021
|
|
|
1022 sub _undocumented {
|
|
|
1023 my @interface = make_interface(0);
|
|
|
1024 my $interface = _convert(\@interface);
|
|
|
1025 "undocumented data: " . $interface . "\n";
|
|
|
1026 }
|
|
|
1027
|
|
|
1028 sub _convert {
|
|
|
1029 my ($item) = @_;
|
|
|
1030 defined $item or return "u";
|
|
|
1031 if (ref $item) {
|
|
|
1032 UNIVERSAL::isa($item, 'ARRAY')
|
|
|
1033 and return "a(" . join(' ', map { _convert($_) } @$item) . ")";
|
|
|
1034 UNIVERSAL::isa($item, 'CODE')
|
|
|
1035 and return "c";
|
|
|
1036 die "Type not understood: $item\n";
|
|
|
1037 } else {
|
|
|
1038 $item =~ s/([%\(\)\000- \177-\377])/sprintf("%%%03d", ord($1))/ge;
|
|
|
1039 return "d$item";
|
|
|
1040 }
|
|
|
1041 }
|
|
|
1042
|
|
|
1043 sub _version {
|
|
|
1044 "INTERCALC (CLC-INTERCAL $VERSION)\n";
|
|
|
1045 }
|
|
|
1046
|
|
|
1047 sub _give_up {
|
|
|
1048 if ($give_up) {
|
|
|
1049 _stop_calculator();
|
|
|
1050 return '';
|
|
|
1051 }
|
|
|
1052 $give_up = 1;
|
|
|
1053 "Do that again to really GIVE UP\n";
|
|
|
1054 }
|
|
|
1055
|
|
|
1056 sub _after_action {
|
|
|
1057 my ($ui, $res, $menu_name, $menu_entry) = @_;
|
|
|
1058 $res and _status(_shorten($res));
|
|
|
1059 }
|
|
|
1060
|
|
|
1061 sub _sickrc {
|
|
|
1062 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1063 $give_up = 0;
|
|
|
1064 my %newoptions = (
|
|
|
1065 LANGUAGE => [$language, { '' => [ $base, @options] } ],
|
|
|
1066 MODE => [$mode],
|
|
|
1067 );
|
|
|
1068 $rcfile->program_setoptions('INTERCALC', \%newoptions);
|
|
|
1069 $rcfile->save();
|
|
|
1070 return '';
|
|
|
1071 }
|
|
|
1072
|
|
|
1073 sub _read_or_readas {
|
|
|
1074 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1075 $give_up = 0;
|
|
|
1076 $menu_entry eq '' and return _read($ui, $menu_name, $menu_entry);
|
|
|
1077 return save_state($menu_entry, 0);
|
|
|
1078 }
|
|
|
1079
|
|
|
1080 sub _read {
|
|
|
1081 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1082 $give_up = 0;
|
|
|
1083 defined $current_file
|
|
|
1084 or return "Cannot read out without a file name\n";
|
|
|
1085 return save_state($current_file, 1);
|
|
|
1086 }
|
|
|
1087
|
|
|
1088 sub _read_as {
|
|
|
1089 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1090 $give_up = 0;
|
|
|
1091 my $new = $current_file || '';
|
|
|
1092 my $file = $ui->file_dialog("Read AS", $new, "Read it", "Give up");
|
|
|
1093 defined $file or return '';
|
|
|
1094 return save_state($file, 0);
|
|
|
1095 }
|
|
|
1096
|
|
|
1097 sub _write {
|
|
|
1098 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1099 $give_up = 0;
|
|
|
1100 my $file = $ui->file_dialog("Write In", undef, "Write it", "Give up");
|
|
|
1101 defined $file or return '';
|
|
|
1102 return _write_file($ui, $menu_name, $file);
|
|
|
1103 }
|
|
|
1104
|
|
|
1105 sub _write_file {
|
|
|
1106 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1107 $give_up = 0;
|
|
|
1108 my ($ret, $reload) = load_state($menu_entry);
|
|
|
1109 _restart_calculator(1) if $reload;
|
|
|
1110 $ret;
|
|
|
1111 }
|
|
|
1112
|
|
|
1113 sub _history {
|
|
|
1114 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1115 _history_trace($menu_entry, 0, 0);
|
|
|
1116 }
|
|
|
1117
|
|
|
1118 sub _history_w {
|
|
|
1119 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1120 _history_trace('', 0, 0);
|
|
|
1121 }
|
|
|
1122
|
|
|
1123 sub _trace {
|
|
|
1124 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1125 _history_trace($menu_entry, 1, 0);
|
|
|
1126 }
|
|
|
1127
|
|
|
1128 sub _trace_w {
|
|
|
1129 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1130 _history_trace('', 1, 0);
|
|
|
1131 }
|
|
|
1132
|
|
|
1133 sub _history_trace {
|
|
|
1134 my ($size, $with_trace, $redo) = @_;
|
|
|
1135 $give_up = 0;
|
|
|
1136 my $object;
|
|
|
1137 if ($ui->has_window) {
|
|
|
1138 $object = $with_trace ? \$trace_object : \$history_object;
|
|
|
1139 return if $redo && ! $$object;
|
|
|
1140 return if ! $redo && $$object;
|
|
|
1141 }
|
|
|
1142 if ($size) {
|
|
|
1143 $size =~ /^(\d+)/ or return "Invalid number $size\n";
|
|
|
1144 }
|
|
|
1145 my @lines = ();
|
|
|
1146 my $fmt = "%s%$calculator{display_size}s %s\n";
|
|
|
1147 my $read_lines = $ui->has_window
|
|
|
1148 ? sub { push @lines, @_ }
|
|
|
1149 : sub { $ui->stdread->read_text($_ . "\n") for @_ };
|
|
|
1150 my $read_mult = $ui->has_window
|
|
|
1151 ? sub { push @lines, [@_] }
|
|
|
1152 : sub { $ui->stdread->read_text(sprintf $fmt, @_) };
|
|
|
1153 $read_lines->("Command history" .
|
|
|
1154 ($with_trace ? " and trace information" : ''));
|
|
|
1155 $read_lines->("(Note that you need to enable the \"trace\" " .
|
|
|
1156 "option to see trace information)")
|
|
|
1157 if $with_trace && ! exists $calculator{loaded}{OPTION}{trace};
|
|
|
1158 my @title = @lines;
|
|
|
1159 @lines = ();
|
|
|
1160 my $calculation = '';
|
|
|
1161 my @trace = ();
|
|
|
1162 my $OK = $with_trace ? '' : 'OK';
|
|
|
1163 for my $hl (@history, ['c']) {
|
|
|
1164 my ($type, $line) = @$hl;
|
|
|
1165 if ($type eq 'c') {
|
|
|
1166 if ($size ne '') {
|
|
|
1167 $size--;
|
|
|
1168 last if $size < 0;
|
|
|
1169 }
|
|
|
1170 if ($calculation ne '' || $with_trace) {
|
|
|
1171 $read_lines->(@trace);
|
|
|
1172 @trace = ();
|
|
|
1173 next if $with_trace && ! defined $line;
|
|
|
1174 $calculation = $line if $with_trace;
|
|
|
1175 my $memory = '';
|
|
|
1176 $memory = ' ' x (1 + $calculator{digits})
|
|
|
1177 if $calculator{has_memory};
|
|
|
1178 $read_mult->($memory, $OK, $calculation);
|
|
|
1179 }
|
|
|
1180 $calculation = $with_trace ? '' : $line;
|
|
|
1181 } elsif ($type eq 'r') {
|
|
|
1182 my $memory = '';
|
|
|
1183 $memory = $1 if $calculator{has_memory} && $line =~ s/^(\S+)\s//;
|
|
|
1184 $read_mult->($memory, $line, $calculation);
|
|
|
1185 $calculation = '';
|
|
|
1186 } elsif ($type eq 't' && $with_trace) {
|
|
|
1187 unshift @trace, $line;
|
|
|
1188 }
|
|
|
1189 }
|
|
|
1190 if ($ui->has_window) {
|
|
|
1191 _popup($object, \@title, \@lines,
|
|
|
1192 $with_trace ? 'Trace' : 'History', $redo);
|
|
|
1193 }
|
|
|
1194 '';
|
|
|
1195 }
|
|
|
1196
|
|
|
1197 #sub _redo_history {
|
|
|
1198 # my ($object, $with_trace) = @_;
|
|
|
1199 # $ui->start_alter($object);
|
|
|
1200 # my $calculation = '';
|
|
|
1201 # my @trace = ();
|
|
|
1202 # my $OK = $with_trace ? '' : 'OK';
|
|
|
1203 # for my $hl (@history, ['c']) {
|
|
|
1204 # my ($type, $line) = @$hl;
|
|
|
1205 # if ($type eq 'c') {
|
|
|
1206 # if ($calculation ne '' || $with_trace) {
|
|
|
1207 # $ui->augment($object, 0, @trace) if @trace;
|
|
|
1208 # @trace = ();
|
|
|
1209 # next if $with_trace && ! defined $line;
|
|
|
1210 # $calculation = $line if $with_trace;
|
|
|
1211 # my $memory = '';
|
|
|
1212 # $memory = ' ' x (1 + $calculator{digits})
|
|
|
1213 # if $calculator{has_memory};
|
|
|
1214 # $ui->augment($object, 1, $memory, $OK, $calculation);
|
|
|
1215 # }
|
|
|
1216 # $calculation = $with_trace ? '' : $line;
|
|
|
1217 # } elsif ($type eq 'r') {
|
|
|
1218 # my $memory = '';
|
|
|
1219 # $memory = $1 if $calculator{has_memory} && $line =~ s/^(\S+)\s//;
|
|
|
1220 # $ui->augment($object, 1, $memory, $line, $calculation);
|
|
|
1221 # $calculation = '';
|
|
|
1222 # } elsif ($type eq 't' && $with_trace) {
|
|
|
1223 # unshift @trace, $line;
|
|
|
1224 # }
|
|
|
1225 # }
|
|
|
1226 # $ui->end_alter($object);
|
|
|
1227 #}
|
|
|
1228
|
|
|
1229 sub _change_mode {
|
|
|
1230 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1231 $give_up = 0;
|
|
|
1232 if ($menu_entry eq '') {
|
|
|
1233 die "Internal error: no menu entry\n" if $ui->has_window;
|
|
|
1234 my @mode = map { lc($mode) eq lc($_) ? "*$_" : $_ } qw(OIC Expr Full);
|
|
|
1235 return "Available modes: " . join(', ', @mode) . "\n";
|
|
|
1236 }
|
|
|
1237 return '' if $mode eq lc($menu_entry);
|
|
|
1238 return "Invalid mode: $menu_entry\n"
|
|
|
1239 if $menu_entry !~ /^(?:oic\d*|expr|full)$/i;
|
|
|
1240 if ($ui->has_window) {
|
|
|
1241 $ui->forall('menu', $menu_name, sub {
|
|
|
1242 my ($_ui, $name, $entry, $menu, $item) = @_;
|
|
|
1243 $_ui->tick_menu($menu_entry eq $entry, $name, $entry);
|
|
|
1244 1;
|
|
|
1245 });
|
|
|
1246 }
|
|
|
1247 $mode = lc($menu_entry);
|
|
|
1248 _restart_calculator(0);
|
|
|
1249 "Mode changed to $mode\n";
|
|
|
1250 }
|
|
|
1251
|
|
|
1252 sub _change_base {
|
|
|
1253 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1254 $give_up = 0;
|
|
|
1255 if ($ui->has_window) {
|
|
|
1256 $ui->forall('menu', $menu_name, sub {
|
|
|
1257 my ($_ui, $name, $entry, $menu, $item) = @_;
|
|
|
1258 $_ui->tick_menu($menu_entry eq $entry, $name, $entry);
|
|
|
1259 1;
|
|
|
1260 });
|
|
|
1261 }
|
|
|
1262 if ($menu_entry ne $calculator{loaded}{BASE}) {
|
|
|
1263 $calculator{loaded}{BASE} = $menu_entry;
|
|
|
1264 $calculator{object}->setreg('%BA', $menu_entry);
|
|
|
1265 }
|
|
|
1266 "Base changed to $menu_entry\n";
|
|
|
1267 }
|
|
|
1268
|
|
|
1269 sub _change_language {
|
|
|
1270 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1271 $give_up = 0;
|
|
|
1272 my ($newlang, @opts, $change_opts);
|
|
|
1273 if ($menu_entry =~ s/^(\w+)\s*\+\s*//) {
|
|
|
1274 $newlang = $1;
|
|
|
1275 if ($menu_entry =~ /\S/) {
|
|
|
1276 @opts = split(/\s+/, $menu_entry);
|
|
|
1277 } else {
|
|
|
1278 @opts = ();
|
|
|
1279 }
|
|
|
1280 my $loaded = $calculator{need_reload} || $calculator{loaded};
|
|
|
1281 for my $o (@opts) {
|
|
|
1282 next if exists $loaded->{OPTION}{$o};
|
|
|
1283 $change_opts = 1;
|
|
|
1284 last;
|
|
|
1285 }
|
|
|
1286 if (! $change_opts) {
|
|
|
1287 my %o = map { ($_ => 1) } @opts;
|
|
|
1288 for my $o (keys %{$loaded->{OPTION}}) {
|
|
|
1289 next if exists $o{$o};
|
|
|
1290 $change_opts = 1;
|
|
|
1291 last;
|
|
|
1292 }
|
|
|
1293 }
|
|
|
1294 } else {
|
|
|
1295 $newlang = $menu_entry;
|
|
|
1296 @opts = ();
|
|
|
1297 $change_opts = 0;
|
|
|
1298 }
|
|
|
1299 if ($ui->has_window) {
|
|
|
1300 $ui->forall('menu', $menu_name, sub {
|
|
|
1301 my ($_ui, $name, $entry, $menu, $item) = @_;
|
|
|
1302 $_ui->tick_menu($newlang eq $entry, $name, $entry);
|
|
|
1303 1;
|
|
|
1304 });
|
|
|
1305 }
|
|
|
1306 my $opts = '';
|
|
|
1307 if ($change_opts) {
|
|
|
1308 $calculator{full_restart} = 1;
|
|
|
1309 _need_reload('LANGUAGE', $newlang, 'OPTION', @opts);
|
|
|
1310 $opts = ' (' . join(', ', @opts) . ')';
|
|
|
1311 } elsif ($newlang ne $calculator{loaded}{LANGUAGE}) {
|
|
|
1312 $calculator{full_restart} = 1;
|
|
|
1313 _need_reload('LANGUAGE', $newlang);
|
|
|
1314 }
|
|
|
1315 "Language changed to $newlang$opts\n";
|
|
|
1316 }
|
|
|
1317
|
|
|
1318 sub _toggle_option {
|
|
|
1319 my ($ui, $menu_name, $menu_entry) = @_;
|
|
|
1320 $give_up = 0;
|
|
|
1321 $calculator{full_restart} = 1;
|
|
|
1322 _need_reload('OPTION', $menu_entry);
|
|
|
1323 if ($ui->has_window) {
|
|
|
1324 my $t = exists $calculator{need_reload}{'OPTION'}{$menu_entry};
|
|
|
1325 $ui->tick_menu($t, $menu_name, $menu_entry);
|
|
|
1326 }
|
|
|
1327 "Option $menu_entry has been " .
|
|
|
1328 (exists $calculator{need_reload}{OPTION}{$menu_entry}
|
|
|
1329 ? "added"
|
|
|
1330 : "removed") .
|
|
|
1331 "\n";
|
|
|
1332 }
|
|
|
1333
|
|
|
1334 sub _need_reload {
|
|
|
1335 my ($type, $name, $othertype, @othernames) = @_;
|
|
|
1336 if (! $calculator{need_reload}) {
|
|
|
1337 my %r = ();
|
|
|
1338 for my $t (keys %{$calculator{loaded}}) {
|
|
|
1339 my $v = $calculator{loaded}{$t};
|
|
|
1340 if (ref $v) {
|
|
|
1341 my %h = ();
|
|
|
1342 $h{$_} = 1 for keys %$v;
|
|
|
1343 $r{$t} = \%h;
|
|
|
1344 } else {
|
|
|
1345 $r{$t} = $v;
|
|
|
1346 }
|
|
|
1347 }
|
|
|
1348 $calculator{need_reload} = \%r;
|
|
|
1349 }
|
|
|
1350 if (ref $calculator{need_reload}{$type}) {
|
|
|
1351 if (exists $calculator{need_reload}{$type}{$name}) {
|
|
|
1352 delete $calculator{need_reload}{$type}{$name};
|
|
|
1353 } else {
|
|
|
1354 $calculator{need_reload}{$type}{$name} = 1;
|
|
|
1355 }
|
|
|
1356 } else {
|
|
|
1357 $calculator{need_reload}{$type} = $name;
|
|
|
1358 }
|
|
|
1359 if (defined $othertype) {
|
|
|
1360 $calculator{need_reload}{$othertype} = {
|
|
|
1361 map { ($_ => 1) } @othernames,
|
|
|
1362 };
|
|
|
1363 }
|
|
|
1364 _restart_calculator(0);
|
|
|
1365 }
|
|
|
1366
|
|
|
1367 sub _clear {
|
|
|
1368 $give_up = 0;
|
|
|
1369 _clear_status();
|
|
|
1370 $command = '';
|
|
|
1371 $ui->set_text('command', '');
|
|
|
1372 _enable_keys();
|
|
|
1373 ''
|
|
|
1374 }
|
|
|
1375
|
|
|
1376 sub _addkey {
|
|
|
1377 my ($key) = @_;
|
|
|
1378 $give_up = 0;
|
|
|
1379 $key = ' ' if $key eq 'space';
|
|
|
1380 my $ok = $calcptr->can_add($key);
|
|
|
1381 if (defined $ok) {
|
|
|
1382 if (ref $ok) {
|
|
|
1383 $command .= $$ok;
|
|
|
1384 _calculate();
|
|
|
1385 return;
|
|
|
1386 } else {
|
|
|
1387 $command .= $ok;
|
|
|
1388 _enable_keys();
|
|
|
1389 }
|
|
|
1390 }
|
|
|
1391 _clear_status();
|
|
|
1392 ''
|
|
|
1393 }
|
|
|
1394
|
|
|
1395 sub _calculate {
|
|
|
1396 $give_up = 0;
|
|
|
1397 my $c = $command;
|
|
|
1398 my $i = $ui->has_window;
|
|
|
1399 if ($c eq '') {
|
|
|
1400 _clear_status() if $i;
|
|
|
1401 } else {
|
|
|
1402 my ($calculation, $memory, $scroll, @result) = $calcptr->run($c);
|
|
|
1403 $command = '';
|
|
|
1404 $ui->set_text('command', $calculation) if $i;
|
|
|
1405 my $orig_calc = $calculation;
|
|
|
1406 my $saveit = ! $scroll;
|
|
|
1407 for my $result (@result) {
|
|
|
1408 $result =~ s/\s+$//;
|
|
|
1409 $result =~ s/\n/ /g;
|
|
|
1410 my $histline = $calculator{has_memory}
|
|
|
1411 ? join(' ', $memory, $result)
|
|
|
1412 : $result;
|
|
|
1413 if ($saveit) {
|
|
|
1414 unshift @history, ['r', $histline];
|
|
|
1415 $saveit = 0;
|
|
|
1416 }
|
|
|
1417 if (exists $calculator{skip_scroll}) {
|
|
|
1418 delete $calculator{skip_scroll};
|
|
|
1419 } else {
|
|
|
1420 if ($i) {
|
|
|
1421 for (my $h = $history; $h >= 1; $h--) {
|
|
|
1422 my $ph = $h == 1 ? '' : $h - 1;
|
|
|
1423 $ui->set_text("display$h", $ui->get_text("display$ph"));
|
|
|
1424 $ui->set_text("memory$h", $ui->get_text("memory$ph"))
|
|
|
1425 if $calculator{has_memory};
|
|
|
1426 }
|
|
|
1427 }
|
|
|
1428 }
|
|
|
1429 if ($i) {
|
|
|
1430 $ui->set_text('display', $result);
|
|
|
1431 $ui->set_text('memory', $memory) if $calculator{has_memory};
|
|
|
1432 } else {
|
|
|
1433 my $l = sprintf "%s%$calculator{display_size}s %s\n",
|
|
|
1434 $calculator{has_memory} ? $memory : '',
|
|
|
1435 $result, $calculation;
|
|
|
1436 $ui->stdread->read_text($l);
|
|
|
1437 }
|
|
|
1438 $memory = $calculation = '';
|
|
|
1439 }
|
|
|
1440 unshift @history, ['c', $orig_calc];
|
|
|
1441 $calculator{skip_scroll} = 1 if $scroll;
|
|
|
1442 }
|
|
|
1443 if ($i) {
|
|
|
1444 $history_object and _history_trace('', 0, 1);
|
|
|
1445 $trace_object and _history_trace('', 1, 1);
|
|
|
1446 _enable_keys();
|
|
|
1447 }
|
|
|
1448 ''
|
|
|
1449 }
|
|
|
1450
|
|
|
1451 sub _delkey {
|
|
|
1452 $give_up = 0;
|
|
|
1453 _clear_status();
|
|
|
1454 $command =~ s/.$//;
|
|
|
1455 $ui->set_text('command', $command);
|
|
|
1456 _enable_keys();
|
|
|
1457 ''
|
|
|
1458 }
|
|
|
1459
|
|
|
1460 sub _clear_status {
|
|
|
1461 $ui->set_text('command', $command);
|
|
|
1462 if ($calculator{skip_scroll}) {
|
|
|
1463 $calculator{skip_scroll} = 0;
|
|
|
1464 $ui->set_text("display", '');
|
|
|
1465 $ui->set_text("memory", '') if $calculator{has_memory};
|
|
|
1466 }
|
|
|
1467 }
|
|
|
1468
|
|
|
1469 sub _status {
|
|
|
1470 my ($msg) = @_;
|
|
|
1471 if ($ui->has_window) {
|
|
|
1472 $msg =~ s/\n$//;
|
|
|
1473 $ui->set_text('command', $msg);
|
|
|
1474 $ui->update();
|
|
|
1475 } else {
|
|
|
1476 $msg .= "\n" unless $msg =~ /\n$/;
|
|
|
1477 $ui->stdread->read_text($msg);
|
|
|
1478 }
|
|
|
1479 '';
|
|
|
1480 }
|
|
|
1481
|
|
|
1482 sub _complete {
|
|
|
1483 my ($text) = @_;
|
|
|
1484 my $T = $text;
|
|
|
1485 if ($T =~ s/^\s*`\s*//) {
|
|
|
1486 if ($T eq '') {
|
|
|
1487 return grep { $_ ne "\0" } keys %escape_defs;
|
|
|
1488 }
|
|
|
1489 my $c = substr($T, 0, 1, '');
|
|
|
1490 $T =~ s/^\s+//;
|
|
|
1491 exists $escape_defs{$c} or return ();
|
|
|
1492 my ($code, $list, $term, $names) = @{$escape_defs{$c}};
|
|
|
1493 defined $list or return ();
|
|
|
1494 if ($list) {
|
|
|
1495 if (defined $term) {
|
|
|
1496 my $i = index($T, $term);
|
|
|
1497 if ($i >= 0) {
|
|
|
1498 $T = substr($T, $i + 1);
|
|
|
1499 $T =~ s/^.*\s+//;
|
|
|
1500 $list = 'OPTION';
|
|
|
1501 $term = ' ';
|
|
|
1502 }
|
|
|
1503 }
|
|
|
1504 my @l = map {
|
|
|
1505 substr($_, length $T);
|
|
|
1506 } grep {
|
|
|
1507 substr($_, 0, length $T) eq $T;
|
|
|
1508 } @{$objects_found->{$list}};
|
|
|
1509 if (defined $term && @l == 1 && $l[0] eq '') {
|
|
|
1510 push @l, $term;
|
|
|
1511 }
|
|
|
1512 return @l;
|
|
|
1513 } elsif ($c eq 'h' || $c eq 't') {
|
|
|
1514 return (0..9);
|
|
|
1515 } elsif ($c eq 'm') {
|
|
|
1516 return (0..9) if $T =~ /^oic/i;
|
|
|
1517 my @l = grep {
|
|
|
1518 lc(substr($_, 0, length $T)) eq lc($T);
|
|
|
1519 } @{$objects_found->{MODE}};
|
|
|
1520 return map { substr($_, length $T) } @l;
|
|
|
1521 }
|
|
|
1522 } else {
|
|
|
1523 return $calcptr->complete($text);
|
|
|
1524 }
|
|
|
1525 }
|
|
|
1526
|
|
|
1527 sub usage {
|
|
|
1528 (my $p = $0) =~ s#^.*/##;
|
|
|
1529 die "Usage: $p [-alphabet] [files]\n";
|
|
|
1530 }
|
|
|
1531
|
|
|
1532 package INC;
|
|
|
1533
|
|
|
1534 sub can_add {
|
|
|
1535 my ($inc, $key) = @_;
|
|
|
1536 my ($ok, $cpl, $kcpl) = _check($inc, $command);
|
|
|
1537 $kcpl && exists $kcpl->{$key} ? $key : undef;
|
|
|
1538 }
|
|
|
1539
|
|
|
1540 sub _check {
|
|
|
1541 my ($inc, $line) = @_;
|
|
|
1542 return (0, {}) if $@;
|
|
|
1543 return @{$inc->{cache}{$line}} if exists $inc->{cache}{$line};
|
|
|
1544 my $run = 0;
|
|
|
1545 my $cpl = {};
|
|
|
1546 my $kcpl = {};
|
|
|
1547 eval {
|
|
|
1548 my ($l, $c) = $inc->{parser}->compile($inc->{s_line}, $line, 0,
|
|
|
1549 $inc->{s_space}, 0);
|
|
|
1550 $run = grep { $_->[1] == length($line) } @$l;
|
|
|
1551 my %cpl = ();
|
|
|
1552 my %kcpl = ();
|
|
|
1553 for my $cpl (@$c) {
|
|
|
1554 $cpl{$cpl} = 1;
|
|
|
1555 $kcpl{substr($cpl, 0, 1)} = 1;
|
|
|
1556 }
|
|
|
1557 $cpl = \%cpl;
|
|
|
1558 $kcpl = \%kcpl;
|
|
|
1559 };
|
|
|
1560 $inc->{cache}{$line} = [$run, $cpl, $kcpl];
|
|
|
1561 return @{$inc->{cache}{$line}};
|
|
|
1562 }
|
|
|
1563
|
|
|
1564 sub can_run {
|
|
|
1565 my ($inc) = @_;
|
|
|
1566 my ($ok, $cpl, $kcpl) = _check($inc, $command);
|
|
|
1567 $ok;
|
|
|
1568 }
|
|
|
1569
|
|
|
1570 sub complete {
|
|
|
1571 my ($inc, $text) = @_;
|
|
|
1572 my ($ok, $cpl, $kcpl) = _check($inc, $text);
|
|
|
1573 return $cpl ? (keys %$cpl) : ();
|
|
|
1574 }
|
|
|
1575
|
|
|
1576 sub run {
|
|
|
1577 my ($inc, $oline) = @_;
|
|
|
1578 my @result;
|
|
|
1579 eval {
|
|
|
1580 my $line = $oline;
|
|
|
1581 my ($l) = $inc->{parser}->compile($inc->{s_line}, $line, 0,
|
|
|
1582 $inc->{s_space}, 0);
|
|
|
1583 die "Syntax error\n" unless @$l;
|
|
|
1584 my @l = map { $_->[3] } grep { $_->[1] == length $line } @$l;
|
|
|
1585 die "Syntax error\n" unless @l;
|
|
|
1586 my $pos = length $line;
|
|
|
1587 my ($g) = $inc->{parser}->compile($inc->{s_statement},
|
|
|
1588 "$line\nDO GIVE UP", $pos,
|
|
|
1589 $inc->{s_space}, 0);
|
|
|
1590 my @g = map { $_->[3] } @$g;
|
|
|
1591 push @l, @g;
|
|
|
1592 $inc->{object}->object->code(\@l);
|
|
|
1593 $inc->{object}->object->source($line);
|
|
|
1594 ${$inc->{read_data}} = '';
|
|
|
1595 $inc->{read_fh}->reset;
|
|
|
1596 $inc->{object}->start(2)->run()->stop();
|
|
|
1597 $inc->{cache} = {} if $inc->{invalidate};
|
|
|
1598 @result = grep { /./ } split(/\n+/, ${$inc->{read_data}});
|
|
|
1599 };
|
|
|
1600 push @result, $@ if $@;
|
|
|
1601 for (@result) {
|
|
|
1602 $_ = main::_shorten($_) if /\*\d{3}/ && $ui->has_window;
|
|
|
1603 }
|
|
|
1604 my $scroll = 0;
|
|
|
1605 unless (@result) {
|
|
|
1606 push @result, 'OK';
|
|
|
1607 $scroll = 1;
|
|
|
1608 }
|
|
|
1609 ($oline, '', $scroll, @result);
|
|
|
1610 }
|
|
|
1611
|
|
|
1612 package OIC;
|
|
|
1613
|
|
|
1614 sub run {
|
|
|
1615 my ($oic, $line) = @_;
|
|
|
1616 my $calculation = '';
|
|
|
1617 my $memory = ' ' x (1 + $oic->{digits});
|
|
|
1618 my @result = ();
|
|
|
1619 eval {
|
|
|
1620 $line =~ s/\s+//g;
|
|
|
1621 $calculation = '(';
|
|
|
1622 my $a = _extract_oic($oic, \$line, \$calculation);
|
|
|
1623 die "Missing number\n" if $a eq '';
|
|
|
1624 $calculation .= ' - ';
|
|
|
1625 my $b = _extract_oic($oic, \$line, \$calculation);
|
|
|
1626 die "Missing number\n" if $b eq '';
|
|
|
1627 $calculation .= ') / ';
|
|
|
1628 my $c = _extract_oic($oic, \$line, \$calculation);
|
|
|
1629 die "Missing number\n" if $c eq '';
|
|
|
1630 $line =~ s/$oic->{regex}//
|
|
|
1631 or die "Invalid result: $line\n";
|
|
|
1632 $1 >= $oic->{nmems}
|
|
|
1633 and die "Invalid memory $1\n";
|
|
|
1634 my $m = $1;
|
|
|
1635 $memory = sprintf $oic->{format}, $m;
|
|
|
1636 my $result = ($a - $b) / $c;
|
|
|
1637 $oic->{memory}[$m] = $result;
|
|
|
1638 push @result, $result;
|
|
|
1639 $line eq '' or die "Extra data after line: $line\n";
|
|
|
1640 };
|
|
|
1641 push @result, $@ if $@;
|
|
|
1642 ($calculation, $memory, 0, @result);
|
|
|
1643 }
|
|
|
1644
|
|
|
1645 sub _extract_oic {
|
|
|
1646 my ($oic, $line, $calculation) = @_;
|
|
|
1647 if ($$line =~ s/$oic->{regex}//) {
|
|
|
1648 $1 >= $oic->{nmems}
|
|
|
1649 and die "Invalid memory $1\n";
|
|
|
1650 $$calculation .= sprintf $oic->{format}, $1;
|
|
|
1651 return $oic->{memory}[$1];
|
|
|
1652 }
|
|
|
1653 if ($$line =~ s/^(-?\d+\.\d*|-?\d*\.\d+|-?\d+)//) {
|
|
|
1654 $$calculation .= $1;
|
|
|
1655 return $1;
|
|
|
1656 }
|
|
|
1657 die "Invalid syntax: $line\n";
|
|
|
1658 }
|
|
|
1659
|
|
|
1660 sub _check {
|
|
|
1661 my ($oic, $c, $key) = @_;
|
|
|
1662 my $l = $c . $key;
|
|
|
1663 for (1..3) {
|
|
|
1664 my $r = '';
|
|
|
1665 last if $l =~ s/^(?:-\.?|\.|m)$//i;
|
|
|
1666 eval { _extract_oic($oic, \$l, \$r) };
|
|
|
1667 return undef if $@;
|
|
|
1668 return $key if $l eq '';
|
|
|
1669 }
|
|
|
1670 if ($l ne '') {
|
|
|
1671 $l =~ s/^m//i or return undef;
|
|
|
1672 $l =~ /^\d*$/ or return undef;
|
|
|
1673 return \$key if length($l) == $oic->{digits};
|
|
|
1674 }
|
|
|
1675 return $key;
|
|
|
1676 }
|
|
|
1677
|
|
|
1678 sub can_add {
|
|
|
1679 my ($oic, $key) = @_;
|
|
|
1680 _check($oic, $command, $key);
|
|
|
1681 }
|
|
|
1682
|
|
|
1683 sub complete {
|
|
|
1684 my ($oic, $text) = @_;
|
|
|
1685 grep { defined _check($oic, $text, $_) } (0..9, '-', '.', 'm');
|
|
|
1686 }
|
|
|
1687
|
|
|
1688 sub can_run {
|
|
|
1689 my ($oic) = @_;
|
|
|
1690 my $ok = _check($oic, $command, '');
|
|
|
1691 defined $ok && ref $ok;
|
|
|
1692 }
|
|
|
1693
|
|
|
1694 package WOBJ;
|
|
|
1695
|
|
|
1696 sub write {
|
|
|
1697 my ($wobj, $size) = @_;
|
|
|
1698 while (1) {
|
|
|
1699 return '' if ! defined $$wobj;
|
|
|
1700 return substr($$wobj, 0, $size, '') if length $$wobj >= $size;
|
|
|
1701 my $l = $ui->getline("DATA: ");
|
|
|
1702 if (defined $l && $l ne '') {
|
|
|
1703 $$wobj .= $l;
|
|
|
1704 } else {
|
|
|
1705 $l = $$wobj;
|
|
|
1706 $$wobj = '';
|
|
|
1707 return $l;
|
|
|
1708 }
|
|
|
1709 }
|
|
|
1710 }
|
|
|
1711
|
|
|
1712 package TOBJ;
|
|
|
1713
|
|
|
1714 sub read {
|
|
|
1715 my ($tobj, $line) = @_;
|
|
|
1716 $tobj->[1] or return;
|
|
|
1717 $tobj->[0] .= $line;
|
|
|
1718 my $sr = $ui->has_window ? undef : $ui->stdread;
|
|
|
1719 while ($tobj->[0] =~ s/^(.*?)\n//) {
|
|
|
1720 unshift @history, ['t', $1] if $1 ne '';
|
|
|
1721 if ($sr) {
|
|
|
1722 $sr->read_text($1 . "\n");
|
|
|
1723 } elsif ($trace_object) {
|
|
|
1724 main::_history_trace('', 1, 1);
|
|
|
1725 }
|
|
|
1726 }
|
|
|
1727 }
|
|
|
1728
|
|
|
1729 sub enable {
|
|
|
1730 my ($tobj, $yes) = @_;
|
|
|
1731 $tobj->[1] = $yes;
|
|
|
1732 }
|
|
|
1733
|
|
|
1734 __END__
|
|
|
1735
|
|
|
1736 =pod
|
|
|
1737
|
|
|
1738 =head1 NAME
|
|
|
1739
|
|
|
1740 intercalc - CLC-INTERCAL desk calculator
|
|
|
1741
|
|
|
1742 =head1 SYNOPSIS
|
|
|
1743
|
|
|
1744 B<intercalc> [options]
|
|
|
1745
|
|
|
1746 =head1 DESCRIPTION
|
|
|
1747
|
|
|
1748 B<intercalc> is a simple desk calculator, allowing the user to
|
|
|
1749 enter INTERCAL statements (to see what they do) and expressions
|
|
|
1750 (to see what value they produce); it uses an interpreter object
|
|
|
1751 from CLC-INTERCAL to provide immediate feedback.
|
|
|
1752
|
|
|
1753 The desk calculator accepts several options, some of which are documented here.
|
|
|
1754
|
|
|
1755 =head2 User Interface Options
|
|
|
1756
|
|
|
1757 =over 4
|
|
|
1758
|
|
|
1759 =item B<-X> / B<--graphic>
|
|
|
1760
|
|
|
1761 Enters X-based graphical user interface. Requires Perl-GTK. This is the
|
|
|
1762 default if Perl-GTK is installed, the environment variable I<$DISPLAY> is
|
|
|
1763 set and the opening of the X display succeeds.
|
|
|
1764
|
|
|
1765 =item B<-c> / B<--curses>
|
|
|
1766
|
|
|
1767 Enters full screen, curses-based interface. This is the default if the
|
|
|
1768 X based interface cannot be started, the environment variable I<$TERM>
|
|
|
1769 is set and the terminal name is known.
|
|
|
1770
|
|
|
1771 =item B<--line>
|
|
|
1772
|
|
|
1773 Enters the line-mode user interface. This is the default if the X based
|
|
|
1774 and the curses based interfaces do not work.
|
|
|
1775
|
|
|
1776 In this mode, the program executes each line from standard input according
|
|
|
1777 to the current mode and language, and prints results to standard output.
|
|
|
1778 A line starting with a backspark is interpreted as a command to the
|
|
|
1779 calculator. Use backspark-g to GIVE UP (you'll need to do it twice), or
|
|
|
1780 backspark-h to display the ehm, help page. Things which are available
|
|
|
1781 via menu entries on the Curses and X interfaces are also available via
|
|
|
1782 the backspark. For now, you can refer to the source code for a list.
|
|
|
1783
|
|
|
1784 Command-line editing and command history is provided by the readline
|
|
|
1785 library. Command completion works if the underlying compiler supports it
|
|
|
1786 (the compilers provided with the distributions do).
|
|
|
1787
|
|
|
1788 =item B<--batch>
|
|
|
1789
|
|
|
1790 Avoids entering interactive mode. This is the default if the standard
|
|
|
1791 input and output are not connected to a terminal and the X based interface
|
|
|
1792 cannot be started. This mode is very similar to the line mode except that
|
|
|
1793 command-line editing and command history are not implemented. Backspark
|
|
|
1794 escapes work just the same.
|
|
|
1795
|
|
|
1796 =item B<-i>I<type> / B<--interface>=I<type>
|
|
|
1797
|
|
|
1798 Selects the user interface I<type>. Currently, only I<X>, I<Curses>,
|
|
|
1799 I<Line> and I<None> are defined, but more can be installed as compiler
|
|
|
1800 plug-ins. If the interface selected is I<None>, B<intercalc> will work in
|
|
|
1801 batch mode. In addition, an empty string will reinstate the default
|
|
|
1802 behaviour.
|
|
|
1803
|
|
|
1804 =back
|
|
|
1805
|
|
|
1806 =head2 Source language and compilation options
|
|
|
1807
|
|
|
1808 =over 4
|
|
|
1809
|
|
|
1810 =item B<--bug>=I<number>
|
|
|
1811
|
|
|
1812 Selects a different probability for the compiler bug. The compiler bug is
|
|
|
1813 implemented by initialising the compiler's state with the required probability:
|
|
|
1814 when a statement is compiled (usually at runtime), a "BUG" instruction is
|
|
|
1815 emitted with the required probability. The default is 1%.
|
|
|
1816
|
|
|
1817 =item B<--ubug>=I<number>
|
|
|
1818
|
|
|
1819 Selects a probability for the unexplainable compiler bug. This is the compiler
|
|
|
1820 bug which occurs when the probability of a (explainable) compiler bug is zero.
|
|
|
1821 Only wimps would use this option. The default is 0.01%.
|
|
|
1822
|
|
|
1823 =item B<-I>I<path> / B<--include>=I<path>
|
|
|
1824
|
|
|
1825 Adds a directory before the standard search path for compiler objects
|
|
|
1826 and source code. If a file is accessible from the current directory,
|
|
|
1827 it is never searched in any include path.
|
|
|
1828
|
|
|
1829 If this option is repeated, the given paths will be searched in the
|
|
|
1830 order given, followed by the standard paths.
|
|
|
1831
|
|
|
1832 =item B<-l>I<language> / B<--language>=I<language>
|
|
|
1833
|
|
|
1834 Selects the language to use when interpreting user input. This should
|
|
|
1835 correspond to the name of a compiler, which is an INTERCAL object
|
|
|
1836 which was originally built by I<iacc>. Only the expression and
|
|
|
1837 statement parsers are used, so it is possible to test incomplete
|
|
|
1838 compilers by loading them into I<intercalc> even if they don't
|
|
|
1839 work with I<sick>. The default is obtained from the F<sickrc>
|
|
|
1840 option I<.INTERCALC.LANGUAGE>.
|
|
|
1841
|
|
|
1842 =item -B<-o>I<option> -B<--option>=I<option>
|
|
|
1843
|
|
|
1844 Adds a language option. For example, -B<-o>I<3> selects base 3 calculation,
|
|
|
1845 and -B<-o>I<wimp> selects wimp mode. If no options are provided, and the
|
|
|
1846 default language was taken from the F<sickrc> file, the default options
|
|
|
1847 are taken from the F<sickrc> file. Note that if an option or a language is
|
|
|
1848 specified on the command line, the F<sickrc> defaults are ignored.
|
|
|
1849
|
|
|
1850 Unlike previous versions of I<intercalc>, this version checks that the
|
|
|
1851 options make sense in the context of the calculator; for example trying
|
|
|
1852 to load a compiler as an option will cause an error, but a compiler
|
|
|
1853 extension will be OK.
|
|
|
1854
|
|
|
1855 =item B<-m>I<mode> / B<--mode>=I<mode>
|
|
|
1856
|
|
|
1857 Select operation mode. Currently, the only valid modes are I<full>,
|
|
|
1858 I<expr> and I<one>. See L</Operating Modes>. If this is not specified,
|
|
|
1859 the default is taken from the F<sickrc> option I<..INTERCALC.MODE>.
|
|
|
1860
|
|
|
1861 =back
|
|
|
1862
|
|
|
1863 =head2 Misc Options
|
|
|
1864
|
|
|
1865 =over 4
|
|
|
1866
|
|
|
1867 =item B<-r>I<name> / B<--rcfile>=I<name>
|
|
|
1868
|
|
|
1869 Executes commands from file I<name> before starting to accept input.
|
|
|
1870 This option can be repeated, to execute more than one file. If it is
|
|
|
1871 not specified, the standard library, the current directory, and the
|
|
|
1872 current user's home directory are searched for files with name
|
|
|
1873 F<system.sickrc> or F<.sickrc>, which are then executed. The order
|
|
|
1874 for this search is: specified library (B<--include>), system library,
|
|
|
1875 home directory, current directory. This is different from the search
|
|
|
1876 order used when looking for objects or source code. If a directory
|
|
|
1877 contains both F<.sickrc> and F<system.sickrc>, the F<system.sickrc>
|
|
|
1878 is executed first, followed by F<.sickrc>. Also note that if the
|
|
|
1879 current directory or the home directory appear in the search path
|
|
|
1880 and contain one of these files, they will be executed twice.
|
|
|
1881
|
|
|
1882 If filenames are explicitely specified, they must be fully qualified:
|
|
|
1883 the search path is not used to find them.
|
|
|
1884
|
|
|
1885 =item B<--nouserrc>
|
|
|
1886
|
|
|
1887 Prevents loading a user rcfile (.sickrc); also limits loading of
|
|
|
1888 system.sickrc to the first one found. This option is normally only
|
|
|
1889 used when testing the installation, to prevent interference from
|
|
|
1890 previous versions of CLC-INTERCAL.
|
|
|
1891
|
|
|
1892 =back
|
|
|
1893
|
|
|
1894 =head1 Operating Modes
|
|
|
1895
|
|
|
1896 The calculator can operate in the following modes:
|
|
|
1897
|
|
|
1898 =over 5
|
|
|
1899
|
|
|
1900 =item full
|
|
|
1901 Fully functional INTERCAL interpreter.
|
|
|
1902
|
|
|
1903 The calculator can parse and execute any statement or expression.
|
|
|
1904
|
|
|
1905 Statements are compiled as a one-statement program, and executed;
|
|
|
1906 any register value etc. will be preserved between statements, so
|
|
|
1907 entering a list of statements is equivalent to running a program
|
|
|
1908 in which all these statements are executed in sequence.
|
|
|
1909
|
|
|
1910 It is important to note that some statements will not execute in
|
|
|
1911 the normal manner. For example, a COME FROM will be parsed but
|
|
|
1912 have no effect, unless it is something like:
|
|
|
1913
|
|
|
1914 (1) PLEASE COME FROM (1)
|
|
|
1915
|
|
|
1916 which causes the calculator to hang. On the other hand, an ABSTAIN FROM
|
|
|
1917 or a REINSTATE will work as expected, as will CREATE and DESTROY.
|
|
|
1918 A GIVE UP does not cause the calculator to terminate. One final
|
|
|
1919 difference is that comments are not parsed, and therefore you get a
|
|
|
1920 "Syntax Error" from the calculator rather than a splat *000 from the
|
|
|
1921 INTERCAL interpreter.
|
|
|
1922
|
|
|
1923 For expressions, the calculator READs OUT the expression's result.
|
|
|
1924 Any side effects will be remembered, so if the expression contains
|
|
|
1925 overloads they will remain to haunt the calculator.
|
|
|
1926
|
|
|
1927 =item expr
|
|
|
1928 INTERCAL expression interpreter
|
|
|
1929
|
|
|
1930 The calculator can only parse expressions or assignments. In either
|
|
|
1931 case, the calculated values are READ OUT; assignments will also
|
|
|
1932 store the value to the destination, while expressions will then
|
|
|
1933 discard the result.
|
|
|
1934
|
|
|
1935 =item oic
|
|
|
1936 The B<O>ne B<I>nstruction B<C>alculator.
|
|
|
1937
|
|
|
1938 This is something we've made
|
|
|
1939 up one early morning while discussing desk calculators (as one does).
|
|
|
1940 It is not INTERCAL at all, in fact it is inspired from the One Instruction
|
|
|
1941 Set Computer.
|
|
|
1942
|
|
|
1943 The calculator has a number of memories (default 100 - these can be changed
|
|
|
1944 by appending a number to the operating mode, for example I<oic10> will
|
|
|
1945 use a 10-memory calculator). These memories are identified by the letter
|
|
|
1946 B<m> followed by a number; in the default 100-memory version, the first two
|
|
|
1947 digits after B<m> are the memory, and any subsequent digit forms part
|
|
|
1948 of the next operand. At the start, all memories are initialised to 0.
|
|
|
1949
|
|
|
1950 Since there is only one operation, there is no need to specify it, so an
|
|
|
1951 "operation" is a sequence of three operands and a result. The result must
|
|
|
1952 be a memory, while each operand can be a number or a memory, with the
|
|
|
1953 limitation that consecutive numbers are acceptable only if the parser can
|
|
|
1954 determine where one ends and the next one starts. So for example "1-0" is
|
|
|
1955 two numeric operands, 1 and -0 (aka 0); "1.2.3" is also two operands,
|
|
|
1956 1.2 and 3; "12" is a single operand, even if you intended it to be two
|
|
|
1957 operands, 1 and 2, and even if you put spaces: "1 2" is still interpreted
|
|
|
1958 as the single operand 12.
|
|
|
1959
|
|
|
1960 The operation performed is the difference between the first two operands,
|
|
|
1961 divided by the third. For example, the three operations:
|
|
|
1962
|
|
|
1963 7 m01 2 M01
|
|
|
1964 1 m02 1 m02
|
|
|
1965 m1 .5 m2 m03
|
|
|
1966
|
|
|
1967 will produce results m01=3.5 ((7-0)/2); m02=1 ((1-0)/1); m03=3 ((3.5-.5)/1).
|
|
|
1968 and will produce the following output if the calculator is running in batch
|
|
|
1969 mode:
|
|
|
1970
|
|
|
1971 m01 3.5 (7 - m01) / 2
|
|
|
1972 m02 1 (1 - m02) / 1
|
|
|
1973 m03 3 (m01 - .5) / m02
|
|
|
1974
|
|
|
1975 =back
|
|
|
1976
|
|
|
1977 =head1 SEE ALSO
|
|
|
1978
|
|
|
1979 The INTERCAL on-line documentation, by running B<intercalc> and finding the
|
|
|
1980 "help" menu or key (X and Curses) or backspark escape (Line and None).
|
|
|
1981
|
