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