ffa_ch17_peh.kv

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