- 772AAAF953790FBB7D7FE6AFD0BF2DEAF77988B1376A7C169FBD21F47F5AAFF6DF87B2C333B90E8CD373C11379BA4830CEDC3A48B36C26767AC7303889EF6A69
+ C8DCA28206FADA4CCA7369F0429DC4CBE3B5E75702C701F84256F2A6E04DF33EF6557CD427BF2A486306675943215445982E21CEA9CAEDBCCDE0049AC9C39BE1
ffa/ffacalc/ffa_calc.adb
(20 . 7)(20 . 6)
27 -- Basics
28 with Version; use Version;
29 with OS; use OS;
30 with CmdLine; use CmdLine;
31
32 -- FFA
33 with FFA; use FFA;
(32 . 115)(31 . 170)
35 with FFA_RNG; use FFA_RNG;
36
37
38 procedure FFA_Calc is
39 package body FFA_Calc is
40
41 Width : Positive; -- Desired FFA Width
42 Height : Positive; -- Desired Height of Stack
43 RNG : RNG_Device; -- The active RNG device.
44
45 begin
46 if Arg_Count < 3 or Arg_Count > 4 then
47 Eggog("Usage: ./ffa_calc WIDTH HEIGHT [/dev/rng]");
48 end if;
49
50 declare
51 Arg1 : CmdLineArg;
52 Arg2 : CmdLineArg;
53 -- Ensure that requested Peh Dimensions are permissible. Terminate if not.
54 procedure Validate_Peh_Dimensions(Dimensions : in Peh_Dimensions) is
55 begin
56 -- Get commandline args:
57 Get_Argument(1, Arg1); -- First arg
58 Get_Argument(2, Arg2); -- Second arg
59
60 if Arg_Count = 4 then
61 -- RNG was specified:
62 declare
63 Arg3 : CmdLineArg;
64 begin
65 Get_Argument(3, Arg3); -- Third arg (optional)
66
67 -- Ada.Sequential_IO chokes on paths with trailing whitespace!
68 -- So we have to give it a trimmed path. But we can't use
69 -- Ada.Strings.Fixed.Trim, because it suffers from
70 -- SecondaryStackism-syphilis. Instead we are stuck doing this:
71 Init_RNG(RNG, Arg3(Arg3'First .. Len_Arg(3)));
72 end;
73 else
74 -- RNG was NOT specified:
75 Init_RNG(RNG); -- Use the machine default then
76
77 -- Test if proposed Width is permissible:
78 if not FFA_FZ_Valid_Bitness_P(Dimensions.Width) then
79 Eggog("Requested Invalid FZ Width, " & FFA_Validity_Rule_Doc);
80 end if;
81
82 -- Warn the operator if an unbounded Peh run has been requested:
83 if Dimensions.Life = 0 then
84 Achtung("WARNING: Life=0 enables UNBOUNDED run time;" &
85 " halting cannot be guaranteed!");
86 end if;
87
88 -- Parse into Positives:
89 Width := Positive'Value(Arg1);
90 Height := Positive'Value(Arg2);
91 exception
92 when others =>
93 Eggog("Invalid arguments!");
94 end;
95 end Validate_Peh_Dimensions;
96
97 -- Test if proposed Width is permissible:
98 if not FFA_FZ_Valid_Bitness_P(Width) then
99 Eggog("Invalid Width: " & FFA_Validity_Rule_Doc);
100 end if;
101
102 -- The Calculator itself:
103 declare
104 -- Start a Peh Machine with the given Dimensions and Tape; return a Verdict.
105 function Peh_Machine(Dimensions : in Peh_Dimensions;
106 Tape : in Peh_Tapes;
107 RNG : in RNG_Device) return Peh_Verdicts is
108
109 -- The number of Words required to make a FZ of the given Bitness.
110 Wordness : Indices := Indices(Width / Bitness);
111 Wordness : Indices := Indices(Dimensions.Width / Bitness);
112
113 --------------------------------------------------------
114 -- State --
115 --------------------------------------------------------
116 -- The Stack:
117 subtype Stack_Positions is Natural range 0 .. Height;
118 -- The Data Stack:
119 subtype Stack_Positions is Natural range 0 .. Dimensions.Height;
120 type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness);
121 Stack : Stacks(Stack_Positions'Range);
122 Stack : Stacks(Stack_Positions'Range);
123
124 -- Current top of the Data Stack:
125 SP : Stack_Positions := Stack_Positions'First;
126
127 -- Valid indices into the Tape:
128 subtype Tape_Positions is Peh_Tape_Range range Tape'First .. Tape'Last;
129
130 -- Position of the CURRENT Op on the Tape:
131 IP : Tape_Positions;
132
133 -- After an Op, will contain position of NEXT op (if = to IP -> halt)
134 IP_Next : Tape_Positions;
135
136 -- Control Stack; permits bidirectional motion across the Tape:
137 Control_Stack : array(ControlStack_Range) of Tape_Positions
138 := (others => Tape_Positions'First);
139
140 -- Stack Pointer:
141 SP : Stack_Positions := Stack_Positions'First;
142 -- Current top of the Control Stack:
143 CSP : ControlStack_Range := ControlStack_Range'First;
144
145 -- Registers:
146 subtype RegNames is Character range 'g' .. 'z';
147 type RegTables is array(RegNames range <>) of FZ(1 .. Wordness);
148 Registers : RegTables(RegNames'Range);
149
150 -- Carry/Borrow Flag:
151 Flag : WBool := 0;
152 Flag : WBool := 0;
153
154 -- Odometer:
155 Pos : Natural := 0;
156 Ticks : Natural := 0;
157
158 -- The current levels of the three types of nestedness:
159 QuoteLevel : Natural := 0;
160 CommLevel : Natural := 0;
161 CondLevel : Natural := 0;
162 QuoteLevel : Natural := 0;
163 CommLevel : Natural := 0;
164 CondLevel : Natural := 0;
165
166 -- Prefixed Operators
167 PrevC : Character := ' ';
168 HavePrefix : Boolean := False;
169 PrevC : Character := ' ';
170 HavePrefix : Boolean := False;
171
172 -- Current Verdict. We run while 'Mu', tape remains, and Ticks under max.
173 Verdict : Peh_Verdicts := Mu;
174 --------------------------------------------------------
175
176
177 -- Clear the stack and set SP to bottom.
178 -- Determine whether we have reached the given limit of Life:
179 function Exhausted_Life return Boolean is
180 -- If Life = 0, we are in "immortal" mode. Otherwise mortal:
181 MustDie : Boolean :=
182 (Dimensions.Life /= 0) and (Ticks = Dimensions.Life);
183 begin
184 if MustDie then
185 Achtung("WARNING: Exhausted Life ("
186 & Natural'Image(Ticks) & " ticks )");
187 end if;
188 return MustDie;
189 end Exhausted_Life;
190
191
192 -- Clear all state, other than blocks, Control Stack, Tape and Verdict:
193 procedure Zap is
194 begin
195 -- Clear the stack
196 -- Clear the Data Stack:
197 for i in Stack'Range loop
198 FFA_FZ_Clear(Stack(i));
199 end loop;
200 -- Set SP to bottom
201 SP := Stack_Positions'First;
202 -- Clear Overflow flag
203 Flag := 0;
204 -- Clear prefix
205 HavePrefix := False;
206 PrevC := ' ';
207 -- Set SP to bottom:
208 SP := Stack_Positions'First;
209 -- Clear all Registers:
210 for r in RegNames'Range loop
211 FFA_FZ_Clear(Registers(r));
212 end loop;
213 -- Clear Overflow flag:
214 Flag := 0;
215 -- Clear prefix:
216 HavePrefix := False;
217 PrevC := ' ';
218 end Zap;
219
220
221 -- Report a fatal error condition at the current symbol
222 -- Report a fatal error condition at the current symbol.
223 -- On Unixlikes, this will also end the process and return control to OS.
224 procedure E(S : in String) is
225 begin
226 Eggog("Pos:" & Natural'Image(Pos) & ": " & S);
227 Zap; -- Jettison all resettable state!
228 Eggog("FATAL: Tick:" & Natural'Image(Ticks) &
229 " IP:" & Tape_Positions'Image(IP) & " : " & S);
230 end E;
231
232
233 -------------------
234 -- Control Stack --
235 -------------------
236
237 -- Push a given Tape Position to the Control Stack:
238 procedure Control_Push(Position : in Tape_Positions) is
239 begin
240 -- First, test for Overflow of Control Stack:
241 if CSP = Control_Stack'Last then
242 E("Control Stack Overflow!");
243 end if;
244
245 -- Push given Tape Position to Control Stack:
246 CSP := CSP + 1;
247 Control_Stack(CSP) := Position;
248 end Control_Push;
249
250
251 -- Pop a Tape Position from the Control Stack:
252 function Control_Pop return Tape_Positions is
253 Position : Tape_Positions;
254 begin
255 -- First, test for Underflow of Control Stack:
256 if CSP = Control_Stack'First then
257 E("Control Stack Underflow!");
258 end if;
259
260 -- Pop a Tape Position from Control Stack:
261 Position := Control_Stack(CSP);
262 Control_Stack(CSP) := Tape_Positions'First;
263 CSP := CSP - 1;
264 return Position;
265 end Control_Pop;
266
267
268 ----------------
269 -- Data Stack --
270 ----------------
271
272 -- Move SP up
273 procedure Push is
274 begin
(206 . 11)(260 . 40)
276 end Print_FZ;
277
278
279 -- Denote that the given op is a prefix
280 procedure IsPrefix is
281 -- Print a Debug Trace (used in 'QD')
282 procedure Print_Trace is
283 begin
284 HavePrefix := True;
285 end IsPrefix;
286 -- Print Data Stack Trace:
287 Write_String("Data Stack:");
288 Write_Newline;
289 for i in reverse Stack'First + 1 .. SP loop
290 Write_String(" " & Stack_Positions'Image(i) & " : ");
291 Print_FZ(Stack(i));
292 end loop;
293
294 -- Print Control Stack Trace:
295 Write_String("Control Stack:");
296 Write_Newline;
297 for i in reverse Control_Stack'First + 1 .. CSP loop
298 Write_String(" " & ControlStack_Range'Image(i) & " :"
299 & Tape_Positions'Image(Control_Stack(i)));
300 Write_Newline;
301 end loop;
302
303 -- Print All Registers:
304 Write_String("Registers:");
305 Write_Newline;
306 for r in RegNames'Range loop
307 Write_String(" " & r & " : ");
308 Print_FZ(Registers(r));
309 end loop;
310
311 -- Print Ticks and IP:
312 Write_String("Ticks :" & Natural'Image(Ticks));
313 Write_Newline;
314 Write_String("IP :" & Tape_Positions'Image(IP));
315 Write_Newline;
316 end Print_Trace;
317
318
319 -- Execute a Normal Op
(275 . 6)(358 . 13)
321 Want(1);
322 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
323
324 -------------------------
325 -- Fetch from Register --
326 -------------------------
327 when 'g' .. 'z' =>
328 Push;
329 Stack(SP) := Registers(C); -- Put value of Register on stack
330
331 ------------------
332 -- Stack Motion --
333 ------------------
(490 . 25)(580 . 18)
335 Print_FZ(Stack(SP));
336 Drop;
337
338 -- Zap (reset)
339 -- Zap (reset all resettables)
340 when 'Z' =>
341 Zap;
342
343 -- Quit with Stack Trace
344 when 'Q' =>
345 for I in reverse Stack'First + 1 .. SP loop
346 Print_FZ(Stack(I));
347 end loop;
348 Quit(0);
349
350 -- Put the FFACalc Program Version on the stack,
351 -- Put the Peh Program Version on the stack,
352 -- followed by FFA Program Version.
353 when 'V' =>
354 Push;
355 Push;
356 -- FFACalc Version:
357 -- Peh Version:
358 FFA_FZ_Clear(Stack(SP - 1));
359 FFA_FZ_Set_Head(Stack(SP - 1), Word(FFACalc_K_Version));
360 FFA_FZ_Set_Head(Stack(SP - 1), Word(Peh_K_Version));
361 -- FFA Version:
362 FFA_FZ_Clear(Stack(SP));
363 FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
(540 . 24)(623 . 50)
365 -- Prefixes --
366 --------------
367
368 -- 'Left...' :
369 when 'L' =>
370 IsPrefix;
371
372 -- 'Right...' :
373 when 'R' =>
374 IsPrefix;
375 when
376 'Q' -- 'Quit...'
377 |
378 'L' -- 'Left...'
379 |
380 'R' -- 'Right...'
381 |
382 'M' -- 'Modular...'
383 |
384 '$' -- Pop top of Stack into the following Register...
385 =>
386 HavePrefix := True;
387
388 -------------------
389 -- Control Stack --
390 -------------------
391
392 -- Push current IP (i.e. of THIS Op) to Control Stack.
393 when ':' =>
394 Control_Push(IP);
395
396 -- Conditional Return: Pop top of Stack, and...
397 -- ... if ZERO: simply discard the top of the Control Stack.
398 -- ... if NONZERO: pop top of Control Stack and make it next IP.
399 when ',' =>
400 Want(1);
401 declare
402 Position : Tape_Positions := Control_Pop;
403 begin
404 if FFA_FZ_NZeroP(Stack(SP)) = 1 then
405 IP_Next := Position;
406 end if;
407 end;
408 Drop;
409
410 -- 'Modular...' :
411 when 'M' =>
412 IsPrefix;
413 -- UNconditional Return: Control Stack top popped into IP_Next.
414 when ';' =>
415 IP_Next := Control_Pop;
416
417 ---------------------------------------------------------
418 -- Reserved Ops, i.e. ones we have not defined yet: --
419 -- Reserved Ops, i.e. ones we have not defined yet: --
420 ---------------------------------------------------------
421 when '!' | '@' | '$' | ':' | ';' | ',' |
422 'H' | 'I' | 'J' | 'K' | 'N' |
423 'T' | 'X' | 'Y' =>
424 when '!' | '@' |
425 'H' | 'I' | 'J' | 'K' | 'N' | 'T' | 'X' | 'Y' =>
426
427 E("This Operator is not defined yet: " & C);
428 ---------------------------------------------------------
(578 . 12)(687 . 81)
430 -- Execute a Prefixed Op
431 procedure Op_Prefixed(Prefix : in Character;
432 O : in Character) is
433
434 -- Report an attempt to execute an undefined Prefix Op:
435 procedure Undefined_Prefix_Op is
436 begin
437 E("Undefined Prefix Op: " & Prefix & O);
438 end Undefined_Prefix_Op;
439
440 begin
441
442 -- The Prefixed Op:
443 -- Which Prefix Op?
444 case Prefix is
445
446 ---------------------------------------------------------
447 -- Quit...
448 when 'Q' =>
449
450 -- .. Quit how?
451 case O is
452
453 -- ... with a 'Yes' Verdict:
454 when 'Y' =>
455 Verdict := Yes;
456
457 -- ... with a 'No' Verdict:
458 when 'N' =>
459 Verdict := No;
460
461 -- ... with a 'Mu' Verdict: (permitted, but discouraged)
462 when 'M' =>
463 IP_Next := IP; -- Force a 'Mu' Termination
464
465 -- ... with Debug Trace, and a 'Mu' Verdict:
466 when 'D' =>
467 Print_Trace;
468 IP_Next := IP; -- Force a 'Mu' Termination
469
470 -- ... with an explicit Tape-triggered fatal EGGOG!
471 -- The 'QE' curtain call is intended strictly to signal
472 -- catastrophic (e.g. iron) failure from within a Tape
473 -- program ('cosmic ray' scenario) where a ~hardwired
474 -- mechanism~ of any kind appears to have done something
475 -- unexpected; or to abort on a failed test of the RNG;
476 -- or similar hard-stop scenarios, where either physical
477 -- iron, or basic FFA routine must be said to have failed,
478 -- and the continued use of the system itself - dangerous.
479 -- The use of 'QE' for any other purpose is discouraged;
480 -- please do not use it to indicate failed decryption etc.
481 when 'E' =>
482 -- Hard-stop with this eggog:
483 E("Tape-triggered CATASTROPHIC ERROR! " &
484 "Your iron and/or your build of Peh, " &
485 "may be defective! Please consult " &
486 "the author of this Tape.");
487
488 -- ... Unknown (Eggog):
489 when others =>
490 Undefined_Prefix_Op;
491
492 end case;
493
494 ---------------------------------------------------------
495 -- Write into Register...
496 when '$' =>
497
498 -- Eggog if operator gave us a garbage Register name:
499 if O not in RegNames then
500 E("There is no Register '" & O & "' !");
501 end if;
502
503 -- Selected Register exists; move top FZ on stack into it:
504 Want(1);
505 Registers(O) := Stack(SP);
506 Drop;
507
508 ---------------------------------------------------------
509 -- Left...
510 when 'L' =>
511
(608 . 9)(786 . 9)
513 when 'R' =>
514 E("Left-Rotate not yet defined!");
515
516 -- ... Unknown:
517 -- ... Unknown (Eggog):
518 when others =>
519 E("Undefined Op: L" & O);
520 Undefined_Prefix_Op;
521
522 end case;
523 ---------------------------------------------------------
(646 . 9)(824 . 9)
525 XY => Stack(SP - 1));
526 Drop;
527
528 -- ... Unknown:
529 -- ... Unknown (Eggog):
530 when others =>
531 E("Undefined Op: R" & O);
532 Undefined_Prefix_Op;
533
534 end case;
535 ---------------------------------------------------------
(689 . 9)(867 . 9)
537 Drop;
538 Drop;
539
540 -- ... Unknown:
541 -- ... Unknown (Eggog):
542 when others =>
543 E("Undefined Op: M" & O);
544 Undefined_Prefix_Op;
545
546 end case;
547 ---------------------------------------------------------
(769 . 29)(947 . 77)
549 Op_Normal(C);
550 end if;
551
552 -- In all cases, save the current symbol as possible prefix:
553 PrevC := C;
554
555 end Op;
556
557
558 -- Current Character
559 C : Character;
560
561 begin
562 -- Reset the Calculator
563 -- Reset all resettable state:
564 Zap;
565 -- Process characters until EOF:
566
567 -- Execution begins with the first Op on the Tape:
568 IP := Tape_Positions'First;
569
570 loop
571 if Read_Char(C) then
572 -- Execute Op:
573 Op(C);
574 -- Advance Odometer
575 Pos := Pos + 1;
576 -- Save the op for use in prefixed ops
577 PrevC := C;
578
579 -- If current Op is NOT the last Op on the Tape:
580 if IP /= Tape_Positions'Last then
581
582 -- ... then default successor of the current Op is the next one:
583 IP_Next := IP + 1;
584
585 else
586 Zap;
587 Quit(0); -- if EOF, we're done
588
589 -- ... but if no 'next' Op exists, or quit-with-Mu, we stay put:
590 IP_Next := IP; -- ... this will trigger an exit from the loop.
591
592 end if;
593
594 -- Advance Odometer for every Op (incl. prefixes, in comments, etc) :
595 Ticks := Ticks + 1;
596
597 -- Execute the Op at the current IP:
598 Op(Tape(IP));
599
600 -- Halt when...
601 exit when
602 Verdict /= Mu or -- Got a Verdict, or...
603 IP_Next = IP or -- Reached the end of the Tape, or...
604 Exhausted_Life; -- Exhausted Life.
605
606 -- We did not halt yet, so select the IP of the next Op to fetch:
607 IP := IP_Next;
608
609 end loop;
610 end;
611
612 -- Warn operator about any unclosed blocks:
613 if CommLevel > 0 then
614 Achtung("WARNING: Tape terminated with an unclosed Comment!");
615 end if;
616
617 if QuoteLevel > 0 then
618 Achtung("WARNING: Tape terminated with an unclosed Quote!");
619 end if;
620
621 if CondLevel > 0 then
622 Achtung("WARNING: Tape terminated with an unclosed Conditional!");
623 end if;
624
625 -- Warn operator if we terminated with a non-empty Control Stack.
626 -- This situation ought to be considered poor style in a Peh Tape;
627 -- for clarity, Verdicts should be returned from a place near
628 -- the visually-apparent end of a Tape. However, this is not mandatory.
629 if CSP /= Control_Stack'First then
630 Achtung("WARNING: Tape terminated with a non-empty Control Stack!");
631 end if;
632
633 -- We're done with the Tape, so clear the state:
634 Zap;
635
636 -- Return the Verdict:
637 return Verdict;
638
639 end Peh_Machine;
640
641 end FFA_Calc;