File : ffa_calc.adb
1 ------------------------------------------------------------------------------
2 ------------------------------------------------------------------------------
3 -- This file is part of 'Finite Field Arithmetic', aka 'FFA'. --
4 -- --
5 -- (C) 2019 Stanislav Datskovskiy ( www.loper-os.org ) --
6 -- http://wot.deedbot.org/17215D118B7239507FAFED98B98228A001ABFFC7.html --
7 -- --
8 -- You do not have, nor can you ever acquire the right to use, copy or --
9 -- distribute this software ; Should you use this software for any purpose, --
10 -- or copy and distribute it to anyone or in any manner, you are breaking --
11 -- the laws of whatever soi-disant jurisdiction, and you promise to --
12 -- continue doing so for the indefinite future. In any case, please --
13 -- always : read and understand any software ; verify any PGP signatures --
14 -- that you use - for any purpose. --
15 -- --
16 -- See also http://trilema.com/2015/a-new-software-licensing-paradigm . --
17 ------------------------------------------------------------------------------
18 ------------------------------------------------------------------------------
19
20 -- Basics
21 with Version; use Version;
22 with OS; use OS;
23
24 -- FFA
25 with FFA; use FFA;
26
27 -- For the intrinsic equality operator on Words
28 use type FFA.Word;
29
30 -- For RNG:
31 with FFA_RNG; use FFA_RNG;
32
33
34 package body FFA_Calc is
35
36 -- Ensure that requested Peh Dimensions are permissible. Terminate if not.
37 procedure Validate_Peh_Dimensions(Dimensions : in Peh_Dimensions) is
38 begin
39
40 -- Test if proposed Width is permissible:
41 if not FFA_FZ_Valid_Bitness_P(Dimensions.Width) then
42 Eggog("Requested Invalid FZ Width, " & FFA_Validity_Rule_Doc);
43 end if;
44
45 -- Warn the operator if an unbounded Peh run has been requested:
46 if Dimensions.Life = 0 then
47 Achtung("WARNING: Life=0 enables UNBOUNDED run time;" &
48 " halting cannot be guaranteed!");
49 end if;
50
51 end Validate_Peh_Dimensions;
52
53
54 -- Start a Peh Machine with the given Dimensions and Tape; return a Verdict.
55 function Peh_Machine(Dimensions : in Peh_Dimensions;
56 Tape : in Peh_Tapes;
57 RNG : in RNG_Device) return Peh_Verdicts is
58
59 -- The number of Words required to make a FZ of the given Bitness.
60 Wordness : Indices := Indices(Dimensions.Width / Bitness);
61
62 --------------------------------------------------------
63 -- State --
64 --------------------------------------------------------
65 -- The Data Stack:
66 subtype Stack_Positions is Natural range 0 .. Dimensions.Height;
67 type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness);
68 Stack : Stacks(Stack_Positions'Range);
69
70 -- Current top of the Data Stack:
71 SP : Stack_Positions := Stack_Positions'First;
72
73 -- Valid indices into the Tape:
74 subtype Tape_Positions is Peh_Tape_Range range Tape'First .. Tape'Last;
75
76 -- Position of the CURRENT Op on the Tape:
77 IP : Tape_Positions;
78
79 -- After an Op, will contain position of NEXT op (if = to IP -> halt)
80 IP_Next : Tape_Positions;
81
82 -- Control Stack; permits bidirectional motion across the Tape:
83 Control_Stack : array(ControlStack_Range) of Tape_Positions
84 := (others => Tape_Positions'First);
85
86 -- Current top of the Control Stack:
87 CSP : ControlStack_Range := ControlStack_Range'First;
88
89 -- Registers:
90 subtype RegNames is Character range 'g' .. 'z';
91 type RegTables is array(RegNames range <>) of FZ(1 .. Wordness);
92 Registers : RegTables(RegNames'Range);
93
94 -- Carry/Borrow Flag:
95 Flag : WBool := 0;
96
97 -- Odometer:
98 Ticks : Natural := 0;
99
100 -- The current levels of the three types of nestedness:
101 QuoteLevel : Natural := 0;
102 CommLevel : Natural := 0;
103 CondLevel : Natural := 0;
104
105 -- Prefixed Operators
106 PrevC : Character := ' ';
107 HavePrefix : Boolean := False;
108
109 -- Current Verdict. We run while 'Mu', tape remains, and Ticks under max.
110 Verdict : Peh_Verdicts := Mu;
111 --------------------------------------------------------
112
113
114 -- Determine whether we have reached the given limit of Life:
115 function Exhausted_Life return Boolean is
116 -- If Life = 0, we are in "immortal" mode. Otherwise mortal:
117 MustDie : Boolean :=
118 (Dimensions.Life /= 0) and (Ticks = Dimensions.Life);
119 begin
120 if MustDie then
121 Achtung("WARNING: Exhausted Life ("
122 & Natural'Image(Ticks) & " ticks )");
123 end if;
124 return MustDie;
125 end Exhausted_Life;
126
127
128 -- Clear all state, other than blocks, Control Stack, Tape and Verdict:
129 procedure Zap is
130 begin
131 -- Clear the Data Stack:
132 for i in Stack'Range loop
133 FFA_FZ_Clear(Stack(i));
134 end loop;
135 -- Set SP to bottom:
136 SP := Stack_Positions'First;
137 -- Clear all Registers:
138 for r in RegNames'Range loop
139 FFA_FZ_Clear(Registers(r));
140 end loop;
141 -- Clear Overflow flag:
142 Flag := 0;
143 -- Clear prefix:
144 HavePrefix := False;
145 PrevC := ' ';
146 end Zap;
147
148
149 -- Report a fatal error condition at the current symbol.
150 -- On Unixlikes, this will also end the process and return control to OS.
151 procedure E(S : in String) is
152 begin
153 Zap; -- Jettison all resettable state!
154 Eggog("FATAL: Tick:" & Natural'Image(Ticks) &
155 " IP:" & Tape_Positions'Image(IP) & " : " & S);
156 end E;
157
158
159 -------------------
160 -- Control Stack --
161 -------------------
162
163 -- Push a given Tape Position to the Control Stack:
164 procedure Control_Push(Position : in Tape_Positions) is
165 begin
166 -- First, test for Overflow of Control Stack:
167 if CSP = Control_Stack'Last then
168 E("Control Stack Overflow!");
169 end if;
170
171 -- Push given Tape Position to Control Stack:
172 CSP := CSP + 1;
173 Control_Stack(CSP) := Position;
174 end Control_Push;
175
176
177 -- Pop a Tape Position from the Control Stack:
178 function Control_Pop return Tape_Positions is
179 Position : Tape_Positions;
180 begin
181 -- First, test for Underflow of Control Stack:
182 if CSP = Control_Stack'First then
183 E("Control Stack Underflow!");
184 end if;
185
186 -- Pop a Tape Position from Control Stack:
187 Position := Control_Stack(CSP);
188 Control_Stack(CSP) := Tape_Positions'First;
189 CSP := CSP - 1;
190 return Position;
191 end Control_Pop;
192
193
194 ----------------
195 -- Data Stack --
196 ----------------
197
198 -- Move SP up
199 procedure Push is
200 begin
201 if SP = Stack_Positions'Last then
202 E("Stack Overflow!");
203 else
204 SP := SP + 1;
205 end if;
206 end Push;
207
208
209 -- Discard the top of the stack
210 procedure Drop is
211 begin
212 FFA_FZ_Clear(Stack(SP));
213 SP := SP - 1;
214 end Drop;
215
216
217 -- Check if stack has the necessary N items
218 procedure Want(N : in Positive) is
219 begin
220 if SP < N then
221 E("Stack Underflow!");
222 end if;
223 end Want;
224
225
226 -- Ensure that a divisor is not zero
227 procedure MustNotZero(D : in FZ) is
228 begin
229 if FFA_FZ_ZeroP(D) = 1 then
230 E("Division by Zero!");
231 end if;
232 end MustNotZero;
233
234
235 -- Slide a new hex digit into the FZ on top of stack
236 procedure Ins_Hex_Digit(Digit : in Nibble) is
237 Overflow : WBool := 0;
238 begin
239
240 -- Insert the given nibble, and detect any overflow:
241 FFA_FZ_Insert_Bottom_Nibble(N => Stack(SP),
242 D => Digit,
243 Overflow => Overflow);
244
245 -- Constants which exceed the Width are forbidden:
246 if Overflow = 1 then
247 E("Constant Exceeds Bitness!");
248 end if;
249
250 end;
251
252
253 -- Emit an ASCII representation of N to the terminal
254 procedure Print_FZ(N : in FZ) is
255 S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size
256 begin
257 FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex
258 Write_String(S); -- Print the result to stdout
259 Write_Newline; -- Print newline, for clarity.
260 end Print_FZ;
261
262
263 -- Print a Debug Trace (used in 'QD')
264 procedure Print_Trace is
265 begin
266 -- Print Data Stack Trace:
267 Write_String("Data Stack:");
268 Write_Newline;
269 for i in reverse Stack'First + 1 .. SP loop
270 Write_String(" " & Stack_Positions'Image(i) & " : ");
271 Print_FZ(Stack(i));
272 end loop;
273
274 -- Print Control Stack Trace:
275 Write_String("Control Stack:");
276 Write_Newline;
277 for i in reverse Control_Stack'First + 1 .. CSP loop
278 Write_String(" " & ControlStack_Range'Image(i) & " :"
279 & Tape_Positions'Image(Control_Stack(i)));
280 Write_Newline;
281 end loop;
282
283 -- Print All Registers:
284 Write_String("Registers:");
285 Write_Newline;
286 for r in RegNames'Range loop
287 Write_String(" " & r & " : ");
288 Print_FZ(Registers(r));
289 end loop;
290
291 -- Print Ticks and IP:
292 Write_String("Ticks :" & Natural'Image(Ticks));
293 Write_Newline;
294 Write_String("IP :" & Tape_Positions'Image(IP));
295 Write_Newline;
296 end Print_Trace;
297
298
299 -- Execute a Normal Op
300 procedure Op_Normal(C : in Character) is
301
302 -- Over/underflow output from certain ops
303 F : Word;
304
305 begin
306
307 case C is
308
309 --------------
310 -- Stickies --
311 --------------
312 -- Enter Commented
313 when '(' =>
314 CommLevel := 1;
315
316 -- Exit Commented (but we aren't in it!)
317 when ')' =>
318 E("Mismatched close-comment parenthesis !");
319
320 -- Enter Quoted
321 when '[' =>
322 QuoteLevel := 1;
323
324 -- Exit Quoted (but we aren't in it!)
325 when ']' =>
326 E("Mismatched close-quote bracket !");
327
328 -- Enter a ~taken~ Conditional branch:
329 when '{' =>
330 Want(1);
331 if FFA_FZ_ZeroP(Stack(SP)) = 1 then
332 CondLevel := 1;
333 end if;
334 Drop;
335
336 -- Exit from a ~non-taken~ Conditional branch:
337 -- ... we push a 0, to suppress the 'else' clause
338 when '}' =>
339 Push;
340 FFA_WBool_To_FZ(0, Stack(SP));
341
342 ----------------
343 -- Immediates --
344 ----------------
345
346 -- These operate on the FZ ~currently~ at top of the stack;
347 -- and this means that the stack may NOT be empty.
348
349 when '0' .. '9' =>
350 Want(1);
351 Ins_Hex_Digit(Character'Pos(C) - Character'Pos('0'));
352
353 when 'A' .. 'F' =>
354 Want(1);
355 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A'));
356
357 when 'a' .. 'f' =>
358 Want(1);
359 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
360
361 -------------------------
362 -- Fetch from Register --
363 -------------------------
364 when 'g' .. 'z' =>
365 Push;
366 Stack(SP) := Registers(C); -- Put value of Register on stack
367
368 ------------------
369 -- Stack Motion --
370 ------------------
371
372 -- Push a 0 onto the stack
373 when '.' =>
374 Push;
375 FFA_FZ_Clear(Stack(SP));
376
377 -- Dup
378 when '"' =>
379 Want(1);
380 Push;
381 Stack(SP) := Stack(SP - 1);
382
383 -- Drop
384 when '_' =>
385 Want(1);
386 Drop;
387
388 -- Swap
389 when ''' =>
390 Want(2);
391 FFA_FZ_Swap(Stack(SP), Stack(SP - 1));
392
393 -- Over
394 when '`' =>
395 Want(2);
396 Push;
397 Stack(SP) := Stack(SP - 2);
398
399 ----------------
400 -- Predicates --
401 ----------------
402
403 -- Equality
404 when '=' =>
405 Want(2);
406 FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP),
407 Y => Stack(SP - 1)),
408 Stack(SP - 1));
409 Drop;
410
411 -- Less-Than
412 when '<' =>
413 Want(2);
414 FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1),
415 Y => Stack(SP)),
416 Stack(SP - 1));
417 Drop;
418
419 -- Greater-Than
420 when '>' =>
421 Want(2);
422 FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1),
423 Y => Stack(SP)),
424 Stack(SP - 1));
425 Drop;
426
427 ----------------
428 -- Arithmetic --
429 ----------------
430
431 -- Subtract
432 when '-' =>
433 Want(2);
434 FFA_FZ_Subtract(X => Stack(SP - 1),
435 Y => Stack(SP),
436 Difference => Stack(SP - 1),
437 Underflow => F);
438 Flag := FFA_Word_NZeroP(F);
439 Drop;
440
441 -- Add
442 when '+' =>
443 Want(2);
444 FFA_FZ_Add(X => Stack(SP - 1),
445 Y => Stack(SP),
446 Sum => Stack(SP - 1),
447 Overflow => F);
448 Flag := FFA_Word_NZeroP(F);
449 Drop;
450
451 -- Divide and give Quotient and Remainder
452 when '\' =>
453 Want(2);
454 MustNotZero(Stack(SP));
455 FFA_FZ_IDiv(Dividend => Stack(SP - 1),
456 Divisor => Stack(SP),
457 Quotient => Stack(SP - 1),
458 Remainder => Stack(SP));
459
460 -- Divide and give Quotient only
461 when '/' =>
462 Want(2);
463 MustNotZero(Stack(SP));
464 FFA_FZ_Div(Dividend => Stack(SP - 1),
465 Divisor => Stack(SP),
466 Quotient => Stack(SP - 1));
467 Drop;
468
469 -- Divide and give Remainder only
470 when '%' =>
471 Want(2);
472 MustNotZero(Stack(SP));
473 FFA_FZ_Mod(Dividend => Stack(SP - 1),
474 Divisor => Stack(SP),
475 Remainder => Stack(SP - 1));
476 Drop;
477
478 -- Multiply, give bottom and top halves
479 when '*' =>
480 Want(2);
481 FFA_FZ_Multiply(X => Stack(SP - 1),
482 Y => Stack(SP),
483 XY_Lo => Stack(SP - 1),
484 XY_Hi => Stack(SP));
485
486 -- Square, give bottom and top halves
487 when 'S' =>
488 Want(1);
489 Push;
490 FFA_FZ_Square(X => Stack(SP - 1),
491 XX_Lo => Stack(SP - 1),
492 XX_Hi => Stack(SP));
493
494 -- Greatest Common Divisor (GCD)
495 when 'G' =>
496 Want(2);
497
498 -- Note that GCD(0,0) is not factually zero, or unique.
499 -- But it is permissible to define it as zero.
500 -- (See Ch. 15 discussion.)
501
502 FFA_FZ_Greatest_Common_Divisor(X => Stack(SP - 1),
503 Y => Stack(SP),
504 Result => Stack(SP - 1));
505 Drop;
506
507 -----------------
508 -- Bitwise Ops --
509 -----------------
510
511 -- Bitwise-And
512 when '&' =>
513 Want(2);
514 FFA_FZ_And(X => Stack(SP - 1),
515 Y => Stack(SP),
516 Result => Stack(SP - 1));
517 Drop;
518
519 -- Bitwise-Or
520 when '|' =>
521 Want(2);
522 FFA_FZ_Or(X => Stack(SP - 1),
523 Y => Stack(SP),
524 Result => Stack(SP - 1));
525 Drop;
526
527 -- Bitwise-Xor
528 when '^' =>
529 Want(2);
530 FFA_FZ_Xor(X => Stack(SP - 1),
531 Y => Stack(SP),
532 Result => Stack(SP - 1));
533 Drop;
534
535 -- Bitwise-Not (1s-Complement)
536 when '~' =>
537 Want(1);
538 FFA_FZ_Not(Stack(SP), Stack(SP));
539
540 -----------
541 -- Other --
542 -----------
543
544 -- Push a FZ of RNGolade onto the stack
545 when '?' =>
546 Push;
547 FFA_FZ_Clear(Stack(SP));
548 FZ_Random(RNG, Stack(SP));
549
550 -- mUx
551 when 'U' =>
552 Want(3);
553 FFA_FZ_Mux(X => Stack(SP - 2),
554 Y => Stack(SP - 1),
555 Result => Stack(SP - 2),
556 Sel => FFA_FZ_NZeroP(Stack(SP)));
557 Drop;
558 Drop;
559
560 -- Find the position of eldest nonzero bit, if any exist
561 when 'W' =>
562 Want(1);
563 declare
564 -- Find the measure ( 0 if no 1s, or 1 .. FZBitness )
565 Measure : FZBit_Index := FFA_FZ_Measure(Stack(SP));
566 begin
567 -- Put on top of stack
568 FFA_FZ_Clear(Stack(SP));
569 FFA_FZ_Set_Head(Stack(SP), Word(Measure));
570 end;
571
572 -- Put the Overflow flag on the stack
573 when 'O' =>
574 Push;
575 FFA_WBool_To_FZ(Flag, Stack(SP));
576
577 -- Print the FZ on the top of the stack
578 when '#' =>
579 Want(1);
580 Print_FZ(Stack(SP));
581 Drop;
582
583 -- Zap (reset all resettables)
584 when 'Z' =>
585 Zap;
586
587 -- Put the Peh Program Version on the stack,
588 -- followed by FFA Program Version.
589 when 'V' =>
590 Push;
591 Push;
592 -- Peh Version:
593 FFA_FZ_Clear(Stack(SP - 1));
594 FFA_FZ_Set_Head(Stack(SP - 1), Word(Peh_K_Version));
595 -- FFA Version:
596 FFA_FZ_Clear(Stack(SP));
597 FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
598
599 -- Constant-Time Miller-Rabin Test on N using the given Witness.
600 -- Witness will be used as-is if it conforms to the valid range,
601 -- i.e. 2 <= Witness <= N - 2; else will be transformed into a
602 -- valid Witness via modular arithmetic.
603 -- Outputs ONE if N WAS FOUND composite; ZERO if NOT FOUND.
604 -- Handles degenerate cases of N that M-R per se cannot eat:
605 -- N=0, N=1: ALWAYS 'FOUND COMPOS.'; 2, 3 - ALWAYS 'NOT FOUND'.
606 -- If N is Even and not equal to 2, N is ALWAYS 'FOUND COMPOS.'
607 -- For ALL other N, the output is equal to that of the M-R test.
608 -- At most 1/4 of all possible Witnesses will be 'liars' for
609 -- a particular composite N , i.e. fail to attest to its
610 -- compositivity.
611 when 'P' =>
612 Want(2);
613 declare
614 MR_Result : WBool :=
615 FFA_FZ_MR_Composite_On_Witness(N => Stack(SP - 1),
616 Witness => Stack(SP));
617 begin
618 FFA_WBool_To_FZ(MR_Result, Stack(SP - 1));
619 end;
620 Drop;
621
622 --------------
623 -- Prefixes --
624 --------------
625
626 when
627 'Q' -- 'Quit...'
628 |
629 'L' -- 'Left...'
630 |
631 'R' -- 'Right...'
632 |
633 'M' -- 'Modular...'
634 |
635 '$' -- Pop top of Stack into the following Register...
636 =>
637 HavePrefix := True;
638
639 -------------------
640 -- Control Stack --
641 -------------------
642
643 -- Push current IP (i.e. of THIS Op) to Control Stack.
644 when ':' =>
645 Control_Push(IP);
646
647 -- Conditional Return: Pop top of Stack, and...
648 -- ... if ZERO: simply discard the top of the Control Stack.
649 -- ... if NONZERO: pop top of Control Stack and make it next IP.
650 when ',' =>
651 Want(1);
652 declare
653 Position : Tape_Positions := Control_Pop;
654 begin
655 if FFA_FZ_NZeroP(Stack(SP)) = 1 then
656 IP_Next := Position;
657 end if;
658 end;
659 Drop;
660
661 -- UNconditional Return: Control Stack top popped into IP_Next.
662 when ';' =>
663 IP_Next := Control_Pop;
664
665 ---------------------------------------------------------
666 -- Reserved Ops, i.e. ones we have not defined yet: --
667 ---------------------------------------------------------
668 when '!' | '@' |
669 'H' | 'I' | 'J' | 'K' | 'N' | 'T' | 'X' | 'Y' =>
670
671 E("This Operator is not defined yet: " & C);
672 ---------------------------------------------------------
673
674 ----------
675 -- NOPs --
676 ----------
677
678 -- Unprintables and spaces DO NOTHING:
679 when others =>
680 null;
681
682 end case;
683
684 end Op_Normal;
685
686
687 -- Execute a Prefixed Op
688 procedure Op_Prefixed(Prefix : in Character;
689 O : in Character) is
690
691 -- Report an attempt to execute an undefined Prefix Op:
692 procedure Undefined_Prefix_Op is
693 begin
694 E("Undefined Prefix Op: " & Prefix & O);
695 end Undefined_Prefix_Op;
696
697 begin
698
699 -- Which Prefix Op?
700 case Prefix is
701
702 ---------------------------------------------------------
703 -- Quit...
704 when 'Q' =>
705
706 -- .. Quit how?
707 case O is
708
709 -- ... with a 'Yes' Verdict:
710 when 'Y' =>
711 Verdict := Yes;
712
713 -- ... with a 'No' Verdict:
714 when 'N' =>
715 Verdict := No;
716
717 -- ... with a 'Mu' Verdict: (permitted, but discouraged)
718 when 'M' =>
719 IP_Next := IP; -- Force a 'Mu' Termination
720
721 -- ... with Debug Trace, and a 'Mu' Verdict:
722 when 'D' =>
723 Print_Trace;
724 IP_Next := IP; -- Force a 'Mu' Termination
725
726 -- ... with an explicit Tape-triggered fatal EGGOG!
727 -- The 'QE' curtain call is intended strictly to signal
728 -- catastrophic (e.g. iron) failure from within a Tape
729 -- program ('cosmic ray' scenario) where a ~hardwired
730 -- mechanism~ of any kind appears to have done something
731 -- unexpected; or to abort on a failed test of the RNG;
732 -- or similar hard-stop scenarios, where either physical
733 -- iron, or basic FFA routine must be said to have failed,
734 -- and the continued use of the system itself - dangerous.
735 -- The use of 'QE' for any other purpose is discouraged;
736 -- please do not use it to indicate failed decryption etc.
737 when 'E' =>
738 -- Hard-stop with this eggog:
739 E("Tape-triggered CATASTROPHIC ERROR! " &
740 "Your iron and/or your build of Peh, " &
741 "may be defective! Please consult " &
742 "the author of this Tape.");
743
744 -- ... Unknown (Eggog):
745 when others =>
746 Undefined_Prefix_Op;
747
748 end case;
749
750 ---------------------------------------------------------
751 -- Write into Register...
752 when '$' =>
753
754 -- Eggog if operator gave us a garbage Register name:
755 if O not in RegNames then
756 E("There is no Register '" & O & "' !");
757 end if;
758
759 -- Selected Register exists; move top FZ on stack into it:
760 Want(1);
761 Registers(O) := Stack(SP);
762 Drop;
763
764 ---------------------------------------------------------
765 -- Left...
766 when 'L' =>
767
768 -- Which L-op?
769 case O is
770
771 -- ... Shift :
772 when 'S' =>
773 Want(2);
774 declare
775 -- Number of bit positions to shift by:
776 ShiftCount : FZBit_Index
777 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
778 begin
779 FFA_FZ_Quiet_ShiftLeft(N => Stack(SP - 1),
780 ShiftedN => Stack(SP - 1),
781 Count => ShiftCount);
782 end;
783 Drop;
784
785 -- ... Rotate :
786 when 'R' =>
787 E("Left-Rotate not yet defined!");
788
789 -- ... Unknown (Eggog):
790 when others =>
791 Undefined_Prefix_Op;
792
793 end case;
794 ---------------------------------------------------------
795 -- Right...
796 when 'R' =>
797
798 -- Which R-op?
799 case O is
800
801 -- ... Shift:
802 when 'S' =>
803 Want(2);
804 declare
805 -- Number of bit positions to shift by:
806 ShiftCount : FZBit_Index
807 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
808 begin
809 FFA_FZ_Quiet_ShiftRight(N => Stack(SP - 1),
810 ShiftedN => Stack(SP - 1),
811 Count => ShiftCount);
812 end;
813 Drop;
814
815 -- ... Rotate:
816 when 'R' =>
817 E("Right-Rotate not yet defined!");
818
819 -- 'Right-Multiply', give only lower half of the product XY
820 when '*' =>
821 Want(2);
822 FFA_FZ_Low_Multiply(X => Stack(SP - 1),
823 Y => Stack(SP),
824 XY => Stack(SP - 1));
825 Drop;
826
827 -- ... Unknown (Eggog):
828 when others =>
829 Undefined_Prefix_Op;
830
831 end case;
832 ---------------------------------------------------------
833 -- Modular...
834 when 'M' =>
835
836 -- Which M-op?
837 case O is
838
839 -- ... Multiplication (Conventional) :
840 when '*' =>
841 Want(3);
842 MustNotZero(Stack(SP));
843 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
844 Y => Stack(SP - 1),
845 Modulus => Stack(SP),
846 Product => Stack(SP - 2));
847 Drop;
848 Drop;
849
850 -- ... Squaring (Conventional) :
851 when 'S' =>
852 Want(2);
853 MustNotZero(Stack(SP));
854 FFA_FZ_Modular_Square(X => Stack(SP - 1),
855 Modulus => Stack(SP),
856 Product => Stack(SP - 1));
857 Drop;
858
859 -- ... Exponentiation (Barrettronic) :
860 when 'X' =>
861 Want(3);
862 MustNotZero(Stack(SP));
863 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
864 Exponent => Stack(SP - 1),
865 Modulus => Stack(SP),
866 Result => Stack(SP - 2));
867 Drop;
868 Drop;
869
870 -- ... Unknown (Eggog):
871 when others =>
872 Undefined_Prefix_Op;
873
874 end case;
875 ---------------------------------------------------------
876 -- ... Unknown: (impossible per mechanics, but must handle case)
877 when others =>
878 E("Undefined Prefix: " & Prefix);
879
880 end case;
881
882 end Op_Prefixed;
883
884
885 -- Process a Symbol
886 procedure Op(C : in Character) is
887 begin
888 -- First, see whether we are in a state of nestedness:
889
890 -- ... in a Comment block:
891 if CommLevel > 0 then
892 case C is
893 when ')' => -- Drop a nesting level:
894 CommLevel := CommLevel - 1;
895 when '(' => -- Add a nesting level:
896 CommLevel := CommLevel + 1;
897 when others =>
898 null; -- Other symbols have no effect at all
899 end case;
900
901 -- ... in a Quote block:
902 elsif QuoteLevel > 0 then
903 case C is
904 when ']' => -- Drop a nesting level:
905 QuoteLevel := QuoteLevel - 1;
906 when '[' => -- Add a nesting level:
907 QuoteLevel := QuoteLevel + 1;
908 when others =>
909 null; -- Other symbols have no effect on the level
910 end case;
911
912 -- If we aren't the mode-exiting ']', print current symbol:
913 if QuoteLevel > 0 then
914 Write_Char(C);
915 end if;
916
917 --- ... in a ~taken~ Conditional branch:
918 elsif CondLevel > 0 then
919 case C is
920 when '}' => -- Drop a nesting level:
921 CondLevel := CondLevel - 1;
922
923 -- If we exited the Conditional as a result,
924 -- we push a 1 to trigger the possible 'else' clause:
925 if CondLevel = 0 then
926 Push;
927 FFA_WBool_To_FZ(1, Stack(SP));
928 end if;
929
930 when '{' => -- Add a nesting level:
931 CondLevel := CondLevel + 1;
932 when others =>
933 null; -- Other symbols have no effect on the level
934 end case;
935
936 --- ... if in a prefixed op:
937 elsif HavePrefix then
938
939 -- Drop the prefix-op hammer, until another prefix-op cocks it
940 HavePrefix := False;
941
942 -- Dispatch this op, where prefix is the preceding character
943 Op_Prefixed(Prefix => PrevC, O => C);
944
945 else
946 -- This is a Normal Op, so proceed with the normal rules.
947 Op_Normal(C);
948 end if;
949
950 -- In all cases, save the current symbol as possible prefix:
951 PrevC := C;
952
953 end Op;
954
955 begin
956 -- Reset all resettable state:
957 Zap;
958
959 -- Execution begins with the first Op on the Tape:
960 IP := Tape_Positions'First;
961
962 loop
963
964 -- If current Op is NOT the last Op on the Tape:
965 if IP /= Tape_Positions'Last then
966
967 -- ... then default successor of the current Op is the next one:
968 IP_Next := IP + 1;
969
970 else
971
972 -- ... but if no 'next' Op exists, or quit-with-Mu, we stay put:
973 IP_Next := IP; -- ... this will trigger an exit from the loop.
974
975 end if;
976
977 -- Advance Odometer for every Op (incl. prefixes, in comments, etc) :
978 Ticks := Ticks + 1;
979
980 -- Execute the Op at the current IP:
981 Op(Tape(IP));
982
983 -- Halt when...
984 exit when
985 Verdict /= Mu or -- Got a Verdict, or...
986 IP_Next = IP or -- Reached the end of the Tape, or...
987 Exhausted_Life; -- Exhausted Life.
988
989 -- We did not halt yet, so select the IP of the next Op to fetch:
990 IP := IP_Next;
991
992 end loop;
993
994 -- Warn operator about any unclosed blocks:
995 if CommLevel > 0 then
996 Achtung("WARNING: Tape terminated with an unclosed Comment!");
997 end if;
998
999 if QuoteLevel > 0 then
1000 Achtung("WARNING: Tape terminated with an unclosed Quote!");
1001 end if;
1002
1003 if CondLevel > 0 then
1004 Achtung("WARNING: Tape terminated with an unclosed Conditional!");
1005 end if;
1006
1007 -- Warn operator if we terminated with a non-empty Control Stack.
1008 -- This situation ought to be considered poor style in a Peh Tape;
1009 -- for clarity, Verdicts should be returned from a place near
1010 -- the visually-apparent end of a Tape. However, this is not mandatory.
1011 if CSP /= Control_Stack'First then
1012 Achtung("WARNING: Tape terminated with a non-empty Control Stack!");
1013 end if;
1014
1015 -- We're done with the Tape, so clear the state:
1016 Zap;
1017
1018 -- Return the Verdict:
1019 return Verdict;
1020
1021 end Peh_Machine;
1022
1023 end FFA_Calc;